1 /*
2 * Copyright (c) 2004-2005 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) 2009 Sun Microsystems, Inc. All rights reserved.
13 * Copyright (c) 2011-2012 Cisco Systems, Inc. All rights reserved.
14 * Copyright (c) 2015 Research Organization for Information Science
15 * and Technology (RIST). All rights reserved.
16 * $COPYRIGHT$
17 *
18 * Additional copyrights may follow
19 *
20 * $HEADER$
21 */
22
23 #include "ompi_config.h"
24
25 #include "ompi/mpi/fortran/mpif-h/bindings.h"
26 #include "ompi/mpi/fortran/base/constants.h"
27 #include "ompi/datatype/ompi_datatype.h"
28 #include "ompi/datatype/ompi_datatype_internal.h"
29 #include "ompi/errhandler/errhandler.h"
30 #include "ompi/communicator/communicator.h"
31 #include "ompi/runtime/params.h"
32
33 #if OMPI_BUILD_MPI_PROFILING
34 #if OPAL_HAVE_WEAK_SYMBOLS
35 #pragma weak PMPI_TYPE_MATCH_SIZE = ompi_type_match_size_f
36 #pragma weak pmpi_type_match_size = ompi_type_match_size_f
37 #pragma weak pmpi_type_match_size_ = ompi_type_match_size_f
38 #pragma weak pmpi_type_match_size__ = ompi_type_match_size_f
39
40 #pragma weak PMPI_Type_match_size_f = ompi_type_match_size_f
41 #pragma weak PMPI_Type_match_size_f08 = ompi_type_match_size_f
42 #else
43 OMPI_GENERATE_F77_BINDINGS (PMPI_TYPE_MATCH_SIZE,
44 pmpi_type_match_size,
45 pmpi_type_match_size_,
46 pmpi_type_match_size__,
47 pompi_type_match_size_f,
48 (MPI_Fint *typeclass, MPI_Fint *size, MPI_Fint *type, MPI_Fint *ierr),
49 (typeclass, size, type, ierr) )
50 #endif
51 #endif
52
53 #if OPAL_HAVE_WEAK_SYMBOLS
54 #pragma weak MPI_TYPE_MATCH_SIZE = ompi_type_match_size_f
55 #pragma weak mpi_type_match_size = ompi_type_match_size_f
56 #pragma weak mpi_type_match_size_ = ompi_type_match_size_f
57 #pragma weak mpi_type_match_size__ = ompi_type_match_size_f
58
59 #pragma weak MPI_Type_match_size_f = ompi_type_match_size_f
60 #pragma weak MPI_Type_match_size_f08 = ompi_type_match_size_f
61 #else
62 #if ! OMPI_BUILD_MPI_PROFILING
63 OMPI_GENERATE_F77_BINDINGS (MPI_TYPE_MATCH_SIZE,
64 mpi_type_match_size,
65 mpi_type_match_size_,
66 mpi_type_match_size__,
67 ompi_type_match_size_f,
68 (MPI_Fint *typeclass, MPI_Fint *size, MPI_Fint *type, MPI_Fint *ierr),
69 (typeclass, size, type, ierr) )
70 #else
71 #define ompi_type_match_size_f pompi_type_match_size_f
72 #endif
73 #endif
74
75 static const char FUNC_NAME[] = "MPI_Type_match_size_f";
76
77 /* We cannot use the C function as from Fortran we should check for Fortran types. The only
78 * difference is the type of predefined datatypes we are looking for.
79 */
ompi_type_match_size_f(MPI_Fint * typeclass,MPI_Fint * size,MPI_Fint * type,MPI_Fint * ierr)80 void ompi_type_match_size_f(MPI_Fint *typeclass, MPI_Fint *size, MPI_Fint *type, MPI_Fint *ierr)
81 {
82 int c_ierr;
83 MPI_Datatype c_type;
84 int c_size = OMPI_FINT_2_INT( *size );
85
86 if (MPI_PARAM_CHECK) {
87 OMPI_ERR_INIT_FINALIZE(FUNC_NAME);
88 }
89
90 switch( OMPI_FINT_2_INT(*typeclass) ) {
91 case MPI_TYPECLASS_REAL:
92 c_type = (MPI_Datatype)ompi_datatype_match_size( c_size, OMPI_DATATYPE_FLAG_DATA_FLOAT, OMPI_DATATYPE_FLAG_DATA_FORTRAN );
93 break;
94 case MPI_TYPECLASS_INTEGER:
95 c_type = (MPI_Datatype)ompi_datatype_match_size( c_size, OMPI_DATATYPE_FLAG_DATA_INT, OMPI_DATATYPE_FLAG_DATA_FORTRAN );
96 break;
97 case MPI_TYPECLASS_COMPLEX:
98 c_type = (MPI_Datatype)ompi_datatype_match_size( c_size, OMPI_DATATYPE_FLAG_DATA_COMPLEX, OMPI_DATATYPE_FLAG_DATA_FORTRAN );
99 break;
100 default:
101 c_type = &ompi_mpi_datatype_null.dt;
102 }
103 *type = PMPI_Type_c2f( c_type );
104 if ( c_type != &ompi_mpi_datatype_null.dt ) {
105 c_ierr = MPI_SUCCESS;
106 } else {
107 c_ierr = MPI_ERR_ARG;
108 (void)OMPI_ERRHANDLER_INVOKE(MPI_COMM_WORLD, MPI_ERR_ARG, FUNC_NAME);
109 }
110 if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
111 }
112