1! 2! Copyright (C) by Argonne National Laboratory 3! See COPYRIGHT in top-level directory 4! 5 6module mpi_c_interface_glue 7 8use, intrinsic :: iso_c_binding, only : c_char, C_NULL_CHAR 9 10implicit none 11 12public :: MPIR_Fortran_string_f2c 13public :: MPIR_Fortran_string_c2f 14 15public :: MPII_Comm_copy_attr_f08_proxy 16public :: MPIR_Comm_delete_attr_f08_proxy 17public :: MPIR_Type_copy_attr_f08_proxy 18public :: MPIR_Type_delete_attr_f08_proxy 19public :: MPIR_Win_copy_attr_f08_proxy 20public :: MPIR_Win_delete_attr_f08_proxy 21public :: MPII_Keyval_set_proxy 22public :: MPIR_Grequest_set_lang_fortran 23 24! Bind to C's enum MPIR_Attr_type in mpir_attr_generic.h 25enum, bind(C) 26 enumerator :: MPIR_ATTR_PTR = 0 27 enumerator :: MPIR_ATTR_AINT = 1 28 enumerator :: MPIR_ATTR_INT = 3 29end enum 30 31interface 32 33subroutine MPII_Keyval_set_proxy(keyval, attr_copy_proxy, attr_delete_proxy) bind(C, name="MPII_Keyval_set_proxy") 34 use :: iso_c_binding, only : c_int, c_funptr 35 integer(c_int), value, intent(in) :: keyval 36 type(c_funptr), value, intent(in) :: attr_copy_proxy, attr_delete_proxy 37 ! The subroutine is implemented in attrutil.c on the C side 38end subroutine MPII_Keyval_set_proxy 39 40! Just need to tag the lang is Fortran, so it is fine to bind to *_lang_f77 41subroutine MPIR_Grequest_set_lang_fortran(request) bind(C, name="MPII_Grequest_set_lang_f77") 42 use :: mpi_c_interface_types, only : c_Request 43 integer(c_Request), value, intent(in) :: request 44 ! The subroutine is implemented in mpir_request.c on the C side 45end subroutine MPIR_Grequest_set_lang_fortran 46 47end interface 48 49contains 50 51! Copy Fortran string to C charater array, assuming the C array is one-char 52! longer for the terminating null char. 53! fstring : the Fortran input string 54! cstring : the C output string (with memory already allocated) 55subroutine MPIR_Fortran_string_f2c(fstring, cstring) 56 implicit none 57 character(len=*), intent(in) :: fstring 58 character(kind=c_char), intent(out) :: cstring(:) 59 integer :: i, j 60 logical :: met_non_blank 61 62 ! Trim the leading and trailing blank characters 63 j = 1 64 met_non_blank = .false. 65 do i = 1, len_trim(fstring) 66 if (met_non_blank) then 67 cstring(j) = fstring(i:i) 68 j = j + 1 69 else if (fstring(i:i) /= ' ') then 70 met_non_blank = .true. 71 cstring(j) = fstring(i:i) 72 j = j + 1 73 end if 74 end do 75 76 cstring(j) = C_NULL_CHAR 77end subroutine MPIR_Fortran_string_f2c 78 79! Copy C charater array to Fortran string 80subroutine MPIR_Fortran_string_c2f(cstring, fstring) 81 implicit none 82 character(kind=c_char), intent(in) :: cstring(:) 83 character(len=*), intent(out) :: fstring 84 integer :: i, j, length 85 86 i = 1 87 do while (cstring(i) /= C_NULL_CHAR) 88 fstring(i:i) = cstring(i) 89 i = i + 1 90 end do 91 92 ! Zero out the trailing characters 93 length = len(fstring) 94 do j = i, length 95 fstring(j:j) = ' ' 96 end do 97end subroutine MPIR_Fortran_string_c2f 98 99function MPII_Comm_copy_attr_f08_proxy (user_function, oldcomm, comm_keyval, extra_state, & 100 attr_type, attribute_val_in, attribute_val_out, flag) result(ierror) 101 102 use :: iso_c_binding, only : c_int, c_intptr_t 103 use :: mpi_f08, only : MPI_ADDRESS_KIND, MPI_Comm, MPI_Comm_copy_attr_function 104 use :: mpi_c_interface_types, only : c_Comm 105 106 implicit none 107 108 procedure (MPI_Comm_copy_attr_function) :: user_function 109 integer(c_Comm), value, intent(in) :: oldcomm 110 integer(c_int), value, intent(in) :: comm_keyval 111 integer(c_intptr_t), value, intent(in) :: extra_state 112 integer(kind(MPIR_ATTR_AINT)), value, intent(in) :: attr_type ! Only used in C proxy 113 integer(c_intptr_t), value, intent(in) :: attribute_val_in 114 integer(c_intptr_t), intent(out) :: attribute_val_out 115 integer(c_int), intent(out) :: flag 116 integer(c_int) :: ierror 117 118 type(MPI_Comm) :: oldcomm_f 119 integer :: comm_keyval_f 120 integer(MPI_ADDRESS_KIND) :: extra_state_f 121 integer(MPI_ADDRESS_KIND) :: attribute_val_in_f 122 integer(MPI_ADDRESS_KIND) :: attribute_val_out_f 123 logical :: flag_f 124 integer :: ierror_f 125 126 oldcomm_f%MPI_VAL = oldcomm 127 comm_keyval_f = comm_keyval 128 attribute_val_in_f = attribute_val_in 129 extra_state_f = extra_state 130 131 call user_function(oldcomm_f, comm_keyval_f, extra_state_f, attribute_val_in_f, attribute_val_out_f, flag_f, ierror_f) 132 133 attribute_val_out = attribute_val_out_f 134 flag = merge(1, 0, flag_f) 135 ierror = ierror_f 136 137end function MPII_Comm_copy_attr_f08_proxy 138 139function MPIR_Comm_delete_attr_f08_proxy (user_function, comm, comm_keyval, attr_type, & 140 attribute_val, extra_state) result(ierror) 141 use :: iso_c_binding, only : c_int, c_intptr_t 142 use :: mpi_f08, only : MPI_ADDRESS_KIND, MPI_Comm, MPI_Comm_delete_attr_function 143 use :: mpi_c_interface_types, only : c_Comm 144 145 implicit none 146 147 procedure (MPI_Comm_delete_attr_function) :: user_function 148 integer(c_Comm), value, intent(in) :: comm 149 integer(c_int), value, intent(in) :: comm_keyval 150 integer(kind(MPIR_ATTR_AINT)), value, intent(in) :: attr_type ! Only used in C proxy 151 integer(c_intptr_t), value, intent(in) :: attribute_val 152 integer(c_intptr_t), value, intent(in) :: extra_state 153 integer(c_int) :: ierror 154 155 type(MPI_Comm) :: comm_f 156 integer :: comm_keyval_f 157 integer(MPI_ADDRESS_KIND) :: attribute_val_f 158 integer(MPI_ADDRESS_KIND) :: extra_state_f 159 integer :: ierror_f 160 161 comm_f%MPI_VAL = comm 162 comm_keyval_f = comm_keyval 163 attribute_val_f = attribute_val 164 extra_state_f = extra_state 165 166 call user_function(comm_f, comm_keyval_f, attribute_val_f, extra_state_f, ierror_f) 167 168 ierror = ierror_f 169 170end function MPIR_Comm_delete_attr_f08_proxy 171 172function MPIR_Type_copy_attr_f08_proxy (user_function, oldtype, type_keyval, extra_state, & 173 attr_type, attribute_val_in, attribute_val_out, flag) result(ierror) 174 175 use :: iso_c_binding, only : c_int, c_intptr_t 176 use :: mpi_f08, only : MPI_ADDRESS_KIND, MPI_Datatype, MPI_Type_copy_attr_function 177 use :: mpi_c_interface_types, only : c_Datatype 178 179 implicit none 180 181 procedure (MPI_Type_copy_attr_function) :: user_function 182 integer(c_Datatype), value, intent(in) :: oldtype 183 integer(c_int), value, intent(in) :: type_keyval 184 integer(c_intptr_t), value, intent(in) :: extra_state 185 integer(kind(MPIR_ATTR_AINT)), value, intent(in) :: attr_type 186 integer(c_intptr_t), value, intent(in) :: attribute_val_in 187 integer(c_intptr_t), intent(out) :: attribute_val_out 188 integer(c_int), intent(out) :: flag 189 integer(c_int) :: ierror 190 191 type(MPI_Datatype) :: oldtype_f 192 integer :: type_keyval_f 193 integer(MPI_ADDRESS_KIND) :: extra_state_f 194 integer(MPI_ADDRESS_KIND) :: attribute_val_in_f 195 integer(MPI_ADDRESS_KIND) :: attribute_val_out_f 196 logical :: flag_f 197 integer :: ierror_f 198 199 oldtype_f%MPI_VAL = oldtype 200 type_keyval_f = type_keyval 201 attribute_val_in_f = attribute_val_in 202 extra_state_f = extra_state 203 204 call user_function(oldtype_f, type_keyval_f, extra_state_f, attribute_val_in_f, attribute_val_out_f, flag_f, ierror_f) 205 206 attribute_val_out = attribute_val_out_f 207 flag = merge(1, 0, flag_f) 208 ierror = ierror_f 209 210end function MPIR_Type_copy_attr_f08_proxy 211 212function MPIR_Type_delete_attr_f08_proxy (user_function, type, type_keyval, attr_type, & 213 attribute_val, extra_state) result(ierror) 214 use :: iso_c_binding, only : c_int, c_intptr_t 215 use :: mpi_f08, only : MPI_ADDRESS_KIND, MPI_Datatype, MPI_Type_delete_attr_function 216 use :: mpi_c_interface_types, only : c_Datatype 217 218 implicit none 219 220 procedure (MPI_Type_delete_attr_function) :: user_function 221 integer(c_Datatype), value, intent(in) :: type 222 integer(c_int), value, intent(in) :: type_keyval 223 integer(kind(MPIR_ATTR_AINT)), value, intent(in) :: attr_type ! Only used in C proxy 224 integer(c_intptr_t), value, intent(in) :: attribute_val 225 integer(c_intptr_t), value, intent(in) :: extra_state 226 integer(c_int) :: ierror 227 228 type(MPI_Datatype) :: type_f 229 integer :: type_keyval_f 230 integer(MPI_ADDRESS_KIND) :: attribute_val_f 231 integer(MPI_ADDRESS_KIND) :: extra_state_f 232 integer :: ierror_f 233 234 type_f%MPI_VAL = type 235 type_keyval_f = type_keyval 236 attribute_val_f = attribute_val 237 extra_state_f = extra_state 238 239 call user_function(type_f, type_keyval_f, attribute_val_f, extra_state_f, ierror_f) 240 241 ierror = ierror_f 242 243end function MPIR_Type_delete_attr_f08_proxy 244 245function MPIR_Win_copy_attr_f08_proxy (user_function, oldwin, win_keyval, extra_state, & 246 attr_type, attribute_val_in, attribute_val_out, flag) result(ierror) 247 248 use :: iso_c_binding, only : c_int, c_intptr_t 249 use :: mpi_f08, only : MPI_ADDRESS_KIND, MPI_Win, MPI_Win_copy_attr_function 250 use :: mpi_c_interface_types, only : c_Win 251 252 implicit none 253 254 procedure (MPI_Win_copy_attr_function) :: user_function 255 integer(c_Win), value, intent(in) :: oldwin 256 integer(c_int), value, intent(in) :: win_keyval 257 integer(c_intptr_t), value, intent(in) :: extra_state 258 integer(kind(MPIR_ATTR_AINT)), value, intent(in) :: attr_type ! Only used in C proxy 259 integer(c_intptr_t), value, intent(in) :: attribute_val_in 260 integer(c_intptr_t), intent(out) :: attribute_val_out 261 integer(c_int), intent(out) :: flag 262 integer(c_int) :: ierror 263 264 type(MPI_Win) :: oldwin_f 265 integer :: win_keyval_f 266 integer(MPI_ADDRESS_KIND) :: extra_state_f 267 integer(MPI_ADDRESS_KIND) :: attribute_val_in_f 268 integer(MPI_ADDRESS_KIND) :: attribute_val_out_f 269 logical :: flag_f 270 integer :: ierror_f 271 272 oldwin_f%MPI_VAL = oldwin 273 win_keyval_f = win_keyval 274 attribute_val_in_f = attribute_val_in 275 extra_state_f = extra_state 276 277 call user_function(oldwin_f, win_keyval_f, extra_state_f, attribute_val_in_f, attribute_val_out_f, flag_f, ierror_f) 278 279 attribute_val_out = attribute_val_out_f 280 flag = merge(1, 0, flag_f) 281 ierror = ierror_f 282 283end function MPIR_Win_copy_attr_f08_proxy 284 285function MPIR_Win_delete_attr_f08_proxy (user_function, win, win_keyval, attr_type, & 286 attribute_val, extra_state) result(ierror) 287 use :: iso_c_binding, only : c_int, c_intptr_t 288 use :: mpi_f08, only : MPI_ADDRESS_KIND, MPI_Win, MPI_Win_delete_attr_function 289 use :: mpi_c_interface_types, only : c_Win 290 291 implicit none 292 293 procedure (MPI_Win_delete_attr_function) :: user_function 294 integer(c_Win), value, intent(in) :: win 295 integer(c_int), value, intent(in) :: win_keyval 296 integer(kind(MPIR_ATTR_AINT)), value, intent(in) :: attr_type ! Only used in C proxy 297 integer(c_intptr_t), value, intent(in) :: attribute_val 298 integer(c_intptr_t), value, intent(in) :: extra_state 299 integer(c_int) :: ierror 300 301 type(MPI_Win) :: win_f 302 integer :: win_keyval_f 303 integer(MPI_ADDRESS_KIND) :: attribute_val_f 304 integer(MPI_ADDRESS_KIND) :: extra_state_f 305 integer :: ierror_f 306 307 win_f%MPI_VAL = win 308 win_keyval_f = win_keyval 309 attribute_val_f = attribute_val 310 extra_state_f = extra_state 311 312 call user_function(win_f, win_keyval_f, attribute_val_f, extra_state_f, ierror_f) 313 314 ierror = ierror_f 315 316end function MPIR_Win_delete_attr_f08_proxy 317 318end module mpi_c_interface_glue 319