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

Last change on this file since 4753 was 4649, checked in by raasch, 4 years ago

files re-formatted to follow the PALM coding standard

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