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

Last change on this file since 1764 was 1764, checked in by raasch, 6 years ago

update of the nested domain system + some bugfixes

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