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

Last change on this file since 1766 was 1765, checked in by raasch, 8 years ago

last commit documented

  • 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!
23!
24! Former revisions:
25! -----------------
26! $Id: pmc_mpi_wrapper.f90 1765 2016-02-28 13:30:40Z raasch $
27!
28! 1764 2016-02-28 12:45:19Z raasch
29! cpp-statement added (nesting can only be used in parallel mode),
30! kind-parameters adjusted to PALM-kinds
31!
32! 1762 2016-02-25 12:31:13Z hellstea
33! Initial revision by K. Ketelsen
34!
35! Description:
36! ------------
37!
38! MPI Wrapper of Palm Model Coupler
39!------------------------------------------------------------------------------!
40
41#if defined( __parallel )
42   use, intrinsic :: iso_c_binding
43
44#if defined( __lc )
45    USE MPI
46#else
47    INCLUDE "mpif.h"
48#endif
49   USE  kinds
50   USE  PMC_handle_communicator, ONLY: m_to_server_comm, m_to_client_comm, m_model_comm, m_model_rank
51   IMPLICIT none
52   PRIVATE
53   SAVE
54
55!-- TO_DO: what is the meaning of this? Could variables declared in this module
56!--        also have single precision?
57!   INTEGER, PARAMETER :: dp = wp
58
59
60   ! INTERFACE section
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      IMPLICIT     none
162!--   TO_DO: has buf always to be of dp-kind, or can wp used here
163!--          this effects all respective declarations in this file
164      REAL(kind=dp), 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_DOUBLE_PRECISION, 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      IMPLICIT     none
178      REAL(kind=dp), DIMENSION(:), INTENT(OUT)  :: buf
179      INTEGER, INTENT(IN)                       :: n
180      INTEGER, INTENT(IN)                       :: Server_rank
181      INTEGER, INTENT(IN)                       :: tag
182      INTEGER, INTENT(OUT)                      :: ierr
183
184      ierr = 0
185      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
186         MPI_STATUS_IGNORE, ierr)
187
188      return
189   END SUBROUTINE  PMC_Recv_from_Server_real_r1
190
191   SUBROUTINE  PMC_Send_to_Server_real_r2 (buf, n, Server_rank, tag, ierr)
192      IMPLICIT     none
193      REAL(kind=dp), 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_DOUBLE_PRECISION, 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      IMPLICIT     none
207      REAL(kind=dp), DIMENSION(:,:),INTENT(OUT) :: buf
208      INTEGER, INTENT(IN)                       :: n
209      INTEGER, INTENT(IN)                       :: Server_rank
210      INTEGER, INTENT(IN)                       :: tag
211      INTEGER, INTENT(OUT)                      :: ierr
212
213      ierr = 0
214      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
215         MPI_STATUS_IGNORE, ierr)
216
217      return
218   END SUBROUTINE  PMC_Recv_from_Server_real_r2
219
220   SUBROUTINE  PMC_Send_to_Server_real_r3 (buf, n, Server_rank, tag, ierr)
221      IMPLICIT     none
222      REAL(kind=dp), DIMENSION(:,:,:), INTENT(IN) :: buf
223      INTEGER, INTENT(IN)                         :: n
224      INTEGER, INTENT(IN)                         :: Server_rank
225      INTEGER, INTENT(IN)                         :: tag
226      INTEGER, INTENT(OUT)                        :: ierr
227
228      ierr = 0
229      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr)
230
231      return
232   END SUBROUTINE  PMC_Send_to_Server_real_r3
233
234   SUBROUTINE  PMC_Recv_from_Server_real_r3 (buf, n, Server_rank, tag, ierr)
235      IMPLICIT     none
236      REAL(kind=dp), DIMENSION(:,:,:),INTENT(OUT) :: buf
237      INTEGER, INTENT(IN)                         :: n
238      INTEGER, INTENT(IN)                         :: Server_rank
239      INTEGER, INTENT(IN)                         :: tag
240      INTEGER, INTENT(OUT)                        :: ierr
241
242      ierr = 0
243      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
244         MPI_STATUS_IGNORE, ierr)
245
246      return
247   END SUBROUTINE  PMC_Recv_from_Server_real_r3
248
249
250   SUBROUTINE  PMC_Send_to_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
251      IMPLICIT     none
252      INTEGER, INTENT(IN)                       :: Client_id
253      INTEGER, DIMENSION(:), INTENT(IN)         :: buf
254      INTEGER, INTENT(IN)                       :: n
255      INTEGER, INTENT(IN)                       :: Client_rank
256      INTEGER, INTENT(IN)                       :: tag
257      INTEGER, INTENT(OUT)                      :: ierr
258
259      ierr = 0
260      CALL MPI_Send (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), ierr)
261
262      return
263   END SUBROUTINE  PMC_Send_to_Client_INTEGER
264
265   SUBROUTINE  PMC_Recv_from_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
266      IMPLICIT     none
267      INTEGER, INTENT(IN)                       :: Client_id
268      INTEGER, DIMENSION(:), INTENT(INOUT)      :: buf
269      INTEGER, INTENT(IN)                       :: n
270      INTEGER, INTENT(IN)                       :: Client_rank
271      INTEGER, INTENT(IN)                       :: tag
272      INTEGER, INTENT(OUT)                      :: ierr
273
274      ierr = 0
275      CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
276         MPI_STATUS_IGNORE, ierr)
277
278      return
279   END SUBROUTINE  PMC_Recv_from_Client_INTEGER
280
281   SUBROUTINE  PMC_Recv_from_Client_INTEGER_2 (Client_id, buf, n, Client_rank, tag, ierr)
282      IMPLICIT     none
283      INTEGER, INTENT(IN)                       :: Client_id
284      INTEGER, DIMENSION(:,:), INTENT(OUT)      :: buf
285      INTEGER, INTENT(IN)                       :: n
286      INTEGER, INTENT(IN)                       :: Client_rank
287      INTEGER, INTENT(IN)                       :: tag
288      INTEGER, INTENT(OUT)                      :: ierr
289
290      ierr = 0
291      CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
292         MPI_STATUS_IGNORE, ierr)
293
294      return
295   END SUBROUTINE  PMC_Recv_from_Client_INTEGER_2
296
297   SUBROUTINE  PMC_Send_to_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
298      IMPLICIT     none
299      INTEGER, INTENT(IN)                       :: Client_id
300      REAL(kind=dp), DIMENSION(:), INTENT(IN)   :: buf
301      INTEGER, INTENT(IN)                       :: n
302      INTEGER, INTENT(IN)                       :: Client_rank
303      INTEGER, INTENT(IN)                       :: tag
304      INTEGER, INTENT(OUT)                      :: ierr
305
306      ierr = 0
307      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
308         ierr)
309
310      return
311   END SUBROUTINE  PMC_Send_to_Client_real_r1
312
313   SUBROUTINE  PMC_Recv_from_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
314      IMPLICIT     none
315      INTEGER, INTENT(IN)                       :: Client_id
316      REAL(kind=dp), DIMENSION(:), INTENT(INOUT):: buf
317      INTEGER, INTENT(IN)                       :: n
318      INTEGER, INTENT(IN)                       :: Client_rank
319      INTEGER, INTENT(IN)                       :: tag
320      INTEGER, INTENT(OUT)                      :: ierr
321
322      ierr = 0
323      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
324         MPI_STATUS_IGNORE, ierr)
325
326      return
327   END SUBROUTINE  PMC_Recv_from_Client_real_r1
328
329   SUBROUTINE  PMC_Send_to_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
330      IMPLICIT     none
331      INTEGER, INTENT(IN)                       :: Client_id
332      REAL(kind=dp), DIMENSION(:,:), INTENT(IN) :: buf
333      INTEGER, INTENT(IN)                       :: n
334      INTEGER, INTENT(IN)                       :: Client_rank
335      INTEGER, INTENT(IN)                       :: tag
336      INTEGER, INTENT(OUT)                      :: ierr
337
338      ierr = 0
339      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
340         ierr)
341
342      return
343   END SUBROUTINE  PMC_Send_to_Client_real_r2
344
345   SUBROUTINE  PMC_Recv_from_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
346      IMPLICIT     none
347      INTEGER, INTENT(IN)                       :: Client_id
348      REAL(kind=dp), DIMENSION(:,:), INTENT(OUT):: 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_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
356         MPI_STATUS_IGNORE, ierr)
357
358      return
359   END SUBROUTINE  PMC_Recv_from_Client_real_r2
360
361   SUBROUTINE  PMC_Send_to_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
362      IMPLICIT     none
363      INTEGER, INTENT(IN)                         :: Client_id
364      REAL(kind=dp), DIMENSION(:,:,:), INTENT(IN) :: buf
365      INTEGER, INTENT(IN)                         :: n
366      INTEGER, INTENT(IN)                         :: Client_rank
367      INTEGER, INTENT(IN)                         :: tag
368      INTEGER, INTENT(OUT)                        :: ierr
369
370      ierr = 0
371      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
372         ierr)
373
374      return
375   END SUBROUTINE  PMC_Send_to_Client_real_r3
376
377   SUBROUTINE  PMC_Recv_from_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
378      IMPLICIT     none
379      INTEGER, INTENT(IN)                         :: Client_id
380      REAL(kind=dp), DIMENSION(:,:,:), INTENT(OUT):: 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_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
388         MPI_STATUS_IGNORE, ierr)
389
390      return
391   END SUBROUTINE  PMC_Recv_from_Client_real_r3
392
393   SUBROUTINE  PMC_Bcast_INTEGER (buf, root_pe, comm, ierr)
394      IMPLICIT     none
395      INTEGER, INTENT(INOUT)                      :: buf
396      INTEGER, INTENT(IN)                         :: root_pe
397      INTEGER, INTENT(IN),optional                :: comm
398      INTEGER, INTENT(OUT),optional               :: ierr
399      !-- local variables
400      INTEGER                                     :: myComm
401      INTEGER                                     :: myErr
402
403      if(present (comm))  then
404         myComm = comm
405      else
406         myComm = m_model_comm
407      end if
408
409      CALL MPI_Bcast (buf, 1, MPI_INTEGER, root_pe, myComm, myErr)
410
411      if(present (ierr))  then
412         ierr = myErr
413      end if
414
415      return
416   END SUBROUTINE  PMC_Bcast_INTEGER
417
418   SUBROUTINE  PMC_Bcast_character (buf, root_pe, comm, ierr)
419      IMPLICIT     none
420      character(len=*), 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, len(buf), MPI_Character, root_pe, myComm, myErr)
435
436      if(present (ierr))  then
437         ierr = myErr
438      end if
439
440      return
441   END SUBROUTINE  PMC_Bcast_character
442
443   SUBROUTINE  PMC_Inter_Bcast_INTEGER_1 (buf, Client_id, ierr)
444      IMPLICIT     none
445      INTEGER, INTENT(INOUT),DIMENSION(:)         :: buf
446      INTEGER, INTENT(IN),optional                :: Client_id
447      INTEGER, INTENT(OUT),optional               :: ierr
448      !-- local variables
449      INTEGER                                     :: myComm
450      INTEGER                                     :: myErr
451      INTEGER                                     :: root_pe
452
453      !   PE 0 Server Broadcast to all Client PE's
454
455      if(present (Client_id))  then
456         myComm  = m_to_client_comm(Client_id)
457         if(m_model_rank == 0)  then
458            root_pe = MPI_ROOT
459         else
460            root_pe = MPI_PROC_NULL
461         end if
462      else
463         myComm  = m_to_server_comm
464         root_pe = 0
465      end if
466
467      CALL MPI_Bcast (buf, size(buf), MPI_INTEGER, root_pe, myComm, myErr)
468
469      if(present (ierr))  then
470         ierr = myErr
471      end if
472
473      return
474   END SUBROUTINE  PMC_Inter_Bcast_INTEGER_1
475
476!  Allocate  Memory with MPI_Alloc_mem using intermediate C-pointer
477
478   SUBROUTINE  PMC_Alloc_mem_INTEGER_1 (iarray, idim1)
479      IMPLICIT     none
480      INTEGER,DIMENSION(:),POINTER,INTENT(INOUT) :: iarray
481      INTEGER,INTENT(IN)                         :: idim1
482
483      Type(c_ptr)                             :: p_myInd
484      INTEGER,DIMENSION(1)                    :: aShape
485      INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize
486      INTEGER                                 :: ierr
487
488      WinSize = idim1*c_sizeof(ierr)                          ! Length of INTEGER
489
490      CALL MPI_Alloc_mem  (WinSize , MPI_INFO_NULL, p_myInd, ierr);
491      aShape(1) = idim1
492      CALL c_f_pointer(p_myInd,iarray,aShape)
493
494      return
495   END SUBROUTINE  PMC_Alloc_mem_INTEGER_1
496
497   SUBROUTINE  PMC_Alloc_mem_Real_1 (array, idim1, base_ptr)
498      IMPLICIT     none
499      REAL(kind=wp),DIMENSION(:),POINTER,INTENT(INOUT) :: array
500      INTEGER(idp),INTENT(IN)                          :: idim1
501      Type(c_ptr),INTENT(OUT),optional                 :: base_ptr
502
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*wp                          ! 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,array,aShape)
514
515      if(present(base_ptr))   then
516         base_ptr = p_myInd
517      end if
518
519      return
520   END SUBROUTINE  PMC_Alloc_mem_Real_1
521
522   FUNCTION PMC_TIME ()
523      REAL(kind=wp)          :: PMC_TIME
524
525      PMC_TIME = MPI_Wtime ()
526
527      return
528
529    END FUNCTION PMC_TIME
530
531#endif
532 END MODULE pmc_mpi_wrapper
Note: See TracBrowser for help on using the repository browser.