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

Last change on this file since 2834 was 2809, checked in by schwenkel, 7 years ago

Bugfix for gfortran: Replace the function C_SIZEOF with STORAGE_SIZE

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