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

Last change on this file since 4124 was 3655, checked in by knoop, 6 years ago

Bugfix: made "unit" and "found" intend INOUT in module interface subroutines + automatic copyright update

  • Property svn:keywords set to Id
File size: 21.0 KB
Line 
1 MODULE pmc_mpi_wrapper
2
3!------------------------------------------------------------------------------!
4! This file is part of the PALM model system.
5!
6! PALM is free software: you can redistribute it and/or modify it under the
7! terms of the GNU General Public License as published by the Free Software
8! Foundation, either version 3 of the License, or (at your option) any later
9! version.
10!
11! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
12! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
13! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
14!
15! You should have received a copy of the GNU General Public License along with
16! PALM. If not, see <http://www.gnu.org/licenses/>.
17!
18! Copyright 1997-2019 Leibniz Universitaet Hannover
19!------------------------------------------------------------------------------!
20!
21! Current revisions:
22! ------------------
23!
24!
25! Former revisions:
26! -----------------
27! $Id: pmc_mpi_wrapper_mod.f90 3655 2019-01-07 16:51:22Z gronemeier $
28! Extent interface by logical buffer
29!
30! 2936 2018-03-27 14:49:27Z suehring
31! Bugfix: wrong placement of include 'mpif.h' corrected
32!
33! 2809 2018-02-15 09:55:58Z schwenkel
34! Bugfix for gfortran: Replace the function C_SIZEOF with STORAGE_SIZE
35!
36! 2718 2018-01-02 08:49:38Z maronga
37! Corrected "Former revisions" section
38!
39! 2696 2017-12-14 17:12:51Z kanani
40! Change in file header (GPL part)
41!
42! 2599 2017-11-01 13:18:45Z hellstea
43! Some cleanup and commenting improvements only.
44!
45! 2101 2017-01-05 16:42:31Z suehring
46!
47! 2000 2016-08-20 18:09:15Z knoop
48! Forced header and separation lines into 80 columns
49!
50! 1901 2016-05-04 15:39:38Z raasch
51! Code clean up. The words server/client changed to parent/child.
52!
53! 1900 2016-05-04 15:27:53Z raasch
54! re-formatted to match PALM style
55!
56! 1850 2016-04-08 13:29:27Z maronga
57! Module renamed
58!
59!
60! 1808 2016-04-05 19:44:00Z raasch
61! MPI module used by default on all machines
62!
63! 1779 2016-03-03 08:01:28Z raasch
64! kind=dp replaced by wp
65!
66! 1764 2016-02-28 12:45:19Z raasch
67! cpp-statement added (nesting can only be used in parallel mode),
68! kind-parameters adjusted to PALM-kinds
69!
70! 1762 2016-02-25 12:31:13Z hellstea
71! Initial revision by K. Ketelsen
72!
73! Description:
74! ------------
75!
76! MPI Wrapper of Palm Model Coupler
77!-------------------------------------------------------------------------------!
78
79#if defined( __parallel )
80    USE, INTRINSIC ::  ISO_C_BINDING
81
82#if !defined( __mpifh )
83    USE MPI
84#endif
85
86    USE kinds
87    USE pmc_handle_communicator,                                                &
88        ONLY: m_model_comm, m_model_rank, m_to_parent_comm, m_to_child_comm
89
90    IMPLICIT NONE
91
92#if defined( __mpifh )
93    INCLUDE "mpif.h"
94#endif
95
96    PRIVATE
97    SAVE
98
99    INTERFACE pmc_send_to_parent
100       MODULE PROCEDURE pmc_send_to_parent_integer
101       MODULE PROCEDURE pmc_send_to_parent_integer_2
102       MODULE PROCEDURE pmc_send_to_parent_real_r1
103       MODULE PROCEDURE pmc_send_to_parent_real_r2
104       MODULE PROCEDURE pmc_send_to_parent_real_r3
105    END INTERFACE pmc_send_to_parent
106
107    INTERFACE pmc_recv_from_parent
108       MODULE PROCEDURE pmc_recv_from_parent_logical
109       MODULE PROCEDURE pmc_recv_from_parent_integer
110       MODULE PROCEDURE pmc_recv_from_parent_real_r1
111       MODULE PROCEDURE pmc_recv_from_parent_real_r2
112       MODULE PROCEDURE pmc_recv_from_parent_real_r3
113    END INTERFACE pmc_recv_from_parent
114
115    INTERFACE pmc_send_to_child
116       MODULE PROCEDURE pmc_send_to_child_logical
117       MODULE PROCEDURE pmc_send_to_child_integer
118       MODULE PROCEDURE pmc_send_to_child_real_r1
119       MODULE PROCEDURE pmc_send_to_child_real_r2
120       MODULE PROCEDURE pmc_send_to_child_real_r3
121    END INTERFACE pmc_send_to_child
122
123    INTERFACE pmc_recv_from_child
124       MODULE PROCEDURE pmc_recv_from_child_integer
125       MODULE PROCEDURE pmc_recv_from_child_integer_2
126       MODULE PROCEDURE pmc_recv_from_child_real_r1
127       MODULE PROCEDURE pmc_recv_from_child_real_r2
128       MODULE PROCEDURE pmc_recv_from_child_real_r3
129    END INTERFACE pmc_recv_from_child
130
131    INTERFACE pmc_bcast
132       MODULE PROCEDURE pmc_bcast_integer
133       MODULE PROCEDURE pmc_bcast_character
134    END INTERFACE pmc_bcast
135
136    INTERFACE pmc_inter_bcast
137       MODULE PROCEDURE pmc_inter_bcast_integer_1
138    END INTERFACE pmc_inter_bcast
139
140    INTERFACE pmc_alloc_mem
141       MODULE PROCEDURE pmc_alloc_mem_integer_1
142       MODULE PROCEDURE pmc_alloc_mem_Real_1
143    END INTERFACE pmc_alloc_mem
144
145    INTERFACE pmc_time
146       MODULE PROCEDURE pmc_time
147    END INTERFACE pmc_time
148
149    PUBLIC pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_recv_from_child,      &
150           pmc_recv_from_parent, pmc_send_to_child, pmc_send_to_parent,         &
151           pmc_time
152
153 CONTAINS
154
155
156 SUBROUTINE pmc_recv_from_parent_logical( buf, n, parent_rank, tag, ierr )
157
158    IMPLICIT NONE
159
160    INTEGER, INTENT(IN)                ::  n            !<
161    INTEGER, INTENT(IN)                ::  parent_rank  !<
162    INTEGER, INTENT(IN)                ::  tag          !<
163    INTEGER, INTENT(OUT)               ::  ierr         !<
164
165    LOGICAL, INTENT(OUT)               ::  buf          !<
166   
167    ierr = 0
168    CALL MPI_RECV( buf, n, MPI_LOGICAL, parent_rank, tag, m_to_parent_comm,    &
169                   MPI_STATUS_IGNORE, ierr )
170
171 END SUBROUTINE pmc_recv_from_parent_logical
172
173 SUBROUTINE pmc_send_to_child_logical( child_id, buf, n, child_rank, tag,      &
174                                       ierr )
175
176    IMPLICIT NONE
177
178    INTEGER, INTENT(IN)               ::  child_id     !<
179    INTEGER, INTENT(IN)               ::  n            !<
180    INTEGER, INTENT(IN)               ::  child_rank   !<
181    INTEGER, INTENT(IN)               ::  tag          !<
182    INTEGER, INTENT(OUT)              ::  ierr         !<
183
184    LOGICAL, INTENT(IN)               ::  buf          !<
185   
186    ierr = 0
187    CALL MPI_SEND( buf, n, MPI_LOGICAL, child_rank, tag,                       &
188                   m_to_child_comm(child_id), ierr )
189
190 END SUBROUTINE pmc_send_to_child_logical
191
192
193 SUBROUTINE pmc_send_to_parent_integer( buf, n, parent_rank, tag, ierr )
194
195    IMPLICIT NONE
196
197    INTEGER, DIMENSION(:), INTENT(IN) ::  buf          !<
198    INTEGER, INTENT(IN)               ::  n            !<
199    INTEGER, INTENT(IN)               ::  parent_rank  !<
200    INTEGER, INTENT(IN)               ::  tag          !<
201    INTEGER, INTENT(OUT)              ::  ierr         !<
202
203   
204    ierr = 0
205    CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
206                   ierr )
207
208 END SUBROUTINE pmc_send_to_parent_integer
209
210
211 SUBROUTINE pmc_recv_from_parent_integer( buf, n, parent_rank, tag, ierr )
212
213    IMPLICIT NONE
214
215    INTEGER, DIMENSION(:), INTENT(OUT) ::  buf          !<
216    INTEGER, INTENT(IN)                ::  n            !<
217    INTEGER, INTENT(IN)                ::  parent_rank  !<
218    INTEGER, INTENT(IN)                ::  tag          !<
219    INTEGER, INTENT(OUT)               ::  ierr         !<
220
221   
222    ierr = 0
223    CALL MPI_RECV( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
224                   MPI_STATUS_IGNORE, ierr )
225
226 END SUBROUTINE pmc_recv_from_parent_integer
227
228
229
230 SUBROUTINE pmc_send_to_parent_integer_2( buf, n, parent_rank, tag, ierr )
231
232    IMPLICIT NONE
233
234    INTEGER, DIMENSION(:,:), INTENT(IN) :: buf          !<
235    INTEGER, INTENT(IN)                 :: n            !<
236    INTEGER, INTENT(IN)                 :: parent_rank  !<
237    INTEGER, INTENT(IN)                 :: tag          !<
238    INTEGER, INTENT(OUT)                :: ierr         !<
239
240   
241    ierr = 0
242    CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
243                   ierr )
244
245 END SUBROUTINE pmc_send_to_parent_integer_2
246
247
248
249 SUBROUTINE pmc_send_to_parent_real_r1( buf, n, parent_rank, tag, ierr )
250
251    IMPLICIT NONE
252
253    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf          !<
254    INTEGER, INTENT(IN)                ::  n            !<
255    INTEGER, INTENT(IN)                ::  parent_rank  !<
256    INTEGER, INTENT(IN)                ::  tag          !<
257    INTEGER, INTENT(OUT)               ::  ierr         !<
258
259   
260    ierr = 0
261    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
262
263 END SUBROUTINE pmc_send_to_parent_real_r1
264
265
266
267 SUBROUTINE pmc_recv_from_parent_real_r1( buf, n, parent_rank, tag, ierr )
268
269    IMPLICIT NONE
270
271    REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf          !<
272    INTEGER, INTENT(IN)                 ::  n            !<
273    INTEGER, INTENT(IN)                 ::  parent_rank  !<
274    INTEGER, INTENT(IN)                 ::  tag          !<
275    INTEGER, INTENT(OUT)                ::  ierr         !<
276
277   
278    ierr = 0
279    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
280                   MPI_STATUS_IGNORE, ierr )
281
282 END SUBROUTINE pmc_recv_from_parent_real_r1
283
284
285
286 SUBROUTINE pmc_send_to_parent_real_r2( buf, n, parent_rank, tag, ierr )
287
288    IMPLICIT NONE
289
290    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf          !<
291    INTEGER, INTENT(IN)                  ::  n            !<
292    INTEGER, INTENT(IN)                  ::  parent_rank  !<
293    INTEGER, INTENT(IN)                  ::  tag          !<
294    INTEGER, INTENT(OUT)                 ::  ierr         !<
295
296   
297    ierr = 0
298    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
299
300 END SUBROUTINE pmc_send_to_parent_real_r2
301
302
303 SUBROUTINE pmc_recv_from_parent_real_r2( buf, n, parent_rank, tag, ierr )
304
305    IMPLICIT NONE
306
307    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf          !<
308    INTEGER, INTENT(IN)                   ::  n            !<
309    INTEGER, INTENT(IN)                   ::  parent_rank  !<
310    INTEGER, INTENT(IN)                   ::  tag          !<
311    INTEGER, INTENT(OUT)                  ::  ierr         !<
312
313    ierr = 0
314    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
315                   MPI_STATUS_IGNORE, ierr )
316
317 END SUBROUTINE pmc_recv_from_parent_real_r2
318
319
320
321 SUBROUTINE pmc_send_to_parent_real_r3( buf, n, parent_rank, tag, ierr )
322
323    IMPLICIT NONE
324
325    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf          !<
326    INTEGER, INTENT(IN)                    ::  n            !<
327    INTEGER, INTENT(IN)                    ::  parent_rank  !<
328    INTEGER, INTENT(IN)                    ::  tag          !<
329    INTEGER, INTENT(OUT)                   ::  ierr         !<
330
331   
332    ierr = 0
333    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
334
335 END SUBROUTINE pmc_send_to_parent_real_r3
336
337
338
339 SUBROUTINE pmc_recv_from_parent_real_r3( buf, n, parent_rank, tag, ierr )
340
341    IMPLICIT NONE
342
343    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf          !<
344    INTEGER, INTENT(IN)                     ::  n            !<
345    INTEGER, INTENT(IN)                     ::  parent_rank  !<
346    INTEGER, INTENT(IN)                     ::  tag          !<
347    INTEGER, INTENT(OUT)                    ::  ierr         !<
348
349   
350    ierr = 0
351    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
352                   MPI_STATUS_IGNORE, ierr )
353
354 END SUBROUTINE pmc_recv_from_parent_real_r3
355
356
357 SUBROUTINE pmc_send_to_child_integer( child_id, buf, n, child_rank, tag,       &
358                                       ierr )
359
360    IMPLICIT NONE
361
362    INTEGER, INTENT(IN)               ::  child_id     !<
363    INTEGER, DIMENSION(:), INTENT(IN) ::  buf          !<
364    INTEGER, INTENT(IN)               ::  n            !<
365    INTEGER, INTENT(IN)               ::  child_rank   !<
366    INTEGER, INTENT(IN)               ::  tag          !<
367    INTEGER, INTENT(OUT)              ::  ierr         !<
368
369   
370    ierr = 0
371    CALL MPI_SEND( buf, n, MPI_INTEGER, child_rank, tag,                        &
372                   m_to_child_comm(child_id), ierr )
373
374 END SUBROUTINE pmc_send_to_child_integer
375
376
377
378 SUBROUTINE pmc_recv_from_child_integer( child_id, buf, n, child_rank, tag,     &
379                                         ierr )
380
381    IMPLICIT NONE
382
383    INTEGER, INTENT(IN)                  ::  child_id     !<
384    INTEGER, DIMENSION(:), INTENT(INOUT) ::  buf          !<
385    INTEGER, INTENT(IN)                  ::  n            !<
386    INTEGER, INTENT(IN)                  ::  child_rank   !<
387    INTEGER, INTENT(IN)                  ::  tag          !<
388    INTEGER, INTENT(OUT)                 ::  ierr         !<
389
390   
391    ierr = 0
392    CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag,                        &
393                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
394
395 END SUBROUTINE pmc_recv_from_child_integer
396
397
398
399 SUBROUTINE pmc_recv_from_child_integer_2( child_id, buf, n, child_rank,        &
400                                           tag, ierr )
401
402    IMPLICIT NONE
403
404    INTEGER, INTENT(IN)                  ::  child_id     !<
405    INTEGER, DIMENSION(:,:), INTENT(OUT) ::  buf          !<
406    INTEGER, INTENT(IN)                  ::  n            !<
407    INTEGER, INTENT(IN)                  ::  child_rank   !<
408    INTEGER, INTENT(IN)                  ::  tag          !<
409    INTEGER, INTENT(OUT)                 ::  ierr         !<
410
411   
412    ierr = 0
413    CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag,                        &
414                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
415
416 END SUBROUTINE pmc_recv_from_child_integer_2
417
418
419
420 SUBROUTINE pmc_send_to_child_real_r1( child_id, buf, n, child_rank, tag,       &
421                                       ierr )
422
423    IMPLICIT NONE
424
425    INTEGER, INTENT(IN)                ::  child_id     !<
426    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf          !<
427    INTEGER, INTENT(IN)                ::  n            !<
428    INTEGER, INTENT(IN)                ::  child_rank   !<
429    INTEGER, INTENT(IN)                ::  tag          !<
430    INTEGER, INTENT(OUT)               ::  ierr         !<
431
432   
433    ierr = 0
434    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
435                   m_to_child_comm(child_id), ierr )
436
437 END SUBROUTINE pmc_send_to_child_real_r1
438
439
440
441 SUBROUTINE pmc_recv_from_child_real_r1( child_id, buf, n, child_rank, tag,     &
442                                         ierr )
443
444    IMPLICIT NONE
445
446    INTEGER, INTENT(IN)                   ::  child_id     !<
447    REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf          !<
448    INTEGER, INTENT(IN)                   ::  n            !<
449    INTEGER, INTENT(IN)                   ::  child_rank   !<
450    INTEGER, INTENT(IN)                   ::  tag          !<
451    INTEGER, INTENT(OUT)                  ::  ierr         !<
452
453   
454    ierr = 0
455    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           &
456                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
457
458 END SUBROUTINE pmc_recv_from_child_real_r1
459
460
461
462 SUBROUTINE pmc_send_to_child_real_r2( child_id, buf, n, child_rank, tag,       &
463                                       ierr )
464
465    IMPLICIT NONE
466
467    INTEGER, INTENT(IN)                  ::  child_id     !<
468    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf          !<
469    INTEGER, INTENT(IN)                  ::  n            !<
470    INTEGER, INTENT(IN)                  ::  child_rank   !<
471    INTEGER, INTENT(IN)                  ::  tag          !<
472    INTEGER, INTENT(OUT)                 ::  ierr         !<
473
474   
475    ierr = 0
476    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
477                   m_to_child_comm(child_id), ierr )
478
479 END SUBROUTINE pmc_send_to_child_real_r2
480
481
482
483 SUBROUTINE pmc_recv_from_child_real_r2( child_id, buf, n, child_rank, tag,     &
484                                         ierr )
485
486    IMPLICIT NONE
487
488    INTEGER, INTENT(IN)                   ::  child_id     !<
489    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf          !<
490    INTEGER, INTENT(IN)                   ::  n            !<
491    INTEGER, INTENT(IN)                   ::  child_rank   !<
492    INTEGER, INTENT(IN)                   ::  tag          !<
493    INTEGER, INTENT(OUT)                  ::  ierr         !<
494
495   
496    ierr = 0
497    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           &
498                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
499
500 END SUBROUTINE pmc_recv_from_child_real_r2
501
502
503
504 SUBROUTINE pmc_send_to_child_real_r3( child_id, buf, n, child_rank, tag,       &
505                                       ierr )
506
507    IMPLICIT NONE
508
509    INTEGER, INTENT(IN)                    ::  child_id     !<
510    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf          !<
511    INTEGER, INTENT(IN)                    ::  n            !<
512    INTEGER, INTENT(IN)                    ::  child_rank   !<
513    INTEGER, INTENT(IN)                    ::  tag          !<
514    INTEGER, INTENT(OUT)                   ::  ierr         !<
515
516   
517    ierr = 0
518    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
519                   m_to_child_comm(child_id), ierr )
520
521 END SUBROUTINE pmc_send_to_child_real_r3
522
523
524
525 SUBROUTINE pmc_recv_from_child_real_r3( child_id, buf, n, child_rank, tag,     &
526                                         ierr )
527
528    IMPLICIT NONE
529
530    INTEGER, INTENT(IN)                     ::  child_id     !<
531    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf          !<
532    INTEGER, INTENT(IN)                     ::  n            !<
533    INTEGER, INTENT(IN)                     ::  child_rank   !<
534    INTEGER, INTENT(IN)                     ::  tag          !<
535    INTEGER, INTENT(OUT)                    ::  ierr         !<
536
537   
538    ierr = 0
539    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           & 
540                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
541
542 END SUBROUTINE pmc_recv_from_child_real_r3
543
544
545
546 SUBROUTINE pmc_bcast_integer( buf, root_pe, comm, ierr )
547
548    IMPLICIT NONE
549
550    INTEGER, INTENT(INOUT)         ::  buf      !<
551    INTEGER, INTENT(IN)            ::  root_pe  !<
552    INTEGER, INTENT(IN), OPTIONAL  ::  comm     !<
553    INTEGER, INTENT(OUT), OPTIONAL ::  ierr     !<
554
555    INTEGER ::  mycomm  !<
556    INTEGER ::  myerr   !<
557
558
559    IF ( PRESENT( comm ) )  THEN
560       mycomm = comm
561    ELSE
562       mycomm = m_model_comm
563    ENDIF
564
565    CALL MPI_BCAST( buf, 1, MPI_INTEGER, root_pe, mycomm, myerr )
566
567    IF ( PRESENT( ierr ) )  THEN
568       ierr = myerr
569    ENDIF
570
571 END SUBROUTINE pmc_bcast_integer
572
573
574
575 SUBROUTINE pmc_bcast_character( buf, root_pe, comm, ierr )
576
577    IMPLICIT NONE
578
579    CHARACTER(LEN=*), INTENT(INOUT) ::  buf      !<
580    INTEGER, INTENT(IN)             ::  root_pe  !<
581    INTEGER, INTENT(IN), OPTIONAL   ::  comm     !<
582    INTEGER, INTENT(OUT), OPTIONAL  ::  ierr     !<
583
584    INTEGER ::  mycomm  !<
585    INTEGER ::  myerr   !<
586
587   
588    IF ( PRESENT( comm ) )  THEN
589       mycomm = comm
590    ELSE
591       mycomm = m_model_comm
592    ENDIF
593
594    CALL MPI_BCAST( buf, LEN(buf), MPI_CHARACTER, root_pe, mycomm, myerr )
595
596    IF ( PRESENT( ierr ) )  THEN
597       ierr = myerr
598    ENDIF
599
600 END SUBROUTINE pmc_bcast_character
601
602
603
604 SUBROUTINE pmc_inter_bcast_integer_1( buf, child_id, ierr )
605
606    IMPLICIT NONE
607
608    INTEGER, INTENT(INOUT),DIMENSION(:) ::  buf        !<
609    INTEGER, INTENT(IN),optional        ::  child_id   !<
610    INTEGER, INTENT(OUT),optional       ::  ierr       !<
611
612    INTEGER ::  mycomm   !<
613    INTEGER ::  myerr    !<
614    INTEGER ::  root_pe  !<
615
616!
617!-- Process 0 on parent broadcast to all child processes
618    IF ( PRESENT( child_id ) )  THEN
619
620       mycomm = m_to_child_comm(child_id)
621
622       IF ( m_model_rank == 0 )  THEN
623          root_pe = MPI_ROOT
624       ELSE
625          root_pe = MPI_PROC_NULL
626       ENDIF
627
628    ELSE
629       mycomm  = m_to_parent_comm
630       root_pe = 0
631    ENDIF
632
633    CALL MPI_BCAST( buf, SIZE( buf ), MPI_INTEGER, root_pe, mycomm, myerr )
634
635    IF ( PRESENT( ierr ) )  THEN
636       ierr = myerr
637    ENDIF
638
639 END SUBROUTINE pmc_inter_bcast_integer_1
640
641
642
643 SUBROUTINE pmc_alloc_mem_integer_1( iarray, idim1 )
644!
645!-- Allocate memory with MPI_ALLOC_MEM using intermediate C-pointer
646
647    IMPLICIT NONE
648
649    INTEGER, DIMENSION(:), POINTER, INTENT(INOUT) ::  iarray  !<
650    INTEGER, INTENT(IN)                           ::  idim1   !<
651
652    INTEGER, DIMENSION(1)          ::  ashape   !<
653    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
654    INTEGER                        ::  ierr     !<
655
656    TYPE(C_PTR)                    ::  p_myind  !<
657
658   
659    winsize = idim1 * STORAGE_SIZE( ierr )/8
660
661    CALL MPI_ALLOC_MEM( winsize, MPI_INFO_NULL, p_myind, ierr )
662    ashape(1) = idim1
663    CALL C_F_POINTER( p_myind, iarray, ashape )
664
665 END SUBROUTINE pmc_alloc_mem_integer_1
666
667
668
669 SUBROUTINE pmc_alloc_mem_real_1( array, idim1, base_ptr )
670
671    IMPLICIT NONE
672
673    INTEGER(idp), INTENT(IN)                            ::  idim1     !<
674    REAL(KIND=wp), DIMENSION(:), POINTER, INTENT(INOUT) ::  array     !<
675    TYPE(C_PTR), INTENT(OUT), OPTIONAL                  ::  base_ptr  !<
676
677    INTEGER, DIMENSION(1)          :: ashape   !<
678    INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize  !<
679    INTEGER                        :: ierr     !<
680
681    TYPE(C_PTR)                    :: p_myind  !<
682
683   
684    winsize = idim1 * wp
685
686    CALL MPI_ALLOC_MEM( winsize , MPI_INFO_NULL, p_myind, ierr )
687    ashape(1) = idim1
688    CALL C_F_POINTER( p_myind, array, ashape )
689
690    IF ( PRESENT( base_ptr ) )  THEN
691       base_ptr = p_myind
692    ENDIF
693
694 END SUBROUTINE pmc_alloc_mem_Real_1
695
696
697
698 FUNCTION pmc_time()
699
700    REAL(kind=wp) :: pmc_time  !<
701
702   
703    pmc_time = MPI_WTIME()
704
705  END FUNCTION pmc_time
706
707#endif
708 END MODULE pmc_mpi_wrapper
Note: See TracBrowser for help on using the repository browser.