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

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

last commit documented / copyright update

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