source: palm/trunk/SOURCE/pmc_mpi_wrapper_mod.f90 @ 1851

Last change on this file since 1851 was 1851, checked in by maronga, 5 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-2016 Leibniz Universitaet Hannover
18!--------------------------------------------------------------------------------!
19!
20! Current revisions:
21! ------------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: pmc_mpi_wrapper_mod.f90 1851 2016-04-08 13:32:50Z maronga $
27!
28! 1850 2016-04-08 13:29:27Z maronga
29! Module renamed
30!
31!
32! 1808 2016-04-05 19:44:00Z raasch
33! MPI module used by default on all machines
34!
35! 1779 2016-03-03 08:01:28Z raasch
36! kind=dp replaced by wp
37!
38! 1764 2016-02-28 12:45:19Z raasch
39! cpp-statement added (nesting can only be used in parallel mode),
40! kind-parameters adjusted to PALM-kinds
41!
42! 1762 2016-02-25 12:31:13Z hellstea
43! Initial revision by K. Ketelsen
44!
45! Description:
46! ------------
47!
48! MPI Wrapper of Palm Model Coupler
49!------------------------------------------------------------------------------!
50
51#if defined( __parallel )
52   use, intrinsic :: iso_c_binding
53
54#if defined( __mpifh )
55    INCLUDE "mpif.h"
56#else
57    USE MPI
58#endif
59   USE  kinds
60   USE  PMC_handle_communicator, ONLY: m_to_server_comm, m_to_client_comm, m_model_comm, m_model_rank
61   IMPLICIT none
62   PRIVATE
63   SAVE
64
65   INTERFACE PMC_Send_to_Server
66      MODULE PROCEDURE PMC_Send_to_Server_INTEGER
67      MODULE PROCEDURE PMC_Send_to_Server_INTEGER_2
68      MODULE PROCEDURE PMC_Send_to_Server_real_r1
69      MODULE PROCEDURE PMC_Send_to_Server_real_r2
70      MODULE PROCEDURE PMC_Send_to_Server_real_r3
71   END INTERFACE PMC_Send_to_Server
72
73   INTERFACE PMC_Recv_from_Server
74      MODULE PROCEDURE PMC_Recv_from_Server_INTEGER
75      MODULE PROCEDURE PMC_Recv_from_Server_real_r1
76      MODULE PROCEDURE PMC_Recv_from_Server_real_r2
77      MODULE PROCEDURE PMC_Recv_from_Server_real_r3
78   END INTERFACE PMC_Recv_from_Server
79
80   INTERFACE PMC_Send_to_Client
81      MODULE PROCEDURE PMC_Send_to_Client_INTEGER
82      MODULE PROCEDURE PMC_Send_to_Client_real_r1
83      MODULE PROCEDURE PMC_Send_to_Client_real_r2
84      MODULE PROCEDURE PMC_Send_to_Client_real_r3
85   END INTERFACE PMC_Send_to_Client
86
87   INTERFACE PMC_Recv_from_Client
88      MODULE PROCEDURE PMC_Recv_from_Client_INTEGER
89      MODULE PROCEDURE PMC_Recv_from_Client_INTEGER_2
90      MODULE PROCEDURE PMC_Recv_from_Client_real_r1
91      MODULE PROCEDURE PMC_Recv_from_Client_real_r2
92      MODULE PROCEDURE PMC_Recv_from_Client_real_r3
93   END INTERFACE PMC_Recv_from_Client
94
95   INTERFACE PMC_Bcast
96      MODULE PROCEDURE PMC_Bcast_INTEGER
97      MODULE PROCEDURE PMC_Bcast_character
98   END INTERFACE PMC_Bcast
99
100   INTERFACE PMC_Inter_Bcast
101      MODULE PROCEDURE PMC_Inter_Bcast_INTEGER_1
102   END INTERFACE PMC_Inter_Bcast
103
104   INTERFACE PMC_Alloc_mem
105      MODULE PROCEDURE PMC_Alloc_mem_INTEGER_1
106      MODULE PROCEDURE PMC_Alloc_mem_Real_1
107   END INTERFACE PMC_Alloc_mem
108
109   INTERFACE PMC_TIME
110      MODULE PROCEDURE PMC_TIME
111   END INTERFACE PMC_TIME
112
113   PUBLIC PMC_Send_to_Server, PMC_Recv_from_Server
114   PUBLIC PMC_Send_to_Client, PMC_Recv_from_Client
115   PUBLIC PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
116   PUBLIC PMC_TIME
117
118CONTAINS
119
120   SUBROUTINE  PMC_Send_to_Server_INTEGER (buf, n, Server_rank, tag, ierr)
121      IMPLICIT     none
122      INTEGER, DIMENSION(:), INTENT(IN)         :: 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_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
130   
131      return
132   END SUBROUTINE  PMC_Send_to_Server_INTEGER
133
134   SUBROUTINE  PMC_Recv_from_Server_INTEGER (buf, n, Server_rank, tag, ierr)
135      IMPLICIT     none
136      INTEGER, DIMENSION(:), INTENT(OUT)        :: buf
137      INTEGER, INTENT(IN)                       :: n
138      INTEGER, INTENT(IN)                       :: Server_rank
139      INTEGER, INTENT(IN)                       :: tag
140      INTEGER, INTENT(OUT)                      :: ierr
141
142      ierr = 0
143      CALL MPI_Recv (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, &
144         MPI_STATUS_IGNORE, ierr)
145
146      return
147   END SUBROUTINE  PMC_Recv_from_Server_INTEGER
148
149   SUBROUTINE  PMC_Send_to_Server_INTEGER_2 (buf, n, Server_rank, tag, ierr)
150      IMPLICIT     none
151      INTEGER, 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_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
159
160      return
161   END SUBROUTINE  PMC_Send_to_Server_INTEGER_2
162
163   SUBROUTINE  PMC_Send_to_Server_real_r1 (buf, n, Server_rank, tag, ierr)
164
165      IMPLICIT     none
166
167      REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
168      INTEGER, INTENT(IN)                ::  n
169      INTEGER, INTENT(IN)                ::  Server_rank
170      INTEGER, INTENT(IN)                ::  tag
171      INTEGER, INTENT(OUT)               ::  ierr
172
173      ierr = 0
174      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
175
176      return
177   END SUBROUTINE  PMC_Send_to_Server_real_r1
178
179   SUBROUTINE  PMC_Recv_from_Server_real_r1 (buf, n, Server_rank, tag, ierr)
180
181      IMPLICIT     none
182
183      REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf
184      INTEGER, INTENT(IN)                 ::  n
185      INTEGER, INTENT(IN)                 ::  Server_rank
186      INTEGER, INTENT(IN)                 ::  tag
187      INTEGER, INTENT(OUT)                ::  ierr
188
189      ierr = 0
190      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm,     &
191                     MPI_STATUS_IGNORE, ierr)
192
193      return
194   END SUBROUTINE  PMC_Recv_from_Server_real_r1
195
196   SUBROUTINE  PMC_Send_to_Server_real_r2 (buf, n, Server_rank, tag, ierr)
197
198      IMPLICIT     none
199
200      REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
201      INTEGER, INTENT(IN)                  ::  n
202      INTEGER, INTENT(IN)                  ::  Server_rank
203      INTEGER, INTENT(IN)                  ::  tag
204      INTEGER, INTENT(OUT)                 ::  ierr
205
206      ierr = 0
207      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
208
209      return
210   END SUBROUTINE  PMC_Send_to_Server_real_r2
211
212   SUBROUTINE  PMC_Recv_from_Server_real_r2 (buf, n, Server_rank, tag, ierr)
213
214      IMPLICIT     none
215
216      REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
217      INTEGER, INTENT(IN)                   ::  n
218      INTEGER, INTENT(IN)                   ::  Server_rank
219      INTEGER, INTENT(IN)                   ::  tag
220      INTEGER, INTENT(OUT)                  ::  ierr
221
222      ierr = 0
223      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
224         MPI_STATUS_IGNORE, ierr)
225
226      return
227   END SUBROUTINE  PMC_Recv_from_Server_real_r2
228
229   SUBROUTINE  PMC_Send_to_Server_real_r3 (buf, n, Server_rank, tag, ierr)
230
231      IMPLICIT     none
232
233      REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
234      INTEGER, INTENT(IN)                    ::  n
235      INTEGER, INTENT(IN)                    ::  Server_rank
236      INTEGER, INTENT(IN)                    ::  tag
237      INTEGER, INTENT(OUT)                   ::  ierr
238
239      ierr = 0
240      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
241
242      return
243   END SUBROUTINE  PMC_Send_to_Server_real_r3
244
245   SUBROUTINE  PMC_Recv_from_Server_real_r3 (buf, n, Server_rank, tag, ierr)
246
247      IMPLICIT     none
248
249      REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
250      INTEGER, INTENT(IN)                     ::  n
251      INTEGER, INTENT(IN)                     ::  Server_rank
252      INTEGER, INTENT(IN)                     ::  tag
253      INTEGER, INTENT(OUT)                    ::  ierr
254
255      ierr = 0
256      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
257         MPI_STATUS_IGNORE, ierr)
258
259      return
260   END SUBROUTINE  PMC_Recv_from_Server_real_r3
261
262
263   SUBROUTINE  PMC_Send_to_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
264      IMPLICIT     none
265      INTEGER, INTENT(IN)                       :: Client_id
266      INTEGER, DIMENSION(:), INTENT(IN)         :: buf
267      INTEGER, INTENT(IN)                       :: n
268      INTEGER, INTENT(IN)                       :: Client_rank
269      INTEGER, INTENT(IN)                       :: tag
270      INTEGER, INTENT(OUT)                      :: ierr
271
272      ierr = 0
273      CALL MPI_Send (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), ierr)
274
275      return
276   END SUBROUTINE  PMC_Send_to_Client_INTEGER
277
278   SUBROUTINE  PMC_Recv_from_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
279      IMPLICIT     none
280      INTEGER, INTENT(IN)                       :: Client_id
281      INTEGER, DIMENSION(:), INTENT(INOUT)      :: buf
282      INTEGER, INTENT(IN)                       :: n
283      INTEGER, INTENT(IN)                       :: Client_rank
284      INTEGER, INTENT(IN)                       :: tag
285      INTEGER, INTENT(OUT)                      :: ierr
286
287      ierr = 0
288      CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
289         MPI_STATUS_IGNORE, ierr)
290
291      return
292   END SUBROUTINE  PMC_Recv_from_Client_INTEGER
293
294   SUBROUTINE  PMC_Recv_from_Client_INTEGER_2 (Client_id, buf, n, Client_rank, tag, ierr)
295      IMPLICIT     none
296      INTEGER, INTENT(IN)                       :: Client_id
297      INTEGER, DIMENSION(:,:), INTENT(OUT)      :: buf
298      INTEGER, INTENT(IN)                       :: n
299      INTEGER, INTENT(IN)                       :: Client_rank
300      INTEGER, INTENT(IN)                       :: tag
301      INTEGER, INTENT(OUT)                      :: ierr
302
303      ierr = 0
304      CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
305         MPI_STATUS_IGNORE, ierr)
306
307      return
308   END SUBROUTINE  PMC_Recv_from_Client_INTEGER_2
309
310   SUBROUTINE  PMC_Send_to_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
311
312      IMPLICIT     none
313
314      INTEGER, INTENT(IN)                ::  Client_id
315      REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
316      INTEGER, INTENT(IN)                ::  n
317      INTEGER, INTENT(IN)                ::  Client_rank
318      INTEGER, INTENT(IN)                ::  tag
319      INTEGER, INTENT(OUT)               ::  ierr
320
321      ierr = 0
322      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
323         ierr)
324
325      return
326   END SUBROUTINE  PMC_Send_to_Client_real_r1
327
328   SUBROUTINE  PMC_Recv_from_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
329
330      IMPLICIT     none
331
332      INTEGER, INTENT(IN)                   ::  Client_id
333      REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf
334      INTEGER, INTENT(IN)                   ::  n
335      INTEGER, INTENT(IN)                   ::  Client_rank
336      INTEGER, INTENT(IN)                   ::  tag
337      INTEGER, INTENT(OUT)                  ::  ierr
338
339      ierr = 0
340      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
341         MPI_STATUS_IGNORE, ierr)
342
343      return
344   END SUBROUTINE  PMC_Recv_from_Client_real_r1
345
346   SUBROUTINE  PMC_Send_to_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
347
348      IMPLICIT     none
349
350      INTEGER, INTENT(IN)                  ::  Client_id
351      REAL(wp), 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_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
359         ierr)
360
361      return
362   END SUBROUTINE  PMC_Send_to_Client_real_r2
363
364   SUBROUTINE  PMC_Recv_from_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
365
366      IMPLICIT     none
367
368      INTEGER, INTENT(IN)                   ::  Client_id
369      REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
370      INTEGER, INTENT(IN)                   ::  n
371      INTEGER, INTENT(IN)                   ::  Client_rank
372      INTEGER, INTENT(IN)                   ::  tag
373      INTEGER, INTENT(OUT)                  ::  ierr
374
375      ierr = 0
376      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
377         MPI_STATUS_IGNORE, ierr)
378
379      return
380   END SUBROUTINE  PMC_Recv_from_Client_real_r2
381
382   SUBROUTINE  PMC_Send_to_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
383
384      IMPLICIT     none
385
386      INTEGER, INTENT(IN)                    ::  Client_id
387      REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
388      INTEGER, INTENT(IN)                    ::  n
389      INTEGER, INTENT(IN)                    ::  Client_rank
390      INTEGER, INTENT(IN)                    ::  tag
391      INTEGER, INTENT(OUT)                   ::  ierr
392
393      ierr = 0
394      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
395         ierr)
396
397      return
398   END SUBROUTINE  PMC_Send_to_Client_real_r3
399
400   SUBROUTINE  PMC_Recv_from_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
401
402      IMPLICIT     none
403
404      INTEGER, INTENT(IN)                     ::  Client_id
405      REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
406      INTEGER, INTENT(IN)                     :: n
407      INTEGER, INTENT(IN)                     :: Client_rank
408      INTEGER, INTENT(IN)                     :: tag
409      INTEGER, INTENT(OUT)                    :: ierr
410
411      ierr = 0
412      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
413         MPI_STATUS_IGNORE, ierr)
414
415      return
416   END SUBROUTINE  PMC_Recv_from_Client_real_r3
417
418   SUBROUTINE  PMC_Bcast_INTEGER (buf, root_pe, comm, ierr)
419      IMPLICIT     none
420      INTEGER, INTENT(INOUT)                      :: buf
421      INTEGER, INTENT(IN)                         :: root_pe
422      INTEGER, INTENT(IN),optional                :: comm
423      INTEGER, INTENT(OUT),optional               :: ierr
424      !-- local variables
425      INTEGER                                     :: myComm
426      INTEGER                                     :: myErr
427
428      if(present (comm))  then
429         myComm = comm
430      else
431         myComm = m_model_comm
432      end if
433
434      CALL MPI_Bcast (buf, 1, MPI_INTEGER, root_pe, myComm, myErr)
435
436      if(present (ierr))  then
437         ierr = myErr
438      end if
439
440      return
441   END SUBROUTINE  PMC_Bcast_INTEGER
442
443   SUBROUTINE  PMC_Bcast_character (buf, root_pe, comm, ierr)
444      IMPLICIT     none
445      character(len=*), INTENT(INOUT)             :: buf
446      INTEGER, INTENT(IN)                         :: root_pe
447      INTEGER, INTENT(IN),optional                :: comm
448      INTEGER, INTENT(OUT),optional               :: ierr
449      !-- local variables
450      INTEGER                                     :: myComm
451      INTEGER                                     :: myErr
452
453      if(present (comm))  then
454         myComm = comm
455      else
456         myComm = m_model_comm
457      end if
458
459      CALL MPI_Bcast (buf, len(buf), MPI_Character, root_pe, myComm, myErr)
460
461      if(present (ierr))  then
462         ierr = myErr
463      end if
464
465      return
466   END SUBROUTINE  PMC_Bcast_character
467
468   SUBROUTINE  PMC_Inter_Bcast_INTEGER_1 (buf, Client_id, ierr)
469      IMPLICIT     none
470      INTEGER, INTENT(INOUT),DIMENSION(:)         :: buf
471      INTEGER, INTENT(IN),optional                :: Client_id
472      INTEGER, INTENT(OUT),optional               :: ierr
473      !-- local variables
474      INTEGER                                     :: myComm
475      INTEGER                                     :: myErr
476      INTEGER                                     :: root_pe
477
478      !   PE 0 Server Broadcast to all Client PE's
479
480      if(present (Client_id))  then
481         myComm  = m_to_client_comm(Client_id)
482         if(m_model_rank == 0)  then
483            root_pe = MPI_ROOT
484         else
485            root_pe = MPI_PROC_NULL
486         end if
487      else
488         myComm  = m_to_server_comm
489         root_pe = 0
490      end if
491
492      CALL MPI_Bcast (buf, size(buf), MPI_INTEGER, root_pe, myComm, myErr)
493
494      if(present (ierr))  then
495         ierr = myErr
496      end if
497
498      return
499   END SUBROUTINE  PMC_Inter_Bcast_INTEGER_1
500
501!  Allocate  Memory with MPI_Alloc_mem using intermediate C-pointer
502
503   SUBROUTINE  PMC_Alloc_mem_INTEGER_1 (iarray, idim1)
504      IMPLICIT     none
505      INTEGER,DIMENSION(:),POINTER,INTENT(INOUT) :: iarray
506      INTEGER,INTENT(IN)                         :: idim1
507
508      Type(c_ptr)                             :: p_myInd
509      INTEGER,DIMENSION(1)                    :: aShape
510      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
511      INTEGER                                 :: ierr
512
513      WinSize = idim1*c_sizeof(ierr)                          ! Length of INTEGER
514
515      CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
516      aShape(1) = idim1
517      CALL c_f_pointer(p_myInd,iarray,aShape)
518
519      return
520   END SUBROUTINE  PMC_Alloc_mem_INTEGER_1
521
522   SUBROUTINE  PMC_Alloc_mem_Real_1 (array, idim1, base_ptr)
523      IMPLICIT     none
524      REAL(kind=wp),DIMENSION(:),POINTER,INTENT(INOUT) :: array
525      INTEGER(idp),INTENT(IN)                          :: idim1
526      Type(c_ptr),INTENT(OUT),optional                 :: base_ptr
527
528
529      Type(c_ptr)                             :: p_myInd
530      INTEGER,DIMENSION(1)                    :: aShape
531      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
532      INTEGER                                 :: ierr
533
534      WinSize = idim1*wp                          ! Length of INTEGER
535
536      CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
537      aShape(1) = idim1
538      CALL c_f_pointer(p_myInd,array,aShape)
539
540      if(present(base_ptr))   then
541         base_ptr = p_myInd
542      end if
543
544      return
545   END SUBROUTINE  PMC_Alloc_mem_Real_1
546
547   FUNCTION PMC_TIME ()
548      REAL(kind=wp)          :: PMC_TIME
549
550      PMC_TIME = MPI_Wtime ()
551
552      return
553
554    END FUNCTION PMC_TIME
555
556#endif
557 END MODULE pmc_mpi_wrapper
Note: See TracBrowser for help on using the repository browser.