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

Last change on this file since 4590 was 4360, checked in by suehring, 5 years ago

Bugfix in output of time-averaged plant-canopy quanities; Output of plant-canopy data only where tall canopy is defined; land-surface model: fix wrong location strings; tests: update urban test case; all source code files: copyright update

  • Property svn:keywords set to Id
File size: 20.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!
[4360]18! Copyright 1997-2020 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 4360 2020-01-07 11:25:50Z suehring $
[4182]28! Corrected "Former revisions" section
29!
30! 3655 2019-01-07 16:51:22Z knoop
[2938]31! Extent interface by logical buffer
32!
[4182]33! 1762 2016-02-25 12:31:13Z hellstea
34! Initial revision by K. Ketelsen
[2716]35!
[1762]36! Description:
37! ------------
38!
39! MPI Wrapper of Palm Model Coupler
[1933]40!-------------------------------------------------------------------------------!
[1762]41
[1764]42#if defined( __parallel )
[1900]43    USE, INTRINSIC ::  ISO_C_BINDING
[1762]44
[2841]45#if !defined( __mpifh )
[1764]46    USE MPI
47#endif
[1762]48
[1900]49    USE kinds
[1933]50    USE pmc_handle_communicator,                                                &
51        ONLY: m_model_comm, m_model_rank, m_to_parent_comm, m_to_child_comm
[1762]52
[1900]53    IMPLICIT NONE
[1762]54
[2841]55#if defined( __mpifh )
56    INCLUDE "mpif.h"
57#endif
58
[1900]59    PRIVATE
60    SAVE
[1762]61
[1933]62    INTERFACE pmc_send_to_parent
63       MODULE PROCEDURE pmc_send_to_parent_integer
64       MODULE PROCEDURE pmc_send_to_parent_integer_2
65       MODULE PROCEDURE pmc_send_to_parent_real_r1
66       MODULE PROCEDURE pmc_send_to_parent_real_r2
67       MODULE PROCEDURE pmc_send_to_parent_real_r3
68    END INTERFACE pmc_send_to_parent
[1762]69
[1933]70    INTERFACE pmc_recv_from_parent
[2938]71       MODULE PROCEDURE pmc_recv_from_parent_logical
[1933]72       MODULE PROCEDURE pmc_recv_from_parent_integer
73       MODULE PROCEDURE pmc_recv_from_parent_real_r1
74       MODULE PROCEDURE pmc_recv_from_parent_real_r2
75       MODULE PROCEDURE pmc_recv_from_parent_real_r3
76    END INTERFACE pmc_recv_from_parent
[1762]77
[1933]78    INTERFACE pmc_send_to_child
[2938]79       MODULE PROCEDURE pmc_send_to_child_logical
[1933]80       MODULE PROCEDURE pmc_send_to_child_integer
81       MODULE PROCEDURE pmc_send_to_child_real_r1
82       MODULE PROCEDURE pmc_send_to_child_real_r2
83       MODULE PROCEDURE pmc_send_to_child_real_r3
84    END INTERFACE pmc_send_to_child
[1762]85
[1933]86    INTERFACE pmc_recv_from_child
87       MODULE PROCEDURE pmc_recv_from_child_integer
88       MODULE PROCEDURE pmc_recv_from_child_integer_2
89       MODULE PROCEDURE pmc_recv_from_child_real_r1
90       MODULE PROCEDURE pmc_recv_from_child_real_r2
91       MODULE PROCEDURE pmc_recv_from_child_real_r3
92    END INTERFACE pmc_recv_from_child
[1762]93
[1900]94    INTERFACE pmc_bcast
95       MODULE PROCEDURE pmc_bcast_integer
96       MODULE PROCEDURE pmc_bcast_character
97    END INTERFACE pmc_bcast
[1762]98
[1900]99    INTERFACE pmc_inter_bcast
100       MODULE PROCEDURE pmc_inter_bcast_integer_1
101    END INTERFACE pmc_inter_bcast
[1762]102
[1900]103    INTERFACE pmc_alloc_mem
104       MODULE PROCEDURE pmc_alloc_mem_integer_1
105       MODULE PROCEDURE pmc_alloc_mem_Real_1
106    END INTERFACE pmc_alloc_mem
[1762]107
[1900]108    INTERFACE pmc_time
109       MODULE PROCEDURE pmc_time
110    END INTERFACE pmc_time
[1762]111
[1933]112    PUBLIC pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_recv_from_child,      &
113           pmc_recv_from_parent, pmc_send_to_child, pmc_send_to_parent,         &
[1900]114           pmc_time
[1762]115
[1900]116 CONTAINS
[1762]117
118
[2938]119 SUBROUTINE pmc_recv_from_parent_logical( buf, n, parent_rank, tag, ierr )
120
121    IMPLICIT NONE
122
123    INTEGER, INTENT(IN)                ::  n            !<
124    INTEGER, INTENT(IN)                ::  parent_rank  !<
125    INTEGER, INTENT(IN)                ::  tag          !<
126    INTEGER, INTENT(OUT)               ::  ierr         !<
127
128    LOGICAL, INTENT(OUT)               ::  buf          !<
129   
130    ierr = 0
131    CALL MPI_RECV( buf, n, MPI_LOGICAL, parent_rank, tag, m_to_parent_comm,    &
132                   MPI_STATUS_IGNORE, ierr )
133
134 END SUBROUTINE pmc_recv_from_parent_logical
135
136 SUBROUTINE pmc_send_to_child_logical( child_id, buf, n, child_rank, tag,      &
137                                       ierr )
138
139    IMPLICIT NONE
140
141    INTEGER, INTENT(IN)               ::  child_id     !<
142    INTEGER, INTENT(IN)               ::  n            !<
143    INTEGER, INTENT(IN)               ::  child_rank   !<
144    INTEGER, INTENT(IN)               ::  tag          !<
145    INTEGER, INTENT(OUT)              ::  ierr         !<
146
147    LOGICAL, INTENT(IN)               ::  buf          !<
148   
149    ierr = 0
150    CALL MPI_SEND( buf, n, MPI_LOGICAL, child_rank, tag,                       &
151                   m_to_child_comm(child_id), ierr )
152
153 END SUBROUTINE pmc_send_to_child_logical
154
155
[1933]156 SUBROUTINE pmc_send_to_parent_integer( buf, n, parent_rank, tag, ierr )
[1762]157
[1900]158    IMPLICIT NONE
[1762]159
[1900]160    INTEGER, DIMENSION(:), INTENT(IN) ::  buf          !<
161    INTEGER, INTENT(IN)               ::  n            !<
[1933]162    INTEGER, INTENT(IN)               ::  parent_rank  !<
[1900]163    INTEGER, INTENT(IN)               ::  tag          !<
164    INTEGER, INTENT(OUT)              ::  ierr         !<
[1762]165
[2599]166   
[1900]167    ierr = 0
[1933]168    CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
[2599]169                   ierr )
[1779]170
[1933]171 END SUBROUTINE pmc_send_to_parent_integer
[1762]172
[1779]173
[1933]174 SUBROUTINE pmc_recv_from_parent_integer( buf, n, parent_rank, tag, ierr )
[1762]175
[1900]176    IMPLICIT NONE
[1779]177
[1900]178    INTEGER, DIMENSION(:), INTENT(OUT) ::  buf          !<
179    INTEGER, INTENT(IN)                ::  n            !<
[1933]180    INTEGER, INTENT(IN)                ::  parent_rank  !<
[1900]181    INTEGER, INTENT(IN)                ::  tag          !<
182    INTEGER, INTENT(OUT)               ::  ierr         !<
[1762]183
[2599]184   
[1900]185    ierr = 0
[1933]186    CALL MPI_RECV( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
[1900]187                   MPI_STATUS_IGNORE, ierr )
[1779]188
[1933]189 END SUBROUTINE pmc_recv_from_parent_integer
[1762]190
191
[1779]192
[1933]193 SUBROUTINE pmc_send_to_parent_integer_2( buf, n, parent_rank, tag, ierr )
[1762]194
[1900]195    IMPLICIT NONE
[1779]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,     &
[1900]206                   ierr )
[1762]207
[1933]208 END SUBROUTINE pmc_send_to_parent_integer_2
[1779]209
[1762]210
[1779]211
[1933]212 SUBROUTINE pmc_send_to_parent_real_r1( buf, n, parent_rank, tag, ierr )
[1762]213
[1900]214    IMPLICIT NONE
[1762]215
[1900]216    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf          !<
217    INTEGER, INTENT(IN)                ::  n            !<
[1933]218    INTEGER, INTENT(IN)                ::  parent_rank  !<
[1900]219    INTEGER, INTENT(IN)                ::  tag          !<
220    INTEGER, INTENT(OUT)               ::  ierr         !<
[1779]221
[2599]222   
[1900]223    ierr = 0
[1933]224    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]225
[1933]226 END SUBROUTINE pmc_send_to_parent_real_r1
[1779]227
[1762]228
229
[1933]230 SUBROUTINE pmc_recv_from_parent_real_r1( buf, n, parent_rank, tag, ierr )
[1779]231
[1900]232    IMPLICIT NONE
[1762]233
[1900]234    REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf          !<
235    INTEGER, INTENT(IN)                 ::  n            !<
[1933]236    INTEGER, INTENT(IN)                 ::  parent_rank  !<
[1900]237    INTEGER, INTENT(IN)                 ::  tag          !<
238    INTEGER, INTENT(OUT)                ::  ierr         !<
[1779]239
[2599]240   
[1900]241    ierr = 0
[1933]242    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
[1900]243                   MPI_STATUS_IGNORE, ierr )
[1762]244
[1933]245 END SUBROUTINE pmc_recv_from_parent_real_r1
[1762]246
247
248
[1933]249 SUBROUTINE pmc_send_to_parent_real_r2( 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         !<
[1762]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_r2
[1762]264
265
[1933]266 SUBROUTINE pmc_recv_from_parent_real_r2( buf, n, parent_rank, tag, ierr )
[1762]267
[1900]268    IMPLICIT NONE
[1762]269
[1900]270    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf          !<
271    INTEGER, INTENT(IN)                   ::  n            !<
[1933]272    INTEGER, INTENT(IN)                   ::  parent_rank  !<
[1900]273    INTEGER, INTENT(IN)                   ::  tag          !<
274    INTEGER, INTENT(OUT)                  ::  ierr         !<
[1779]275
[1900]276    ierr = 0
[1933]277    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
[1900]278                   MPI_STATUS_IGNORE, ierr )
[1762]279
[1933]280 END SUBROUTINE pmc_recv_from_parent_real_r2
[1779]281
[1762]282
283
[1933]284 SUBROUTINE pmc_send_to_parent_real_r3( buf, n, parent_rank, tag, ierr )
[1779]285
[1900]286    IMPLICIT NONE
[1762]287
[1900]288    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf          !<
289    INTEGER, INTENT(IN)                    ::  n            !<
[1933]290    INTEGER, INTENT(IN)                    ::  parent_rank  !<
[1900]291    INTEGER, INTENT(IN)                    ::  tag          !<
292    INTEGER, INTENT(OUT)                   ::  ierr         !<
[1779]293
[2599]294   
[1900]295    ierr = 0
[1933]296    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]297
[1933]298 END SUBROUTINE pmc_send_to_parent_real_r3
[1762]299
[1779]300
[1762]301
[1933]302 SUBROUTINE pmc_recv_from_parent_real_r3( buf, n, parent_rank, tag, ierr )
[1779]303
[1900]304    IMPLICIT NONE
[1762]305
[1900]306    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf          !<
307    INTEGER, INTENT(IN)                     ::  n            !<
[1933]308    INTEGER, INTENT(IN)                     ::  parent_rank  !<
[1900]309    INTEGER, INTENT(IN)                     ::  tag          !<
310    INTEGER, INTENT(OUT)                    ::  ierr         !<
[1762]311
[2599]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 )
[1779]316
[1933]317 END SUBROUTINE pmc_recv_from_parent_real_r3
[1762]318
[1779]319
[1933]320 SUBROUTINE pmc_send_to_child_integer( child_id, buf, n, child_rank, tag,       &
321                                       ierr )
[1762]322
[1900]323    IMPLICIT NONE
[1779]324
[1933]325    INTEGER, INTENT(IN)               ::  child_id     !<
[1900]326    INTEGER, DIMENSION(:), INTENT(IN) ::  buf          !<
327    INTEGER, INTENT(IN)               ::  n            !<
[1933]328    INTEGER, INTENT(IN)               ::  child_rank   !<
[1900]329    INTEGER, INTENT(IN)               ::  tag          !<
330    INTEGER, INTENT(OUT)              ::  ierr         !<
[1762]331
[2599]332   
[1900]333    ierr = 0
[1933]334    CALL MPI_SEND( buf, n, MPI_INTEGER, child_rank, tag,                        &
335                   m_to_child_comm(child_id), ierr )
[1779]336
[1933]337 END SUBROUTINE pmc_send_to_child_integer
[1762]338
339
[1779]340
[1933]341 SUBROUTINE pmc_recv_from_child_integer( child_id, buf, n, child_rank, tag,     &
342                                         ierr )
[1762]343
[1900]344    IMPLICIT NONE
[1779]345
[1933]346    INTEGER, INTENT(IN)                  ::  child_id     !<
[1900]347    INTEGER, DIMENSION(:), INTENT(INOUT) ::  buf          !<
348    INTEGER, INTENT(IN)                  ::  n            !<
[1933]349    INTEGER, INTENT(IN)                  ::  child_rank   !<
[1900]350    INTEGER, INTENT(IN)                  ::  tag          !<
351    INTEGER, INTENT(OUT)                 ::  ierr         !<
[1762]352
[2599]353   
[1900]354    ierr = 0
[1933]355    CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag,                        &
356                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1762]357
[1933]358 END SUBROUTINE pmc_recv_from_child_integer
[1762]359
360
361
[1933]362 SUBROUTINE pmc_recv_from_child_integer_2( child_id, buf, n, child_rank,        &
363                                           tag, ierr )
[1762]364
[1900]365    IMPLICIT NONE
[1762]366
[1933]367    INTEGER, INTENT(IN)                  ::  child_id     !<
[1900]368    INTEGER, DIMENSION(:,:), INTENT(OUT) ::  buf          !<
369    INTEGER, INTENT(IN)                  ::  n            !<
[1933]370    INTEGER, INTENT(IN)                  ::  child_rank   !<
[1900]371    INTEGER, INTENT(IN)                  ::  tag          !<
372    INTEGER, INTENT(OUT)                 ::  ierr         !<
[1762]373
[2599]374   
[1900]375    ierr = 0
[1933]376    CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag,                        &
377                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1762]378
[1933]379 END SUBROUTINE pmc_recv_from_child_integer_2
[1762]380
381
382
[1933]383 SUBROUTINE pmc_send_to_child_real_r1( child_id, buf, n, child_rank, tag,       &
384                                       ierr )
[1762]385
[1900]386    IMPLICIT NONE
[1762]387
[1933]388    INTEGER, INTENT(IN)                ::  child_id     !<
[1900]389    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf          !<
390    INTEGER, INTENT(IN)                ::  n            !<
[1933]391    INTEGER, INTENT(IN)                ::  child_rank   !<
[1900]392    INTEGER, INTENT(IN)                ::  tag          !<
393    INTEGER, INTENT(OUT)               ::  ierr         !<
[1762]394
[2599]395   
[1900]396    ierr = 0
[1933]397    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
398                   m_to_child_comm(child_id), ierr )
[1762]399
[1933]400 END SUBROUTINE pmc_send_to_child_real_r1
[1762]401
402
403
[1933]404 SUBROUTINE pmc_recv_from_child_real_r1( child_id, buf, n, child_rank, tag,     &
405                                         ierr )
[1762]406
[1900]407    IMPLICIT NONE
[1762]408
[1933]409    INTEGER, INTENT(IN)                   ::  child_id     !<
[1900]410    REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf          !<
411    INTEGER, INTENT(IN)                   ::  n            !<
[1933]412    INTEGER, INTENT(IN)                   ::  child_rank   !<
[1900]413    INTEGER, INTENT(IN)                   ::  tag          !<
414    INTEGER, INTENT(OUT)                  ::  ierr         !<
[1762]415
[2599]416   
[1900]417    ierr = 0
[1933]418    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           &
419                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1762]420
[1933]421 END SUBROUTINE pmc_recv_from_child_real_r1
[1762]422
423
424
[1933]425 SUBROUTINE pmc_send_to_child_real_r2( child_id, buf, n, child_rank, tag,       &
426                                       ierr )
[1762]427
[1900]428    IMPLICIT NONE
[1762]429
[1933]430    INTEGER, INTENT(IN)                  ::  child_id     !<
[1900]431    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf          !<
432    INTEGER, INTENT(IN)                  ::  n            !<
[1933]433    INTEGER, INTENT(IN)                  ::  child_rank   !<
[1900]434    INTEGER, INTENT(IN)                  ::  tag          !<
435    INTEGER, INTENT(OUT)                 ::  ierr         !<
[1762]436
[2599]437   
[1900]438    ierr = 0
[1933]439    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
440                   m_to_child_comm(child_id), ierr )
[1762]441
[1933]442 END SUBROUTINE pmc_send_to_child_real_r2
[1762]443
444
445
[1933]446 SUBROUTINE pmc_recv_from_child_real_r2( child_id, buf, n, child_rank, tag,     &
447                                         ierr )
[1762]448
[1900]449    IMPLICIT NONE
[1762]450
[1933]451    INTEGER, INTENT(IN)                   ::  child_id     !<
[1900]452    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf          !<
453    INTEGER, INTENT(IN)                   ::  n            !<
[1933]454    INTEGER, INTENT(IN)                   ::  child_rank   !<
[1900]455    INTEGER, INTENT(IN)                   ::  tag          !<
456    INTEGER, INTENT(OUT)                  ::  ierr         !<
457
[2599]458   
[1900]459    ierr = 0
[1933]460    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           &
461                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1900]462
[1933]463 END SUBROUTINE pmc_recv_from_child_real_r2
[1900]464
465
466
[1933]467 SUBROUTINE pmc_send_to_child_real_r3( child_id, buf, n, child_rank, tag,       &
[2599]468                                       ierr )
[1900]469
470    IMPLICIT NONE
471
[1933]472    INTEGER, INTENT(IN)                    ::  child_id     !<
[1900]473    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf          !<
474    INTEGER, INTENT(IN)                    ::  n            !<
[1933]475    INTEGER, INTENT(IN)                    ::  child_rank   !<
[1900]476    INTEGER, INTENT(IN)                    ::  tag          !<
477    INTEGER, INTENT(OUT)                   ::  ierr         !<
478
[2599]479   
[1900]480    ierr = 0
[1933]481    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
482                   m_to_child_comm(child_id), ierr )
[1900]483
[1933]484 END SUBROUTINE pmc_send_to_child_real_r3
[1900]485
486
487
[1933]488 SUBROUTINE pmc_recv_from_child_real_r3( child_id, buf, n, child_rank, tag,     &
489                                         ierr )
[1900]490
491    IMPLICIT NONE
492
[1933]493    INTEGER, INTENT(IN)                     ::  child_id     !<
[1900]494    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf          !<
495    INTEGER, INTENT(IN)                     ::  n            !<
[1933]496    INTEGER, INTENT(IN)                     ::  child_rank   !<
[1900]497    INTEGER, INTENT(IN)                     ::  tag          !<
498    INTEGER, INTENT(OUT)                    ::  ierr         !<
499
[2599]500   
[1900]501    ierr = 0
[1933]502    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           & 
503                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1900]504
[1933]505 END SUBROUTINE pmc_recv_from_child_real_r3
[1900]506
507
508
509 SUBROUTINE pmc_bcast_integer( buf, root_pe, comm, ierr )
510
511    IMPLICIT NONE
512
513    INTEGER, INTENT(INOUT)         ::  buf      !<
514    INTEGER, INTENT(IN)            ::  root_pe  !<
515    INTEGER, INTENT(IN), OPTIONAL  ::  comm     !<
516    INTEGER, INTENT(OUT), OPTIONAL ::  ierr     !<
517
518    INTEGER ::  mycomm  !<
519    INTEGER ::  myerr   !<
520
521
522    IF ( PRESENT( comm ) )  THEN
523       mycomm = comm
524    ELSE
525       mycomm = m_model_comm
526    ENDIF
527
528    CALL MPI_BCAST( buf, 1, MPI_INTEGER, root_pe, mycomm, myerr )
529
530    IF ( PRESENT( ierr ) )  THEN
531       ierr = myerr
532    ENDIF
533
534 END SUBROUTINE pmc_bcast_integer
535
536
537
538 SUBROUTINE pmc_bcast_character( buf, root_pe, comm, ierr )
539
540    IMPLICIT NONE
541
542    CHARACTER(LEN=*), INTENT(INOUT) ::  buf      !<
543    INTEGER, INTENT(IN)             ::  root_pe  !<
544    INTEGER, INTENT(IN), OPTIONAL   ::  comm     !<
545    INTEGER, INTENT(OUT), OPTIONAL  ::  ierr     !<
546
547    INTEGER ::  mycomm  !<
548    INTEGER ::  myerr   !<
549
[2599]550   
[1900]551    IF ( PRESENT( comm ) )  THEN
552       mycomm = comm
553    ELSE
554       mycomm = m_model_comm
555    ENDIF
556
557    CALL MPI_BCAST( buf, LEN(buf), MPI_CHARACTER, root_pe, mycomm, myerr )
558
559    IF ( PRESENT( ierr ) )  THEN
560       ierr = myerr
561    ENDIF
562
563 END SUBROUTINE pmc_bcast_character
564
565
566
[1933]567 SUBROUTINE pmc_inter_bcast_integer_1( buf, child_id, ierr )
[1900]568
569    IMPLICIT NONE
570
571    INTEGER, INTENT(INOUT),DIMENSION(:) ::  buf        !<
[1933]572    INTEGER, INTENT(IN),optional        ::  child_id   !<
[1900]573    INTEGER, INTENT(OUT),optional       ::  ierr       !<
574
575    INTEGER ::  mycomm   !<
576    INTEGER ::  myerr    !<
577    INTEGER ::  root_pe  !<
578
579!
[2599]580!-- Process 0 on parent broadcast to all child processes
[1933]581    IF ( PRESENT( child_id ) )  THEN
[1900]582
[1933]583       mycomm = m_to_child_comm(child_id)
[1900]584
585       IF ( m_model_rank == 0 )  THEN
586          root_pe = MPI_ROOT
587       ELSE
588          root_pe = MPI_PROC_NULL
589       ENDIF
590
591    ELSE
[1933]592       mycomm  = m_to_parent_comm
[1900]593       root_pe = 0
594    ENDIF
595
596    CALL MPI_BCAST( buf, SIZE( buf ), MPI_INTEGER, root_pe, mycomm, myerr )
597
598    IF ( PRESENT( ierr ) )  THEN
599       ierr = myerr
600    ENDIF
601
602 END SUBROUTINE pmc_inter_bcast_integer_1
603
604
605
606 SUBROUTINE pmc_alloc_mem_integer_1( iarray, idim1 )
607!
608!-- Allocate memory with MPI_ALLOC_MEM using intermediate C-pointer
609
610    IMPLICIT NONE
611
612    INTEGER, DIMENSION(:), POINTER, INTENT(INOUT) ::  iarray  !<
613    INTEGER, INTENT(IN)                           ::  idim1   !<
614
615    INTEGER, DIMENSION(1)          ::  ashape   !<
616    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
617    INTEGER                        ::  ierr     !<
618
619    TYPE(C_PTR)                    ::  p_myind  !<
620
[2599]621   
[2809]622    winsize = idim1 * STORAGE_SIZE( ierr )/8
[1900]623
624    CALL MPI_ALLOC_MEM( winsize, MPI_INFO_NULL, p_myind, ierr )
625    ashape(1) = idim1
626    CALL C_F_POINTER( p_myind, iarray, ashape )
627
628 END SUBROUTINE pmc_alloc_mem_integer_1
629
630
631
632 SUBROUTINE pmc_alloc_mem_real_1( array, idim1, base_ptr )
633
634    IMPLICIT NONE
635
636    INTEGER(idp), INTENT(IN)                            ::  idim1     !<
637    REAL(KIND=wp), DIMENSION(:), POINTER, INTENT(INOUT) ::  array     !<
638    TYPE(C_PTR), INTENT(OUT), OPTIONAL                  ::  base_ptr  !<
639
640    INTEGER, DIMENSION(1)          :: ashape   !<
641    INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize  !<
642    INTEGER                        :: ierr     !<
643
644    TYPE(C_PTR)                    :: p_myind  !<
645
[2599]646   
[1900]647    winsize = idim1 * wp
648
649    CALL MPI_ALLOC_MEM( winsize , MPI_INFO_NULL, p_myind, ierr )
650    ashape(1) = idim1
651    CALL C_F_POINTER( p_myind, array, ashape )
652
653    IF ( PRESENT( base_ptr ) )  THEN
654       base_ptr = p_myind
655    ENDIF
656
657 END SUBROUTINE pmc_alloc_mem_Real_1
658
659
660
661 FUNCTION pmc_time()
662
663    REAL(kind=wp) :: pmc_time  !<
664
[2599]665   
[1900]666    pmc_time = MPI_WTIME()
667
668  END FUNCTION pmc_time
669
[1764]670#endif
[1762]671 END MODULE pmc_mpi_wrapper
Note: See TracBrowser for help on using the repository browser.