source: palm/trunk/SOURCE/pmc_mpi_wrapper.f90 @ 1763

Last change on this file since 1763 was 1763, checked in by hellstea, 6 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 18.3 KB
Line 
1MODULE pmc_mpi_wrapper
2
3!--------------------------------------------------------------------------------!
4! This file is part of PALM.
5!
6! PALM is free software: you can redistribute it and/or modify it under the terms
7! of the GNU General Public License as published by the Free Software Foundation,
8! either version 3 of the License, or (at your option) any later version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 1997-2015 Leibniz Universitaet Hannover
18!--------------------------------------------------------------------------------!
19!
20! Current revisions:
21! ------------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: pmc_mpi_wrapper.f90 1763 2016-02-25 13:00:19Z hellstea $
27!
28! 1762 2016-02-25 12:31:13Z hellstea
29! Initial revision by K. Ketelsen
30!
31! Description:
32! ------------
33!
34! MPI Wrapper of Palm Model Coupler
35!------------------------------------------------------------------------------!
36
37   use, intrinsic :: iso_c_binding
38
39   USE  mpi
40   USE  kinds,         ONLY: wp
41   USE  PMC_handle_communicator, ONLY: m_to_server_comm, m_to_client_comm, m_model_comm, m_model_rank
42   IMPLICIT none
43   PRIVATE
44   SAVE
45
46   INTEGER, PARAMETER :: dp = wp
47
48
49   ! INTERFACE section
50
51   INTERFACE PMC_Send_to_Server
52      MODULE PROCEDURE PMC_Send_to_Server_INTEGER
53      MODULE PROCEDURE PMC_Send_to_Server_INTEGER_2
54      MODULE PROCEDURE PMC_Send_to_Server_real_r1
55      MODULE PROCEDURE PMC_Send_to_Server_real_r2
56      MODULE PROCEDURE PMC_Send_to_Server_real_r3
57   END INTERFACE PMC_Send_to_Server
58
59   INTERFACE PMC_Recv_from_Server
60      MODULE PROCEDURE PMC_Recv_from_Server_INTEGER
61      MODULE PROCEDURE PMC_Recv_from_Server_real_r1
62      MODULE PROCEDURE PMC_Recv_from_Server_real_r2
63      MODULE PROCEDURE PMC_Recv_from_Server_real_r3
64   END INTERFACE PMC_Recv_from_Server
65
66   INTERFACE PMC_Send_to_Client
67      MODULE PROCEDURE PMC_Send_to_Client_INTEGER
68      MODULE PROCEDURE PMC_Send_to_Client_real_r1
69      MODULE PROCEDURE PMC_Send_to_Client_real_r2
70      MODULE PROCEDURE PMC_Send_to_Client_real_r3
71   END INTERFACE PMC_Send_to_Client
72
73   INTERFACE PMC_Recv_from_Client
74      MODULE PROCEDURE PMC_Recv_from_Client_INTEGER
75      MODULE PROCEDURE PMC_Recv_from_Client_INTEGER_2
76      MODULE PROCEDURE PMC_Recv_from_Client_real_r1
77      MODULE PROCEDURE PMC_Recv_from_Client_real_r2
78      MODULE PROCEDURE PMC_Recv_from_Client_real_r3
79   END INTERFACE PMC_Recv_from_Client
80
81   INTERFACE PMC_Bcast
82      MODULE PROCEDURE PMC_Bcast_INTEGER
83      MODULE PROCEDURE PMC_Bcast_character
84   END INTERFACE PMC_Bcast
85
86   INTERFACE PMC_Inter_Bcast
87      MODULE PROCEDURE PMC_Inter_Bcast_INTEGER_1
88   END INTERFACE PMC_Inter_Bcast
89
90   INTERFACE PMC_Alloc_mem
91      MODULE PROCEDURE PMC_Alloc_mem_INTEGER_1
92      MODULE PROCEDURE PMC_Alloc_mem_Real_1
93   END INTERFACE PMC_Alloc_mem
94
95   INTERFACE PMC_TIME
96      MODULE PROCEDURE PMC_TIME
97   END INTERFACE PMC_TIME
98
99   PUBLIC PMC_Send_to_Server, PMC_Recv_from_Server
100   PUBLIC PMC_Send_to_Client, PMC_Recv_from_Client
101   PUBLIC PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
102   PUBLIC PMC_TIME
103
104CONTAINS
105
106   SUBROUTINE  PMC_Send_to_Server_INTEGER (buf, n, Server_rank, tag, ierr)
107      IMPLICIT     none
108      INTEGER, DIMENSION(:), INTENT(IN)         :: buf
109      INTEGER, INTENT(IN)                       :: n
110      INTEGER, INTENT(IN)                       :: Server_rank
111      INTEGER, INTENT(IN)                       :: tag
112      INTEGER, INTENT(OUT)                      :: ierr
113   
114      ierr = 0
115      CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
116   
117      return
118   END SUBROUTINE  PMC_Send_to_Server_INTEGER
119
120   SUBROUTINE  PMC_Recv_from_Server_INTEGER (buf, n, Server_rank, tag, ierr)
121      IMPLICIT     none
122      INTEGER, DIMENSION(:), INTENT(OUT)        :: buf
123      INTEGER, INTENT(IN)                       :: n
124      INTEGER, INTENT(IN)                       :: Server_rank
125      INTEGER, INTENT(IN)                       :: tag
126      INTEGER, INTENT(OUT)                      :: ierr
127
128      ierr = 0
129      CALL MPI_Recv (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, &
130         MPI_STATUS_IGNORE, ierr)
131
132      return
133   END SUBROUTINE  PMC_Recv_from_Server_INTEGER
134
135   SUBROUTINE  PMC_Send_to_Server_INTEGER_2 (buf, n, Server_rank, tag, ierr)
136      IMPLICIT     none
137      INTEGER, DIMENSION(:,:), INTENT(IN)       :: buf
138      INTEGER, INTENT(IN)                       :: n
139      INTEGER, INTENT(IN)                       :: Server_rank
140      INTEGER, INTENT(IN)                       :: tag
141      INTEGER, INTENT(OUT)                      :: ierr
142
143      ierr = 0
144      CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
145
146      return
147   END SUBROUTINE  PMC_Send_to_Server_INTEGER_2
148
149   SUBROUTINE  PMC_Send_to_Server_real_r1 (buf, n, Server_rank, tag, ierr)
150      IMPLICIT     none
151      REAL(kind=dp), DIMENSION(:), INTENT(IN)   :: buf
152      INTEGER, INTENT(IN)                       :: n
153      INTEGER, INTENT(IN)                       :: Server_rank
154      INTEGER, INTENT(IN)                       :: tag
155      INTEGER, INTENT(OUT)                      :: ierr
156
157      ierr = 0
158      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr)
159
160      return
161   END SUBROUTINE  PMC_Send_to_Server_real_r1
162
163   SUBROUTINE  PMC_Recv_from_Server_real_r1 (buf, n, Server_rank, tag, ierr)
164      IMPLICIT     none
165      REAL(kind=dp), DIMENSION(:), INTENT(OUT)  :: buf
166      INTEGER, INTENT(IN)                       :: n
167      INTEGER, INTENT(IN)                       :: Server_rank
168      INTEGER, INTENT(IN)                       :: tag
169      INTEGER, INTENT(OUT)                      :: ierr
170
171      ierr = 0
172      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
173         MPI_STATUS_IGNORE, ierr)
174
175      return
176   END SUBROUTINE  PMC_Recv_from_Server_real_r1
177
178   SUBROUTINE  PMC_Send_to_Server_real_r2 (buf, n, Server_rank, tag, ierr)
179      IMPLICIT     none
180      REAL(kind=dp), DIMENSION(:,:), INTENT(IN) :: buf
181      INTEGER, INTENT(IN)                       :: n
182      INTEGER, INTENT(IN)                       :: Server_rank
183      INTEGER, INTENT(IN)                       :: tag
184      INTEGER, INTENT(OUT)                      :: ierr
185
186      ierr = 0
187      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr)
188
189      return
190   END SUBROUTINE  PMC_Send_to_Server_real_r2
191
192   SUBROUTINE  PMC_Recv_from_Server_real_r2 (buf, n, Server_rank, tag, ierr)
193      IMPLICIT     none
194      REAL(kind=dp), DIMENSION(:,:),INTENT(OUT) :: buf
195      INTEGER, INTENT(IN)                       :: n
196      INTEGER, INTENT(IN)                       :: Server_rank
197      INTEGER, INTENT(IN)                       :: tag
198      INTEGER, INTENT(OUT)                      :: ierr
199
200      ierr = 0
201      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
202         MPI_STATUS_IGNORE, ierr)
203
204      return
205   END SUBROUTINE  PMC_Recv_from_Server_real_r2
206
207   SUBROUTINE  PMC_Send_to_Server_real_r3 (buf, n, Server_rank, tag, ierr)
208      IMPLICIT     none
209      REAL(kind=dp), DIMENSION(:,:,:), INTENT(IN) :: buf
210      INTEGER, INTENT(IN)                         :: n
211      INTEGER, INTENT(IN)                         :: Server_rank
212      INTEGER, INTENT(IN)                         :: tag
213      INTEGER, INTENT(OUT)                        :: ierr
214
215      ierr = 0
216      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr)
217
218      return
219   END SUBROUTINE  PMC_Send_to_Server_real_r3
220
221   SUBROUTINE  PMC_Recv_from_Server_real_r3 (buf, n, Server_rank, tag, ierr)
222      IMPLICIT     none
223      REAL(kind=dp), DIMENSION(:,:,:),INTENT(OUT) :: buf
224      INTEGER, INTENT(IN)                         :: n
225      INTEGER, INTENT(IN)                         :: Server_rank
226      INTEGER, INTENT(IN)                         :: tag
227      INTEGER, INTENT(OUT)                        :: ierr
228
229      ierr = 0
230      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
231         MPI_STATUS_IGNORE, ierr)
232
233      return
234   END SUBROUTINE  PMC_Recv_from_Server_real_r3
235
236
237   SUBROUTINE  PMC_Send_to_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
238      IMPLICIT     none
239      INTEGER, INTENT(IN)                       :: Client_id
240      INTEGER, DIMENSION(:), INTENT(IN)         :: buf
241      INTEGER, INTENT(IN)                       :: n
242      INTEGER, INTENT(IN)                       :: Client_rank
243      INTEGER, INTENT(IN)                       :: tag
244      INTEGER, INTENT(OUT)                      :: ierr
245
246      ierr = 0
247      CALL MPI_Send (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), ierr)
248
249      return
250   END SUBROUTINE  PMC_Send_to_Client_INTEGER
251
252   SUBROUTINE  PMC_Recv_from_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
253      IMPLICIT     none
254      INTEGER, INTENT(IN)                       :: Client_id
255      INTEGER, DIMENSION(:), INTENT(INOUT)      :: buf
256      INTEGER, INTENT(IN)                       :: n
257      INTEGER, INTENT(IN)                       :: Client_rank
258      INTEGER, INTENT(IN)                       :: tag
259      INTEGER, INTENT(OUT)                      :: ierr
260
261      ierr = 0
262      CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
263         MPI_STATUS_IGNORE, ierr)
264
265      return
266   END SUBROUTINE  PMC_Recv_from_Client_INTEGER
267
268   SUBROUTINE  PMC_Recv_from_Client_INTEGER_2 (Client_id, buf, n, Client_rank, tag, ierr)
269      IMPLICIT     none
270      INTEGER, INTENT(IN)                       :: Client_id
271      INTEGER, DIMENSION(:,:), INTENT(OUT)      :: buf
272      INTEGER, INTENT(IN)                       :: n
273      INTEGER, INTENT(IN)                       :: Client_rank
274      INTEGER, INTENT(IN)                       :: tag
275      INTEGER, INTENT(OUT)                      :: ierr
276
277      ierr = 0
278      CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
279         MPI_STATUS_IGNORE, ierr)
280
281      return
282   END SUBROUTINE  PMC_Recv_from_Client_INTEGER_2
283
284   SUBROUTINE  PMC_Send_to_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
285      IMPLICIT     none
286      INTEGER, INTENT(IN)                       :: Client_id
287      REAL(kind=dp), DIMENSION(:), INTENT(IN)   :: buf
288      INTEGER, INTENT(IN)                       :: n
289      INTEGER, INTENT(IN)                       :: Client_rank
290      INTEGER, INTENT(IN)                       :: tag
291      INTEGER, INTENT(OUT)                      :: ierr
292
293      ierr = 0
294      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
295         ierr)
296
297      return
298   END SUBROUTINE  PMC_Send_to_Client_real_r1
299
300   SUBROUTINE  PMC_Recv_from_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
301      IMPLICIT     none
302      INTEGER, INTENT(IN)                       :: Client_id
303      REAL(kind=dp), DIMENSION(:), INTENT(INOUT):: buf
304      INTEGER, INTENT(IN)                       :: n
305      INTEGER, INTENT(IN)                       :: Client_rank
306      INTEGER, INTENT(IN)                       :: tag
307      INTEGER, INTENT(OUT)                      :: ierr
308
309      ierr = 0
310      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
311         MPI_STATUS_IGNORE, ierr)
312
313      return
314   END SUBROUTINE  PMC_Recv_from_Client_real_r1
315
316   SUBROUTINE  PMC_Send_to_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
317      IMPLICIT     none
318      INTEGER, INTENT(IN)                       :: Client_id
319      REAL(kind=dp), DIMENSION(:,:), INTENT(IN) :: buf
320      INTEGER, INTENT(IN)                       :: n
321      INTEGER, INTENT(IN)                       :: Client_rank
322      INTEGER, INTENT(IN)                       :: tag
323      INTEGER, INTENT(OUT)                      :: ierr
324
325      ierr = 0
326      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
327         ierr)
328
329      return
330   END SUBROUTINE  PMC_Send_to_Client_real_r2
331
332   SUBROUTINE  PMC_Recv_from_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
333      IMPLICIT     none
334      INTEGER, INTENT(IN)                       :: Client_id
335      REAL(kind=dp), DIMENSION(:,:), INTENT(OUT):: buf
336      INTEGER, INTENT(IN)                       :: n
337      INTEGER, INTENT(IN)                       :: Client_rank
338      INTEGER, INTENT(IN)                       :: tag
339      INTEGER, INTENT(OUT)                      :: ierr
340
341      ierr = 0
342      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
343         MPI_STATUS_IGNORE, ierr)
344
345      return
346   END SUBROUTINE  PMC_Recv_from_Client_real_r2
347
348   SUBROUTINE  PMC_Send_to_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
349      IMPLICIT     none
350      INTEGER, INTENT(IN)                         :: Client_id
351      REAL(kind=dp), DIMENSION(:,:,:), INTENT(IN) :: buf
352      INTEGER, INTENT(IN)                         :: n
353      INTEGER, INTENT(IN)                         :: Client_rank
354      INTEGER, INTENT(IN)                         :: tag
355      INTEGER, INTENT(OUT)                        :: ierr
356
357      ierr = 0
358      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
359         ierr)
360
361      return
362   END SUBROUTINE  PMC_Send_to_Client_real_r3
363
364   SUBROUTINE  PMC_Recv_from_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
365      IMPLICIT     none
366      INTEGER, INTENT(IN)                         :: Client_id
367      REAL(kind=dp), DIMENSION(:,:,:), INTENT(OUT):: buf
368      INTEGER, INTENT(IN)                         :: n
369      INTEGER, INTENT(IN)                         :: Client_rank
370      INTEGER, INTENT(IN)                         :: tag
371      INTEGER, INTENT(OUT)                        :: ierr
372
373      ierr = 0
374      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
375         MPI_STATUS_IGNORE, ierr)
376
377      return
378   END SUBROUTINE  PMC_Recv_from_Client_real_r3
379
380   SUBROUTINE  PMC_Bcast_INTEGER (buf, root_pe, comm, ierr)
381      IMPLICIT     none
382      INTEGER, INTENT(INOUT)                      :: buf
383      INTEGER, INTENT(IN)                         :: root_pe
384      INTEGER, INTENT(IN),optional                :: comm
385      INTEGER, INTENT(OUT),optional               :: ierr
386      !-- local variables
387      INTEGER                                     :: myComm
388      INTEGER                                     :: myErr
389
390      if(present (comm))  then
391         myComm = comm
392      else
393         myComm = m_model_comm
394      end if
395
396      CALL MPI_Bcast (buf, 1, MPI_INTEGER, root_pe, myComm, myErr)
397
398      if(present (ierr))  then
399         ierr = myErr
400      end if
401
402      return
403   END SUBROUTINE  PMC_Bcast_INTEGER
404
405   SUBROUTINE  PMC_Bcast_character (buf, root_pe, comm, ierr)
406      IMPLICIT     none
407      character(len=*), INTENT(INOUT)             :: buf
408      INTEGER, INTENT(IN)                         :: root_pe
409      INTEGER, INTENT(IN),optional                :: comm
410      INTEGER, INTENT(OUT),optional               :: ierr
411      !-- local variables
412      INTEGER                                     :: myComm
413      INTEGER                                     :: myErr
414
415      if(present (comm))  then
416         myComm = comm
417      else
418         myComm = m_model_comm
419      end if
420
421      CALL MPI_Bcast (buf, len(buf), MPI_Character, root_pe, myComm, myErr)
422
423      if(present (ierr))  then
424         ierr = myErr
425      end if
426
427      return
428   END SUBROUTINE  PMC_Bcast_character
429
430   SUBROUTINE  PMC_Inter_Bcast_INTEGER_1 (buf, Client_id, ierr)
431      IMPLICIT     none
432      INTEGER, INTENT(INOUT),DIMENSION(:)         :: buf
433      INTEGER, INTENT(IN),optional                :: Client_id
434      INTEGER, INTENT(OUT),optional               :: ierr
435      !-- local variables
436      INTEGER                                     :: myComm
437      INTEGER                                     :: myErr
438      INTEGER                                     :: root_pe
439
440      !   PE 0 Server Broadcast to all Client PE's
441
442      if(present (Client_id))  then
443         myComm  = m_to_client_comm(Client_id)
444         if(m_model_rank == 0)  then
445            root_pe = MPI_ROOT
446         else
447            root_pe = MPI_PROC_NULL
448         end if
449      else
450         myComm  = m_to_server_comm
451         root_pe = 0
452      end if
453
454      CALL MPI_Bcast (buf, size(buf), MPI_INTEGER, root_pe, myComm, myErr)
455
456      if(present (ierr))  then
457         ierr = myErr
458      end if
459
460      return
461   END SUBROUTINE  PMC_Inter_Bcast_INTEGER_1
462
463!  Allocate  Memory with MPI_Alloc_mem using intermediate C-pointer
464
465   SUBROUTINE  PMC_Alloc_mem_INTEGER_1 (iarray, idim1)
466      IMPLICIT     none
467      INTEGER,DIMENSION(:),POINTER,INTENT(INOUT) :: iarray
468      INTEGER,INTENT(IN)                         :: idim1
469
470      Type(c_ptr)                             :: p_myInd
471      INTEGER,DIMENSION(1)                    :: aShape
472      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
473      INTEGER                                 :: ierr
474
475      WinSize = idim1*c_sizeof(ierr)                          ! Length of INTEGER
476
477      CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
478      aShape(1) = idim1
479      CALL c_f_pointer(p_myInd,iarray,aShape)
480
481      return
482   END SUBROUTINE  PMC_Alloc_mem_INTEGER_1
483
484   SUBROUTINE  PMC_Alloc_mem_Real_1 (array, idim1, base_ptr)
485      IMPLICIT     none
486      REAL(kind=wp),DIMENSION(:),POINTER,INTENT(INOUT) :: array
487      INTEGER(kind=8),INTENT(IN)                       :: idim1
488      Type(c_ptr),INTENT(OUT),optional                 :: base_ptr
489
490
491      Type(c_ptr)                             :: p_myInd
492      INTEGER,DIMENSION(1)                    :: aShape
493      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
494      INTEGER                                 :: ierr
495
496      WinSize = idim1*wp                          ! Length of INTEGER
497
498      CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
499      aShape(1) = idim1
500      CALL c_f_pointer(p_myInd,array,aShape)
501
502      if(present(base_ptr))   then
503         base_ptr = p_myInd
504      end if
505
506      return
507   END SUBROUTINE  PMC_Alloc_mem_Real_1
508
509   FUNCTION PMC_TIME ()
510      REAL(kind=wp)          :: PMC_TIME
511
512      PMC_TIME = MPI_Wtime ()
513
514      return
515
516    END FUNCTION PMC_TIME
517
518 END MODULE pmc_mpi_wrapper
Note: See TracBrowser for help on using the repository browser.