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

Last change on this file since 1850 was 1850, checked in by maronga, 5 years ago

added _mod string to several filenames to meet the naming convection for modules

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