source: palm/trunk/SOURCE/pmc_mpi_wrapper_mod.f90

Last change on this file was 4828, checked in by Giersch, 9 months ago

Copyright updated to year 2021, interface pmc_sort removed to accelarate the nesting code

  • Property svn:keywords set to Id
File size: 24.8 KB
Line 
1 MODULE pmc_mpi_wrapper
2!--------------------------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
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.
8!
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.
12!
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/>.
15!
16! Copyright 1997-2021 Leibniz Universitaet Hannover
17!--------------------------------------------------------------------------------------------------!
18!
19!
20! Current revisions:
21! -----------------
22!
23!
24! Former revisions:
25! -----------------
26! $Id: pmc_mpi_wrapper_mod.f90 4828 2021-01-05 11:21:41Z banzhafs $
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!
36! 4360 2020-01-07 11:25:50Z suehring
37! Corrected "Former revisions" section
38!
39! 3655 2019-01-07 16:51:22Z knoop
40! Extent interface by logical buffer
41!
42! 1762 2016-02-25 12:31:13Z hellstea
43! Initial revision by K. Ketelsen
44!
45!
46!--------------------------------------------------------------------------------------------------!
47! Description:
48! ------------
49!
50! MPI Wrapper of Palm Model Coupler
51!--------------------------------------------------------------------------------------------------!
52
53#if defined( __parallel )
54    USE, INTRINSIC ::  ISO_C_BINDING
55
56    USE MPI
57
58    USE kinds
59    USE pmc_handle_communicator,                                                                   &
60        ONLY: m_model_comm,                                                                        &
61              m_model_rank,                                                                        &
62              m_to_child_comm,                                                                     &
63              m_to_parent_comm
64
65
66    IMPLICIT NONE
67
68
69    PRIVATE
70    SAVE
71
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
79
80    INTERFACE pmc_recv_from_parent
81       MODULE PROCEDURE pmc_recv_from_parent_logical
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
87
88    INTERFACE pmc_send_to_child
89       MODULE PROCEDURE pmc_send_to_child_logical
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
95
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
103
104    INTERFACE pmc_bcast
105       MODULE PROCEDURE pmc_bcast_integer
106       MODULE PROCEDURE pmc_bcast_character
107    END INTERFACE pmc_bcast
108
109    INTERFACE pmc_inter_bcast
110       MODULE PROCEDURE pmc_inter_bcast_integer_1
111    END INTERFACE pmc_inter_bcast
112
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
117
118    INTERFACE pmc_time
119       MODULE PROCEDURE pmc_time
120    END INTERFACE pmc_time
121
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,                                                                     &
129           pmc_time
130
131 CONTAINS
132
133!--------------------------------------------------------------------------------------------------!
134! Description:
135! ------------
136!
137!> @Todo: Missing subroutine description.
138!--------------------------------------------------------------------------------------------------!
139 SUBROUTINE pmc_recv_from_parent_logical( buf, n, parent_rank, tag, ierr )
140
141    IMPLICIT NONE
142
143    INTEGER, INTENT(IN) ::  n            !<
144    INTEGER, INTENT(IN) ::  parent_rank  !<
145    INTEGER, INTENT(IN) ::  tag          !<
146
147    INTEGER, INTENT(OUT) ::  ierr  !<
148
149    LOGICAL, INTENT(OUT) ::  buf   !<
150
151    ierr = 0
152    CALL MPI_RECV( buf, n, MPI_LOGICAL, parent_rank, tag, m_to_parent_comm, MPI_STATUS_IGNORE,     &
153                   ierr )
154
155 END SUBROUTINE pmc_recv_from_parent_logical
156
157
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
166    IMPLICIT NONE
167
168    INTEGER, INTENT(IN) ::  child_id    !<
169    INTEGER, INTENT(IN) ::  child_rank  !<
170    INTEGER, INTENT(IN) ::  n           !<
171    INTEGER, INTENT(IN) ::  tag         !<
172
173    INTEGER, INTENT(OUT) ::  ierr  !<
174
175    LOGICAL, INTENT(IN) ::  buf  !<
176
177    ierr = 0
178    CALL MPI_SEND( buf, n, MPI_LOGICAL, child_rank, tag, m_to_child_comm(child_id), ierr )
179
180 END SUBROUTINE pmc_send_to_child_logical
181
182
183!--------------------------------------------------------------------------------------------------!
184! Description:
185! ------------
186!
187!> @Todo: Missing subroutine description.
188!--------------------------------------------------------------------------------------------------!
189 SUBROUTINE pmc_send_to_parent_integer( buf, n, parent_rank, tag, ierr )
190
191    IMPLICIT NONE
192
193    INTEGER, INTENT(IN) ::  n            !<
194    INTEGER, INTENT(IN) ::  parent_rank  !<
195    INTEGER, INTENT(IN) ::  tag          !<
196
197    INTEGER, DIMENSION(:), INTENT(IN) ::  buf  !<
198
199    INTEGER, INTENT(OUT) ::  ierr  !<
200
201
202    ierr = 0
203    CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, ierr )
204
205 END SUBROUTINE pmc_send_to_parent_integer
206
207
208!--------------------------------------------------------------------------------------------------!
209! Description:
210! ------------
211!
212!> @Todo: Missing subroutine description.
213!--------------------------------------------------------------------------------------------------!
214 SUBROUTINE pmc_recv_from_parent_integer( buf, n, parent_rank, tag, ierr )
215
216    IMPLICIT NONE
217
218    INTEGER, INTENT(IN) ::  n            !<
219    INTEGER, INTENT(IN) ::  parent_rank  !<
220    INTEGER, INTENT(IN) ::  tag          !<
221
222    INTEGER, INTENT(OUT) ::  ierr  !<
223
224    INTEGER, DIMENSION(:), INTENT(OUT) :: buf  !<
225
226
227    ierr = 0
228    CALL MPI_RECV( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, MPI_STATUS_IGNORE,     &
229                   ierr )
230
231 END SUBROUTINE pmc_recv_from_parent_integer
232
233
234!--------------------------------------------------------------------------------------------------!
235! Description:
236! ------------
237!
238!> @Todo: Missing subroutine description.
239!--------------------------------------------------------------------------------------------------!
240 SUBROUTINE pmc_send_to_parent_integer_2( buf, n, parent_rank, tag, ierr )
241
242    IMPLICIT NONE
243
244    INTEGER, INTENT(IN) :: n            !<
245    INTEGER, INTENT(IN) :: parent_rank  !<
246    INTEGER, INTENT(IN) :: tag          !<
247
248    INTEGER, DIMENSION(:,:), INTENT(IN) :: buf  !<
249
250    INTEGER, INTENT(OUT) :: ierr  !<
251
252
253    ierr = 0
254    CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, ierr )
255
256 END SUBROUTINE pmc_send_to_parent_integer_2
257
258
259
260!--------------------------------------------------------------------------------------------------!
261! Description:
262! ------------
263!
264!> @Todo: Missing subroutine description.
265!--------------------------------------------------------------------------------------------------!
266 SUBROUTINE pmc_send_to_parent_real_r1( buf, n, parent_rank, tag, ierr )
267
268    IMPLICIT NONE
269
270
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
280    ierr = 0
281    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
282
283 END SUBROUTINE pmc_send_to_parent_real_r1
284
285
286!--------------------------------------------------------------------------------------------------!
287! Description:
288! ------------
289!
290!> @Todo: Missing subroutine description.
291!--------------------------------------------------------------------------------------------------!
292 SUBROUTINE pmc_recv_from_parent_real_r1( buf, n, parent_rank, tag, ierr )
293
294    IMPLICIT NONE
295
296    INTEGER, INTENT(IN) ::  n            !<
297    INTEGER, INTENT(IN) ::  parent_rank  !<
298    INTEGER, INTENT(IN) ::  tag          !<
299
300    INTEGER, INTENT(OUT) ::  ierr  !<
301
302    REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf  !<
303
304
305    ierr = 0
306    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, MPI_STATUS_IGNORE, ierr )
307
308 END SUBROUTINE pmc_recv_from_parent_real_r1
309
310
311!--------------------------------------------------------------------------------------------------!
312! Description:
313! ------------
314!
315!> @Todo: Missing subroutine description.
316!--------------------------------------------------------------------------------------------------!
317 SUBROUTINE pmc_send_to_parent_real_r2( buf, n, parent_rank, tag, ierr )
318
319    IMPLICIT NONE
320
321    INTEGER, INTENT(IN) ::  n            !<
322    INTEGER, INTENT(IN) ::  parent_rank  !<
323    INTEGER, INTENT(IN) ::  tag          !<
324
325    INTEGER, INTENT(OUT) ::  ierr  !<
326
327    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf  !<
328
329
330    ierr = 0
331    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
332
333 END SUBROUTINE pmc_send_to_parent_real_r2
334
335
336!--------------------------------------------------------------------------------------------------!
337! Description:
338! ------------
339!
340!> @Todo: Missing subroutine description.
341!--------------------------------------------------------------------------------------------------!
342 SUBROUTINE pmc_recv_from_parent_real_r2( buf, n, parent_rank, tag, ierr )
343
344    IMPLICIT NONE
345
346    INTEGER, INTENT(IN) ::  n            !<
347    INTEGER, INTENT(IN) ::  parent_rank  !<
348    INTEGER, INTENT(IN) ::  tag          !<
349
350    INTEGER, INTENT(OUT) ::  ierr  !<
351
352     REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf  !<
353
354
355    ierr = 0
356    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, MPI_STATUS_IGNORE, ierr )
357
358 END SUBROUTINE pmc_recv_from_parent_real_r2
359
360
361!--------------------------------------------------------------------------------------------------!
362! Description:
363! ------------
364!
365!> @Todo: Missing subroutine description.
366!--------------------------------------------------------------------------------------------------!
367 SUBROUTINE pmc_send_to_parent_real_r3( buf, n, parent_rank, tag, ierr )
368
369    IMPLICIT NONE
370
371    INTEGER, INTENT(IN) ::  n            !<
372    INTEGER, INTENT(IN) ::  parent_rank  !<
373    INTEGER, INTENT(IN) ::  tag          !<
374
375    INTEGER, INTENT(OUT) ::  ierr  !<
376
377    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf  !<
378
379
380    ierr = 0
381    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
382
383 END SUBROUTINE pmc_send_to_parent_real_r3
384
385
386!--------------------------------------------------------------------------------------------------!
387! Description:
388! ------------
389!
390!> @Todo: Missing subroutine description.
391!--------------------------------------------------------------------------------------------------!
392 SUBROUTINE pmc_recv_from_parent_real_r3( buf, n, parent_rank, tag, ierr )
393
394    IMPLICIT NONE
395
396    INTEGER, INTENT(IN) ::  n            !<
397    INTEGER, INTENT(IN) ::  parent_rank  !<
398    INTEGER, INTENT(IN) ::  tag          !<
399
400    INTEGER, INTENT(OUT) ::  ierr  !<
401
402    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf  !<
403
404
405    ierr = 0
406    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, MPI_STATUS_IGNORE, ierr )
407
408 END SUBROUTINE pmc_recv_from_parent_real_r3
409
410
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 )
418
419    IMPLICIT NONE
420
421    INTEGER, INTENT(IN) ::  child_id    !<
422    INTEGER, INTENT(IN) ::  child_rank  !<
423    INTEGER, INTENT(IN) ::  n           !<
424    INTEGER, INTENT(IN) ::  tag         !<
425
426    INTEGER, DIMENSION(:), INTENT(IN) ::  buf  !<
427
428    INTEGER, INTENT(OUT) ::  ierr  !<
429
430
431    ierr = 0
432    CALL MPI_SEND( buf, n, MPI_INTEGER, child_rank, tag, m_to_child_comm(child_id), ierr )
433
434 END SUBROUTINE pmc_send_to_child_integer
435
436
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 )
444
445    IMPLICIT NONE
446
447    INTEGER, INTENT(IN) ::  child_id    !<
448    INTEGER, INTENT(IN) ::  child_rank  !<
449    INTEGER, INTENT(IN) ::  n           !<
450    INTEGER, INTENT(IN) ::  tag         !<
451
452    INTEGER, INTENT(OUT) ::  ierr  !<
453
454    INTEGER, DIMENSION(:), INTENT(INOUT) ::  buf  !<
455
456
457    ierr = 0
458    CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag, m_to_child_comm(child_id),                &
459                   MPI_STATUS_IGNORE, ierr )
460
461 END SUBROUTINE pmc_recv_from_child_integer
462
463
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 )
471
472    IMPLICIT NONE
473
474    INTEGER, INTENT(IN) ::  child_id    !<
475    INTEGER, INTENT(IN) ::  child_rank  !<
476    INTEGER, INTENT(IN) ::  n           !<
477    INTEGER, INTENT(IN) ::  tag         !<
478
479    INTEGER, INTENT(OUT) ::  ierr  !<
480
481    INTEGER, DIMENSION(:,:), INTENT(OUT) ::  buf  !<
482
483
484    ierr = 0
485    CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag, m_to_child_comm(child_id),                &
486                   MPI_STATUS_IGNORE, ierr )
487
488 END SUBROUTINE pmc_recv_from_child_integer_2
489
490
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 )
498
499    IMPLICIT NONE
500
501    INTEGER, INTENT(IN) ::  child_id    !<
502    INTEGER, INTENT(IN) ::  child_rank  !<
503    INTEGER, INTENT(IN) ::  n           !<
504    INTEGER, INTENT(IN) ::  tag         !<
505
506    INTEGER, INTENT(OUT) ::  ierr  !<
507
508    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf  !<
509
510
511    ierr = 0
512    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id), ierr )
513
514 END SUBROUTINE pmc_send_to_child_real_r1
515
516
517
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 )
525
526    IMPLICIT NONE
527
528    INTEGER, INTENT(IN) ::  child_id    !<
529    INTEGER, INTENT(IN) ::  child_rank  !<
530    INTEGER, INTENT(IN) ::  n           !<
531    INTEGER, INTENT(IN) ::  tag         !<
532
533    INTEGER, INTENT(OUT) ::  ierr  !<
534
535    REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf  !<
536
537
538    ierr = 0
539    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id),                   &
540                   MPI_STATUS_IGNORE, ierr )
541
542 END SUBROUTINE pmc_recv_from_child_real_r1
543
544
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 )
552
553    IMPLICIT NONE
554
555    INTEGER, INTENT(IN) ::  child_id    !<
556    INTEGER, INTENT(IN) ::  child_rank  !<
557    INTEGER, INTENT(IN) ::  n           !<
558    INTEGER, INTENT(IN) ::  tag         !<
559
560    INTEGER, INTENT(OUT) ::  ierr  !<
561
562    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf  !<
563
564
565    ierr = 0
566    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id), ierr )
567
568 END SUBROUTINE pmc_send_to_child_real_r2
569
570
571
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 )
579
580    IMPLICIT NONE
581
582    INTEGER, INTENT(IN) ::  child_id    !<
583    INTEGER, INTENT(IN) ::  child_rank  !<
584    INTEGER, INTENT(IN) ::  n           !<
585    INTEGER, INTENT(IN) ::  tag         !<
586
587    INTEGER, INTENT(OUT) ::  ierr  !<
588
589    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf  !<
590
591
592    ierr = 0
593    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id),                   &
594                   MPI_STATUS_IGNORE, ierr )
595
596 END SUBROUTINE pmc_recv_from_child_real_r2
597
598
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 )
606
607    IMPLICIT NONE
608
609    INTEGER, INTENT(IN) ::  child_id    !<
610    INTEGER, INTENT(IN) ::  child_rank  !<
611    INTEGER, INTENT(IN) ::  n           !<
612    INTEGER, INTENT(IN) ::  tag         !<
613
614    INTEGER, INTENT(OUT) ::  ierr  !<
615
616    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf  !<
617
618
619    ierr = 0
620    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id), ierr )
621
622 END SUBROUTINE pmc_send_to_child_real_r3
623
624
625
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 )
633
634    IMPLICIT NONE
635
636    INTEGER, INTENT(IN) ::  child_id    !<
637    INTEGER, INTENT(IN) ::  child_rank  !<
638    INTEGER, INTENT(IN) ::  n           !<
639    INTEGER, INTENT(IN) ::  tag         !<
640
641    INTEGER, INTENT(OUT) ::  ierr  !<
642
643    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf  !<
644
645
646    ierr = 0
647    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id),                   &
648                   MPI_STATUS_IGNORE, ierr )
649
650 END SUBROUTINE pmc_recv_from_child_real_r3
651
652
653
654!--------------------------------------------------------------------------------------------------!
655! Description:
656! ------------
657!
658!> @Todo: Missing subroutine description.
659!--------------------------------------------------------------------------------------------------!
660 SUBROUTINE pmc_bcast_integer( buf, root_pe, comm, ierr )
661
662    IMPLICIT NONE
663
664    INTEGER, INTENT(IN) ::  root_pe  !<
665
666    INTEGER, INTENT(INOUT) ::  buf  !<
667
668    INTEGER, INTENT(IN), OPTIONAL ::  comm  !<
669
670    INTEGER, INTENT(OUT), OPTIONAL ::  ierr  !<
671
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
691!--------------------------------------------------------------------------------------------------!
692! Description:
693! ------------
694!
695!> @Todo: Missing subroutine description.
696!--------------------------------------------------------------------------------------------------!
697 SUBROUTINE pmc_bcast_character( buf, root_pe, comm, ierr )
698
699    IMPLICIT NONE
700
701    CHARACTER(LEN=*), INTENT(INOUT) ::  buf  !<
702
703    INTEGER, INTENT(IN) ::  root_pe  !<
704
705    INTEGER, INTENT(IN), OPTIONAL ::  comm  !<
706
707    INTEGER, INTENT(OUT), OPTIONAL ::  ierr  !<
708
709    INTEGER ::  mycomm  !<
710    INTEGER ::  myerr   !<
711
712
713    IF ( PRESENT( comm ) )  THEN
714       mycomm = comm
715    ELSE
716       mycomm = m_model_comm
717    ENDIF
718
719    CALL MPI_BCAST( buf, LEN( buf ), MPI_CHARACTER, root_pe, mycomm, myerr )
720
721    IF ( PRESENT( ierr ) )  THEN
722       ierr = myerr
723    ENDIF
724
725 END SUBROUTINE pmc_bcast_character
726
727
728!--------------------------------------------------------------------------------------------------!
729! Description:
730! ------------
731!
732!> @Todo: Missing subroutine description.
733!--------------------------------------------------------------------------------------------------!
734 SUBROUTINE pmc_inter_bcast_integer_1( buf, child_id, ierr )
735
736    IMPLICIT NONE
737
738    INTEGER, INTENT(IN),optional ::  child_id  !<
739
740    INTEGER, INTENT(OUT),optional ::  ierr  !<
741
742    INTEGER, INTENT(INOUT),DIMENSION(:) ::  buf  !<
743
744    INTEGER ::  mycomm   !<
745    INTEGER ::  myerr    !<
746    INTEGER ::  root_pe  !<
747
748!
749!-- Process 0 on parent broadcast to all child processes
750    IF ( PRESENT( child_id ) )  THEN
751
752       mycomm = m_to_child_comm(child_id)
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
761       mycomm  = m_to_parent_comm
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
775!--------------------------------------------------------------------------------------------------!
776! Description:
777! ------------
778!
779!> @Todo: Missing subroutine description.
780!--------------------------------------------------------------------------------------------------!
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
787    INTEGER, INTENT(IN) ::  idim1  !<
788
789    INTEGER ::  ierr  !<
790
791    INTEGER, DIMENSION(1) ::  ashape  !<
792
793    INTEGER, DIMENSION(:), POINTER, INTENT(INOUT) ::  iarray  !<
794
795    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
796
797    TYPE(C_PTR) ::  p_myind  !<
798
799
800    winsize = idim1 * STORAGE_SIZE( ierr ) / 8
801
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
810!--------------------------------------------------------------------------------------------------!
811! Description:
812! ------------
813!
814!> @Todo: Missing subroutine description.
815!--------------------------------------------------------------------------------------------------!
816 SUBROUTINE pmc_alloc_mem_real_1( array, idim1, base_ptr )
817
818    IMPLICIT NONE
819
820    INTEGER(idp), INTENT(IN) ::  idim1  !<
821
822    INTEGER :: ierr  !<
823
824    INTEGER, DIMENSION(1) ::  ashape  !<
825
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
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
851    REAL(KIND=wp) :: pmc_time  !<
852
853
854    pmc_time = MPI_WTIME()
855
856  END FUNCTION pmc_time
857
858#endif
859 END MODULE pmc_mpi_wrapper
Note: See TracBrowser for help on using the repository browser.