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

Last change on this file since 4096 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
RevLine 
[1900]1 MODULE pmc_mpi_wrapper
[1762]2
[2000]3!------------------------------------------------------------------------------!
[2696]4! This file is part of the PALM model system.
[1762]5!
[2000]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.
[1762]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!
[3655]18! Copyright 1997-2019 Leibniz Universitaet Hannover
[2000]19!------------------------------------------------------------------------------!
[1762]20!
21! Current revisions:
22! ------------------
[1851]23!
[2001]24!
[1762]25! Former revisions:
26! -----------------
27! $Id: pmc_mpi_wrapper_mod.f90 3655 2019-01-07 16:51:22Z motisi $
[2938]28! Extent interface by logical buffer
29!
30! 2936 2018-03-27 14:49:27Z suehring
[2841]31! Bugfix: wrong placement of include 'mpif.h' corrected
32!
33! 2809 2018-02-15 09:55:58Z schwenkel
[2809]34! Bugfix for gfortran: Replace the function C_SIZEOF with STORAGE_SIZE
35!
36! 2718 2018-01-02 08:49:38Z maronga
[2716]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
[2599]43! Some cleanup and commenting improvements only.
44!
45! 2101 2017-01-05 16:42:31Z suehring
[1762]46!
[2001]47! 2000 2016-08-20 18:09:15Z knoop
48! Forced header and separation lines into 80 columns
49!
[1933]50! 1901 2016-05-04 15:39:38Z raasch
51! Code clean up. The words server/client changed to parent/child.
52!
[1901]53! 1900 2016-05-04 15:27:53Z raasch
54! re-formatted to match PALM style
55!
[1851]56! 1850 2016-04-08 13:29:27Z maronga
57! Module renamed
58!
59!
[1809]60! 1808 2016-04-05 19:44:00Z raasch
61! MPI module used by default on all machines
62!
[1780]63! 1779 2016-03-03 08:01:28Z raasch
64! kind=dp replaced by wp
65!
[1765]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!
[1763]70! 1762 2016-02-25 12:31:13Z hellstea
71! Initial revision by K. Ketelsen
[1762]72!
73! Description:
74! ------------
75!
76! MPI Wrapper of Palm Model Coupler
[1933]77!-------------------------------------------------------------------------------!
[1762]78
[1764]79#if defined( __parallel )
[1900]80    USE, INTRINSIC ::  ISO_C_BINDING
[1762]81
[2841]82#if !defined( __mpifh )
[1764]83    USE MPI
84#endif
[1762]85
[1900]86    USE kinds
[1933]87    USE pmc_handle_communicator,                                                &
88        ONLY: m_model_comm, m_model_rank, m_to_parent_comm, m_to_child_comm
[1762]89
[1900]90    IMPLICIT NONE
[1762]91
[2841]92#if defined( __mpifh )
93    INCLUDE "mpif.h"
94#endif
95
[1900]96    PRIVATE
97    SAVE
[1762]98
[1933]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
[1762]106
[1933]107    INTERFACE pmc_recv_from_parent
[2938]108       MODULE PROCEDURE pmc_recv_from_parent_logical
[1933]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
[1762]114
[1933]115    INTERFACE pmc_send_to_child
[2938]116       MODULE PROCEDURE pmc_send_to_child_logical
[1933]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
[1762]122
[1933]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
[1762]130
[1900]131    INTERFACE pmc_bcast
132       MODULE PROCEDURE pmc_bcast_integer
133       MODULE PROCEDURE pmc_bcast_character
134    END INTERFACE pmc_bcast
[1762]135
[1900]136    INTERFACE pmc_inter_bcast
137       MODULE PROCEDURE pmc_inter_bcast_integer_1
138    END INTERFACE pmc_inter_bcast
[1762]139
[1900]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
[1762]144
[1900]145    INTERFACE pmc_time
146       MODULE PROCEDURE pmc_time
147    END INTERFACE pmc_time
[1762]148
[1933]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,         &
[1900]151           pmc_time
[1762]152
[1900]153 CONTAINS
[1762]154
155
[2938]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
[1933]193 SUBROUTINE pmc_send_to_parent_integer( buf, n, parent_rank, tag, ierr )
[1762]194
[1900]195    IMPLICIT NONE
[1762]196
[1900]197    INTEGER, DIMENSION(:), INTENT(IN) ::  buf          !<
198    INTEGER, INTENT(IN)               ::  n            !<
[1933]199    INTEGER, INTENT(IN)               ::  parent_rank  !<
[1900]200    INTEGER, INTENT(IN)               ::  tag          !<
201    INTEGER, INTENT(OUT)              ::  ierr         !<
[1762]202
[2599]203   
[1900]204    ierr = 0
[1933]205    CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
[2599]206                   ierr )
[1779]207
[1933]208 END SUBROUTINE pmc_send_to_parent_integer
[1762]209
[1779]210
[1933]211 SUBROUTINE pmc_recv_from_parent_integer( buf, n, parent_rank, tag, ierr )
[1762]212
[1900]213    IMPLICIT NONE
[1779]214
[1900]215    INTEGER, DIMENSION(:), INTENT(OUT) ::  buf          !<
216    INTEGER, INTENT(IN)                ::  n            !<
[1933]217    INTEGER, INTENT(IN)                ::  parent_rank  !<
[1900]218    INTEGER, INTENT(IN)                ::  tag          !<
219    INTEGER, INTENT(OUT)               ::  ierr         !<
[1762]220
[2599]221   
[1900]222    ierr = 0
[1933]223    CALL MPI_RECV( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
[1900]224                   MPI_STATUS_IGNORE, ierr )
[1779]225
[1933]226 END SUBROUTINE pmc_recv_from_parent_integer
[1762]227
228
[1779]229
[1933]230 SUBROUTINE pmc_send_to_parent_integer_2( buf, n, parent_rank, tag, ierr )
[1762]231
[1900]232    IMPLICIT NONE
[1779]233
[1900]234    INTEGER, DIMENSION(:,:), INTENT(IN) :: buf          !<
235    INTEGER, INTENT(IN)                 :: n            !<
[1933]236    INTEGER, INTENT(IN)                 :: parent_rank  !<
[1900]237    INTEGER, INTENT(IN)                 :: tag          !<
238    INTEGER, INTENT(OUT)                :: ierr         !<
[1762]239
[2599]240   
[1900]241    ierr = 0
[1933]242    CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
[1900]243                   ierr )
[1762]244
[1933]245 END SUBROUTINE pmc_send_to_parent_integer_2
[1779]246
[1762]247
[1779]248
[1933]249 SUBROUTINE pmc_send_to_parent_real_r1( buf, n, parent_rank, tag, ierr )
[1762]250
[1900]251    IMPLICIT NONE
[1762]252
[1900]253    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf          !<
254    INTEGER, INTENT(IN)                ::  n            !<
[1933]255    INTEGER, INTENT(IN)                ::  parent_rank  !<
[1900]256    INTEGER, INTENT(IN)                ::  tag          !<
257    INTEGER, INTENT(OUT)               ::  ierr         !<
[1779]258
[2599]259   
[1900]260    ierr = 0
[1933]261    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]262
[1933]263 END SUBROUTINE pmc_send_to_parent_real_r1
[1779]264
[1762]265
266
[1933]267 SUBROUTINE pmc_recv_from_parent_real_r1( buf, n, parent_rank, tag, ierr )
[1779]268
[1900]269    IMPLICIT NONE
[1762]270
[1900]271    REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf          !<
272    INTEGER, INTENT(IN)                 ::  n            !<
[1933]273    INTEGER, INTENT(IN)                 ::  parent_rank  !<
[1900]274    INTEGER, INTENT(IN)                 ::  tag          !<
275    INTEGER, INTENT(OUT)                ::  ierr         !<
[1779]276
[2599]277   
[1900]278    ierr = 0
[1933]279    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
[1900]280                   MPI_STATUS_IGNORE, ierr )
[1762]281
[1933]282 END SUBROUTINE pmc_recv_from_parent_real_r1
[1762]283
284
285
[1933]286 SUBROUTINE pmc_send_to_parent_real_r2( buf, n, parent_rank, tag, ierr )
[1762]287
[1900]288    IMPLICIT NONE
[1762]289
[1900]290    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf          !<
291    INTEGER, INTENT(IN)                  ::  n            !<
[1933]292    INTEGER, INTENT(IN)                  ::  parent_rank  !<
[1900]293    INTEGER, INTENT(IN)                  ::  tag          !<
294    INTEGER, INTENT(OUT)                 ::  ierr         !<
[1762]295
[2599]296   
[1900]297    ierr = 0
[1933]298    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]299
[1933]300 END SUBROUTINE pmc_send_to_parent_real_r2
[1762]301
302
[1933]303 SUBROUTINE pmc_recv_from_parent_real_r2( buf, n, parent_rank, tag, ierr )
[1762]304
[1900]305    IMPLICIT NONE
[1762]306
[1900]307    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf          !<
308    INTEGER, INTENT(IN)                   ::  n            !<
[1933]309    INTEGER, INTENT(IN)                   ::  parent_rank  !<
[1900]310    INTEGER, INTENT(IN)                   ::  tag          !<
311    INTEGER, INTENT(OUT)                  ::  ierr         !<
[1779]312
[1900]313    ierr = 0
[1933]314    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
[1900]315                   MPI_STATUS_IGNORE, ierr )
[1762]316
[1933]317 END SUBROUTINE pmc_recv_from_parent_real_r2
[1779]318
[1762]319
320
[1933]321 SUBROUTINE pmc_send_to_parent_real_r3( buf, n, parent_rank, tag, ierr )
[1779]322
[1900]323    IMPLICIT NONE
[1762]324
[1900]325    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf          !<
326    INTEGER, INTENT(IN)                    ::  n            !<
[1933]327    INTEGER, INTENT(IN)                    ::  parent_rank  !<
[1900]328    INTEGER, INTENT(IN)                    ::  tag          !<
329    INTEGER, INTENT(OUT)                   ::  ierr         !<
[1779]330
[2599]331   
[1900]332    ierr = 0
[1933]333    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]334
[1933]335 END SUBROUTINE pmc_send_to_parent_real_r3
[1762]336
[1779]337
[1762]338
[1933]339 SUBROUTINE pmc_recv_from_parent_real_r3( buf, n, parent_rank, tag, ierr )
[1779]340
[1900]341    IMPLICIT NONE
[1762]342
[1900]343    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf          !<
344    INTEGER, INTENT(IN)                     ::  n            !<
[1933]345    INTEGER, INTENT(IN)                     ::  parent_rank  !<
[1900]346    INTEGER, INTENT(IN)                     ::  tag          !<
347    INTEGER, INTENT(OUT)                    ::  ierr         !<
[1762]348
[2599]349   
[1900]350    ierr = 0
[1933]351    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
[1900]352                   MPI_STATUS_IGNORE, ierr )
[1779]353
[1933]354 END SUBROUTINE pmc_recv_from_parent_real_r3
[1762]355
[1779]356
[1933]357 SUBROUTINE pmc_send_to_child_integer( child_id, buf, n, child_rank, tag,       &
358                                       ierr )
[1762]359
[1900]360    IMPLICIT NONE
[1779]361
[1933]362    INTEGER, INTENT(IN)               ::  child_id     !<
[1900]363    INTEGER, DIMENSION(:), INTENT(IN) ::  buf          !<
364    INTEGER, INTENT(IN)               ::  n            !<
[1933]365    INTEGER, INTENT(IN)               ::  child_rank   !<
[1900]366    INTEGER, INTENT(IN)               ::  tag          !<
367    INTEGER, INTENT(OUT)              ::  ierr         !<
[1762]368
[2599]369   
[1900]370    ierr = 0
[1933]371    CALL MPI_SEND( buf, n, MPI_INTEGER, child_rank, tag,                        &
372                   m_to_child_comm(child_id), ierr )
[1779]373
[1933]374 END SUBROUTINE pmc_send_to_child_integer
[1762]375
376
[1779]377
[1933]378 SUBROUTINE pmc_recv_from_child_integer( child_id, buf, n, child_rank, tag,     &
379                                         ierr )
[1762]380
[1900]381    IMPLICIT NONE
[1779]382
[1933]383    INTEGER, INTENT(IN)                  ::  child_id     !<
[1900]384    INTEGER, DIMENSION(:), INTENT(INOUT) ::  buf          !<
385    INTEGER, INTENT(IN)                  ::  n            !<
[1933]386    INTEGER, INTENT(IN)                  ::  child_rank   !<
[1900]387    INTEGER, INTENT(IN)                  ::  tag          !<
388    INTEGER, INTENT(OUT)                 ::  ierr         !<
[1762]389
[2599]390   
[1900]391    ierr = 0
[1933]392    CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag,                        &
393                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1762]394
[1933]395 END SUBROUTINE pmc_recv_from_child_integer
[1762]396
397
398
[1933]399 SUBROUTINE pmc_recv_from_child_integer_2( child_id, buf, n, child_rank,        &
400                                           tag, ierr )
[1762]401
[1900]402    IMPLICIT NONE
[1762]403
[1933]404    INTEGER, INTENT(IN)                  ::  child_id     !<
[1900]405    INTEGER, DIMENSION(:,:), INTENT(OUT) ::  buf          !<
406    INTEGER, INTENT(IN)                  ::  n            !<
[1933]407    INTEGER, INTENT(IN)                  ::  child_rank   !<
[1900]408    INTEGER, INTENT(IN)                  ::  tag          !<
409    INTEGER, INTENT(OUT)                 ::  ierr         !<
[1762]410
[2599]411   
[1900]412    ierr = 0
[1933]413    CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag,                        &
414                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1762]415
[1933]416 END SUBROUTINE pmc_recv_from_child_integer_2
[1762]417
418
419
[1933]420 SUBROUTINE pmc_send_to_child_real_r1( child_id, buf, n, child_rank, tag,       &
421                                       ierr )
[1762]422
[1900]423    IMPLICIT NONE
[1762]424
[1933]425    INTEGER, INTENT(IN)                ::  child_id     !<
[1900]426    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf          !<
427    INTEGER, INTENT(IN)                ::  n            !<
[1933]428    INTEGER, INTENT(IN)                ::  child_rank   !<
[1900]429    INTEGER, INTENT(IN)                ::  tag          !<
430    INTEGER, INTENT(OUT)               ::  ierr         !<
[1762]431
[2599]432   
[1900]433    ierr = 0
[1933]434    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
435                   m_to_child_comm(child_id), ierr )
[1762]436
[1933]437 END SUBROUTINE pmc_send_to_child_real_r1
[1762]438
439
440
[1933]441 SUBROUTINE pmc_recv_from_child_real_r1( child_id, buf, n, child_rank, tag,     &
442                                         ierr )
[1762]443
[1900]444    IMPLICIT NONE
[1762]445
[1933]446    INTEGER, INTENT(IN)                   ::  child_id     !<
[1900]447    REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf          !<
448    INTEGER, INTENT(IN)                   ::  n            !<
[1933]449    INTEGER, INTENT(IN)                   ::  child_rank   !<
[1900]450    INTEGER, INTENT(IN)                   ::  tag          !<
451    INTEGER, INTENT(OUT)                  ::  ierr         !<
[1762]452
[2599]453   
[1900]454    ierr = 0
[1933]455    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           &
456                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1762]457
[1933]458 END SUBROUTINE pmc_recv_from_child_real_r1
[1762]459
460
461
[1933]462 SUBROUTINE pmc_send_to_child_real_r2( child_id, buf, n, child_rank, tag,       &
463                                       ierr )
[1762]464
[1900]465    IMPLICIT NONE
[1762]466
[1933]467    INTEGER, INTENT(IN)                  ::  child_id     !<
[1900]468    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf          !<
469    INTEGER, INTENT(IN)                  ::  n            !<
[1933]470    INTEGER, INTENT(IN)                  ::  child_rank   !<
[1900]471    INTEGER, INTENT(IN)                  ::  tag          !<
472    INTEGER, INTENT(OUT)                 ::  ierr         !<
[1762]473
[2599]474   
[1900]475    ierr = 0
[1933]476    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
477                   m_to_child_comm(child_id), ierr )
[1762]478
[1933]479 END SUBROUTINE pmc_send_to_child_real_r2
[1762]480
481
482
[1933]483 SUBROUTINE pmc_recv_from_child_real_r2( child_id, buf, n, child_rank, tag,     &
484                                         ierr )
[1762]485
[1900]486    IMPLICIT NONE
[1762]487
[1933]488    INTEGER, INTENT(IN)                   ::  child_id     !<
[1900]489    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf          !<
490    INTEGER, INTENT(IN)                   ::  n            !<
[1933]491    INTEGER, INTENT(IN)                   ::  child_rank   !<
[1900]492    INTEGER, INTENT(IN)                   ::  tag          !<
493    INTEGER, INTENT(OUT)                  ::  ierr         !<
494
[2599]495   
[1900]496    ierr = 0
[1933]497    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           &
498                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1900]499
[1933]500 END SUBROUTINE pmc_recv_from_child_real_r2
[1900]501
502
503
[1933]504 SUBROUTINE pmc_send_to_child_real_r3( child_id, buf, n, child_rank, tag,       &
[2599]505                                       ierr )
[1900]506
507    IMPLICIT NONE
508
[1933]509    INTEGER, INTENT(IN)                    ::  child_id     !<
[1900]510    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf          !<
511    INTEGER, INTENT(IN)                    ::  n            !<
[1933]512    INTEGER, INTENT(IN)                    ::  child_rank   !<
[1900]513    INTEGER, INTENT(IN)                    ::  tag          !<
514    INTEGER, INTENT(OUT)                   ::  ierr         !<
515
[2599]516   
[1900]517    ierr = 0
[1933]518    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
519                   m_to_child_comm(child_id), ierr )
[1900]520
[1933]521 END SUBROUTINE pmc_send_to_child_real_r3
[1900]522
523
524
[1933]525 SUBROUTINE pmc_recv_from_child_real_r3( child_id, buf, n, child_rank, tag,     &
526                                         ierr )
[1900]527
528    IMPLICIT NONE
529
[1933]530    INTEGER, INTENT(IN)                     ::  child_id     !<
[1900]531    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf          !<
532    INTEGER, INTENT(IN)                     ::  n            !<
[1933]533    INTEGER, INTENT(IN)                     ::  child_rank   !<
[1900]534    INTEGER, INTENT(IN)                     ::  tag          !<
535    INTEGER, INTENT(OUT)                    ::  ierr         !<
536
[2599]537   
[1900]538    ierr = 0
[1933]539    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           & 
540                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1900]541
[1933]542 END SUBROUTINE pmc_recv_from_child_real_r3
[1900]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
[2599]587   
[1900]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
[1933]604 SUBROUTINE pmc_inter_bcast_integer_1( buf, child_id, ierr )
[1900]605
606    IMPLICIT NONE
607
608    INTEGER, INTENT(INOUT),DIMENSION(:) ::  buf        !<
[1933]609    INTEGER, INTENT(IN),optional        ::  child_id   !<
[1900]610    INTEGER, INTENT(OUT),optional       ::  ierr       !<
611
612    INTEGER ::  mycomm   !<
613    INTEGER ::  myerr    !<
614    INTEGER ::  root_pe  !<
615
616!
[2599]617!-- Process 0 on parent broadcast to all child processes
[1933]618    IF ( PRESENT( child_id ) )  THEN
[1900]619
[1933]620       mycomm = m_to_child_comm(child_id)
[1900]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
[1933]629       mycomm  = m_to_parent_comm
[1900]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
[2599]658   
[2809]659    winsize = idim1 * STORAGE_SIZE( ierr )/8
[1900]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
[2599]683   
[1900]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
[2599]702   
[1900]703    pmc_time = MPI_WTIME()
704
705  END FUNCTION pmc_time
706
[1764]707#endif
[1762]708 END MODULE pmc_mpi_wrapper
Note: See TracBrowser for help on using the repository browser.