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

Last change on this file since 1808 was 1808, checked in by raasch, 5 years ago

preprocessor directives using machine dependent flags (lc, ibm, etc.) mostly removed from the code

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