root/ompi/mpi/fortran/mpif-h/error_string_f.c

DEFINITIONS

1. ompi_error_string_f

   1 /*
   2  * Copyright (c) 2004-2007 The Trustees of Indiana University and Indiana
   3  *                         University Research and Technology
   4  *                         Corporation.  All rights reserved.
   5  * Copyright (c) 2004-2005 The University of Tennessee and The University
   6  *                         of Tennessee Research Foundation.  All rights
   7  *                         reserved.
   8  * Copyright (c) 2004-2005 High Performance Computing Center Stuttgart,
   9  *                         University of Stuttgart.  All rights reserved.
  10  * Copyright (c) 2004-2005 The Regents of the University of California.
  11  *                         All rights reserved.
  12  * Copyright (c) 2006-2012 Cisco Systems, Inc.  All rights reserved.
  13  * Copyright (c) 2015-2017 Research Organization for Information Science
  14  *                         and Technology (RIST). All rights reserved.
  15  * $COPYRIGHT$
  16  *
  17  * Additional copyrights may follow
  18  *
  19  * $HEADER$
  20  */
  21 
  22 #include "ompi_config.h"
  23 
  24 #include "ompi/mpi/fortran/mpif-h/bindings.h"
  25 #include "ompi/mpi/fortran/base/fortran_base_strings.h"
  26 #include "ompi/constants.h"
  27 #include "ompi/communicator/communicator.h"
  28 
  29 #if OMPI_BUILD_MPI_PROFILING
  30 #if OPAL_HAVE_WEAK_SYMBOLS
  31 #pragma weak PMPI_ERROR_STRING = ompi_error_string_f
  32 #pragma weak pmpi_error_string = ompi_error_string_f
  33 #pragma weak pmpi_error_string_ = ompi_error_string_f
  34 #pragma weak pmpi_error_string__ = ompi_error_string_f
  35 
  36 #pragma weak PMPI_Error_string_f = ompi_error_string_f
  37 #pragma weak PMPI_Error_string_f08 = ompi_error_string_f
  38 #else
  39 OMPI_GENERATE_F77_BINDINGS (PMPI_ERROR_STRING,
  40                             pmpi_error_string,
  41                             pmpi_error_string_,
  42                             pmpi_error_string__,
  43                             pompi_error_string_f,
  44                             (MPI_Fint *errorcode, char *string, MPI_Fint *resultlen, MPI_Fint *ierr, int string_len),
  45                             (errorcode, string, resultlen, ierr, string_len) )
  46 #endif
  47 #endif
  48 
  49 #if OPAL_HAVE_WEAK_SYMBOLS
  50 #pragma weak MPI_ERROR_STRING = ompi_error_string_f
  51 #pragma weak mpi_error_string = ompi_error_string_f
  52 #pragma weak mpi_error_string_ = ompi_error_string_f
  53 #pragma weak mpi_error_string__ = ompi_error_string_f
  54 
  55 #pragma weak MPI_Error_string_f = ompi_error_string_f
  56 #pragma weak MPI_Error_string_f08 = ompi_error_string_f
  57 #else
  58 #if ! OMPI_BUILD_MPI_PROFILING
  59 OMPI_GENERATE_F77_BINDINGS (MPI_ERROR_STRING,
  60                             mpi_error_string,
  61                             mpi_error_string_,
  62                             mpi_error_string__,
  63                             ompi_error_string_f,
  64                             (MPI_Fint *errorcode, char *string, MPI_Fint *resultlen, MPI_Fint *ierr, int string_len),
  65                             (errorcode, string, resultlen, ierr, string_len) )
  66 #else
  67 #define ompi_error_string_f pompi_error_string_f
  68 #endif
  69 #endif
  70 
  71 
  72 static const char FUNC_NAME[] = "MPI_ERROR_STRING";
  73 
  74 /* Note that the string_len parameter is silently added by the Fortran
  75    compiler, and will be filled in with the actual length of the
  76    character array from the caller.  Hence, it's the max length of the
  77    string that we can use. */
  78 
  79 void ompi_error_string_f(MPI_Fint *errorcode, char *string,
  80                         MPI_Fint *resultlen, MPI_Fint *ierr, int string_len)
  81 {
  82     int c_ierr, ret;
  83     char c_string[MPI_MAX_ERROR_STRING + 1];
  84     OMPI_SINGLE_NAME_DECL(resultlen);
  85 
  86     c_ierr = PMPI_Error_string(OMPI_FINT_2_INT(*errorcode),
  87                               c_string,
  88                               OMPI_SINGLE_NAME_CONVERT(resultlen)
  89                               );
  90     if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
  91 
  92     if (MPI_SUCCESS == c_ierr) {
  93         OMPI_SINGLE_INT_2_FINT(resultlen);
  94         if (OMPI_SUCCESS != (ret = ompi_fortran_string_c2f(c_string, string,
  95                                                            string_len))) {
  96             c_ierr = OMPI_ERRHANDLER_INVOKE(MPI_COMM_WORLD, ret, FUNC_NAME);
  97             if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
  98         }
  99     }
 100 }