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

Last change on this file since 4204 was 4182, checked in by scharf, 5 years ago
  • corrected "Former revisions" section
  • minor formatting in "Former revisions" section
  • added "Author" section
  • Property svn:keywords set to Id
File size: 20.0 KB
Line 
1 MODULE pmc_mpi_wrapper
2
3!------------------------------------------------------------------------------!
4! This file is part of the PALM model system.
5!
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.
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!
18! Copyright 1997-2019 Leibniz Universitaet Hannover
19!------------------------------------------------------------------------------!
20!
21! Current revisions:
22! ------------------
23!
24!
25! Former revisions:
26! -----------------
27! $Id: pmc_mpi_wrapper_mod.f90 4182 2019-08-22 15:20:23Z knoop $
28! Corrected "Former revisions" section
29!
30! 3655 2019-01-07 16:51:22Z knoop
31! Extent interface by logical buffer
32!
33! 1762 2016-02-25 12:31:13Z hellstea
34! Initial revision by K. Ketelsen
35!
36! Description:
37! ------------
38!
39! MPI Wrapper of Palm Model Coupler
40!-------------------------------------------------------------------------------!
41
42#if defined( __parallel )
43    USE, INTRINSIC ::  ISO_C_BINDING
44
45#if !defined( __mpifh )
46    USE MPI
47#endif
48
49    USE kinds
50    USE pmc_handle_communicator,                                                &
51        ONLY: m_model_comm, m_model_rank, m_to_parent_comm, m_to_child_comm
52
53    IMPLICIT NONE
54
55#if defined( __mpifh )
56    INCLUDE "mpif.h"
57#endif
58
59    PRIVATE
60    SAVE
61
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
69
70    INTERFACE pmc_recv_from_parent
71       MODULE PROCEDURE pmc_recv_from_parent_logical
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
77
78    INTERFACE pmc_send_to_child
79       MODULE PROCEDURE pmc_send_to_child_logical
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
85
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
93
94    INTERFACE pmc_bcast
95       MODULE PROCEDURE pmc_bcast_integer
96       MODULE PROCEDURE pmc_bcast_character
97    END INTERFACE pmc_bcast
98
99    INTERFACE pmc_inter_bcast
100       MODULE PROCEDURE pmc_inter_bcast_integer_1
101    END INTERFACE pmc_inter_bcast
102
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
107
108    INTERFACE pmc_time
109       MODULE PROCEDURE pmc_time
110    END INTERFACE pmc_time
111
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,         &
114           pmc_time
115
116 CONTAINS
117
118
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
156 SUBROUTINE pmc_send_to_parent_integer( buf, n, parent_rank, tag, ierr )
157
158    IMPLICIT NONE
159
160    INTEGER, DIMENSION(:), INTENT(IN) ::  buf          !<
161    INTEGER, INTENT(IN)               ::  n            !<
162    INTEGER, INTENT(IN)               ::  parent_rank  !<
163    INTEGER, INTENT(IN)               ::  tag          !<
164    INTEGER, INTENT(OUT)              ::  ierr         !<
165
166   
167    ierr = 0
168    CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
169                   ierr )
170
171 END SUBROUTINE pmc_send_to_parent_integer
172
173
174 SUBROUTINE pmc_recv_from_parent_integer( buf, n, parent_rank, tag, ierr )
175
176    IMPLICIT NONE
177
178    INTEGER, DIMENSION(:), INTENT(OUT) ::  buf          !<
179    INTEGER, INTENT(IN)                ::  n            !<
180    INTEGER, INTENT(IN)                ::  parent_rank  !<
181    INTEGER, INTENT(IN)                ::  tag          !<
182    INTEGER, INTENT(OUT)               ::  ierr         !<
183
184   
185    ierr = 0
186    CALL MPI_RECV( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
187                   MPI_STATUS_IGNORE, ierr )
188
189 END SUBROUTINE pmc_recv_from_parent_integer
190
191
192
193 SUBROUTINE pmc_send_to_parent_integer_2( buf, n, parent_rank, tag, ierr )
194
195    IMPLICIT NONE
196
197    INTEGER, DIMENSION(:,:), INTENT(IN) :: buf          !<
198    INTEGER, INTENT(IN)                 :: n            !<
199    INTEGER, INTENT(IN)                 :: parent_rank  !<
200    INTEGER, INTENT(IN)                 :: tag          !<
201    INTEGER, INTENT(OUT)                :: ierr         !<
202
203   
204    ierr = 0
205    CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm,     &
206                   ierr )
207
208 END SUBROUTINE pmc_send_to_parent_integer_2
209
210
211
212 SUBROUTINE pmc_send_to_parent_real_r1( buf, n, parent_rank, tag, ierr )
213
214    IMPLICIT NONE
215
216    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf          !<
217    INTEGER, INTENT(IN)                ::  n            !<
218    INTEGER, INTENT(IN)                ::  parent_rank  !<
219    INTEGER, INTENT(IN)                ::  tag          !<
220    INTEGER, INTENT(OUT)               ::  ierr         !<
221
222   
223    ierr = 0
224    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
225
226 END SUBROUTINE pmc_send_to_parent_real_r1
227
228
229
230 SUBROUTINE pmc_recv_from_parent_real_r1( buf, n, parent_rank, tag, ierr )
231
232    IMPLICIT NONE
233
234    REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf          !<
235    INTEGER, INTENT(IN)                 ::  n            !<
236    INTEGER, INTENT(IN)                 ::  parent_rank  !<
237    INTEGER, INTENT(IN)                 ::  tag          !<
238    INTEGER, INTENT(OUT)                ::  ierr         !<
239
240   
241    ierr = 0
242    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
243                   MPI_STATUS_IGNORE, ierr )
244
245 END SUBROUTINE pmc_recv_from_parent_real_r1
246
247
248
249 SUBROUTINE pmc_send_to_parent_real_r2( buf, n, parent_rank, tag, ierr )
250
251    IMPLICIT NONE
252
253    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf          !<
254    INTEGER, INTENT(IN)                  ::  n            !<
255    INTEGER, INTENT(IN)                  ::  parent_rank  !<
256    INTEGER, INTENT(IN)                  ::  tag          !<
257    INTEGER, INTENT(OUT)                 ::  ierr         !<
258
259   
260    ierr = 0
261    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
262
263 END SUBROUTINE pmc_send_to_parent_real_r2
264
265
266 SUBROUTINE pmc_recv_from_parent_real_r2( buf, n, parent_rank, tag, ierr )
267
268    IMPLICIT NONE
269
270    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf          !<
271    INTEGER, INTENT(IN)                   ::  n            !<
272    INTEGER, INTENT(IN)                   ::  parent_rank  !<
273    INTEGER, INTENT(IN)                   ::  tag          !<
274    INTEGER, INTENT(OUT)                  ::  ierr         !<
275
276    ierr = 0
277    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
278                   MPI_STATUS_IGNORE, ierr )
279
280 END SUBROUTINE pmc_recv_from_parent_real_r2
281
282
283
284 SUBROUTINE pmc_send_to_parent_real_r3( buf, n, parent_rank, tag, ierr )
285
286    IMPLICIT NONE
287
288    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf          !<
289    INTEGER, INTENT(IN)                    ::  n            !<
290    INTEGER, INTENT(IN)                    ::  parent_rank  !<
291    INTEGER, INTENT(IN)                    ::  tag          !<
292    INTEGER, INTENT(OUT)                   ::  ierr         !<
293
294   
295    ierr = 0
296    CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
297
298 END SUBROUTINE pmc_send_to_parent_real_r3
299
300
301
302 SUBROUTINE pmc_recv_from_parent_real_r3( buf, n, parent_rank, tag, ierr )
303
304    IMPLICIT NONE
305
306    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf          !<
307    INTEGER, INTENT(IN)                     ::  n            !<
308    INTEGER, INTENT(IN)                     ::  parent_rank  !<
309    INTEGER, INTENT(IN)                     ::  tag          !<
310    INTEGER, INTENT(OUT)                    ::  ierr         !<
311
312   
313    ierr = 0
314    CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm,        &
315                   MPI_STATUS_IGNORE, ierr )
316
317 END SUBROUTINE pmc_recv_from_parent_real_r3
318
319
320 SUBROUTINE pmc_send_to_child_integer( child_id, buf, n, child_rank, tag,       &
321                                       ierr )
322
323    IMPLICIT NONE
324
325    INTEGER, INTENT(IN)               ::  child_id     !<
326    INTEGER, DIMENSION(:), INTENT(IN) ::  buf          !<
327    INTEGER, INTENT(IN)               ::  n            !<
328    INTEGER, INTENT(IN)               ::  child_rank   !<
329    INTEGER, INTENT(IN)               ::  tag          !<
330    INTEGER, INTENT(OUT)              ::  ierr         !<
331
332   
333    ierr = 0
334    CALL MPI_SEND( buf, n, MPI_INTEGER, child_rank, tag,                        &
335                   m_to_child_comm(child_id), ierr )
336
337 END SUBROUTINE pmc_send_to_child_integer
338
339
340
341 SUBROUTINE pmc_recv_from_child_integer( child_id, buf, n, child_rank, tag,     &
342                                         ierr )
343
344    IMPLICIT NONE
345
346    INTEGER, INTENT(IN)                  ::  child_id     !<
347    INTEGER, DIMENSION(:), INTENT(INOUT) ::  buf          !<
348    INTEGER, INTENT(IN)                  ::  n            !<
349    INTEGER, INTENT(IN)                  ::  child_rank   !<
350    INTEGER, INTENT(IN)                  ::  tag          !<
351    INTEGER, INTENT(OUT)                 ::  ierr         !<
352
353   
354    ierr = 0
355    CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag,                        &
356                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
357
358 END SUBROUTINE pmc_recv_from_child_integer
359
360
361
362 SUBROUTINE pmc_recv_from_child_integer_2( child_id, buf, n, child_rank,        &
363                                           tag, ierr )
364
365    IMPLICIT NONE
366
367    INTEGER, INTENT(IN)                  ::  child_id     !<
368    INTEGER, DIMENSION(:,:), INTENT(OUT) ::  buf          !<
369    INTEGER, INTENT(IN)                  ::  n            !<
370    INTEGER, INTENT(IN)                  ::  child_rank   !<
371    INTEGER, INTENT(IN)                  ::  tag          !<
372    INTEGER, INTENT(OUT)                 ::  ierr         !<
373
374   
375    ierr = 0
376    CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag,                        &
377                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
378
379 END SUBROUTINE pmc_recv_from_child_integer_2
380
381
382
383 SUBROUTINE pmc_send_to_child_real_r1( child_id, buf, n, child_rank, tag,       &
384                                       ierr )
385
386    IMPLICIT NONE
387
388    INTEGER, INTENT(IN)                ::  child_id     !<
389    REAL(wp), DIMENSION(:), INTENT(IN) ::  buf          !<
390    INTEGER, INTENT(IN)                ::  n            !<
391    INTEGER, INTENT(IN)                ::  child_rank   !<
392    INTEGER, INTENT(IN)                ::  tag          !<
393    INTEGER, INTENT(OUT)               ::  ierr         !<
394
395   
396    ierr = 0
397    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
398                   m_to_child_comm(child_id), ierr )
399
400 END SUBROUTINE pmc_send_to_child_real_r1
401
402
403
404 SUBROUTINE pmc_recv_from_child_real_r1( child_id, buf, n, child_rank, tag,     &
405                                         ierr )
406
407    IMPLICIT NONE
408
409    INTEGER, INTENT(IN)                   ::  child_id     !<
410    REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf          !<
411    INTEGER, INTENT(IN)                   ::  n            !<
412    INTEGER, INTENT(IN)                   ::  child_rank   !<
413    INTEGER, INTENT(IN)                   ::  tag          !<
414    INTEGER, INTENT(OUT)                  ::  ierr         !<
415
416   
417    ierr = 0
418    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           &
419                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
420
421 END SUBROUTINE pmc_recv_from_child_real_r1
422
423
424
425 SUBROUTINE pmc_send_to_child_real_r2( child_id, buf, n, child_rank, tag,       &
426                                       ierr )
427
428    IMPLICIT NONE
429
430    INTEGER, INTENT(IN)                  ::  child_id     !<
431    REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf          !<
432    INTEGER, INTENT(IN)                  ::  n            !<
433    INTEGER, INTENT(IN)                  ::  child_rank   !<
434    INTEGER, INTENT(IN)                  ::  tag          !<
435    INTEGER, INTENT(OUT)                 ::  ierr         !<
436
437   
438    ierr = 0
439    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
440                   m_to_child_comm(child_id), ierr )
441
442 END SUBROUTINE pmc_send_to_child_real_r2
443
444
445
446 SUBROUTINE pmc_recv_from_child_real_r2( child_id, buf, n, child_rank, tag,     &
447                                         ierr )
448
449    IMPLICIT NONE
450
451    INTEGER, INTENT(IN)                   ::  child_id     !<
452    REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf          !<
453    INTEGER, INTENT(IN)                   ::  n            !<
454    INTEGER, INTENT(IN)                   ::  child_rank   !<
455    INTEGER, INTENT(IN)                   ::  tag          !<
456    INTEGER, INTENT(OUT)                  ::  ierr         !<
457
458   
459    ierr = 0
460    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           &
461                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
462
463 END SUBROUTINE pmc_recv_from_child_real_r2
464
465
466
467 SUBROUTINE pmc_send_to_child_real_r3( child_id, buf, n, child_rank, tag,       &
468                                       ierr )
469
470    IMPLICIT NONE
471
472    INTEGER, INTENT(IN)                    ::  child_id     !<
473    REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf          !<
474    INTEGER, INTENT(IN)                    ::  n            !<
475    INTEGER, INTENT(IN)                    ::  child_rank   !<
476    INTEGER, INTENT(IN)                    ::  tag          !<
477    INTEGER, INTENT(OUT)                   ::  ierr         !<
478
479   
480    ierr = 0
481    CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag,                           &
482                   m_to_child_comm(child_id), ierr )
483
484 END SUBROUTINE pmc_send_to_child_real_r3
485
486
487
488 SUBROUTINE pmc_recv_from_child_real_r3( child_id, buf, n, child_rank, tag,     &
489                                         ierr )
490
491    IMPLICIT NONE
492
493    INTEGER, INTENT(IN)                     ::  child_id     !<
494    REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf          !<
495    INTEGER, INTENT(IN)                     ::  n            !<
496    INTEGER, INTENT(IN)                     ::  child_rank   !<
497    INTEGER, INTENT(IN)                     ::  tag          !<
498    INTEGER, INTENT(OUT)                    ::  ierr         !<
499
500   
501    ierr = 0
502    CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag,                           & 
503                   m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
504
505 END SUBROUTINE pmc_recv_from_child_real_r3
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
550   
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
567 SUBROUTINE pmc_inter_bcast_integer_1( buf, child_id, ierr )
568
569    IMPLICIT NONE
570
571    INTEGER, INTENT(INOUT),DIMENSION(:) ::  buf        !<
572    INTEGER, INTENT(IN),optional        ::  child_id   !<
573    INTEGER, INTENT(OUT),optional       ::  ierr       !<
574
575    INTEGER ::  mycomm   !<
576    INTEGER ::  myerr    !<
577    INTEGER ::  root_pe  !<
578
579!
580!-- Process 0 on parent broadcast to all child processes
581    IF ( PRESENT( child_id ) )  THEN
582
583       mycomm = m_to_child_comm(child_id)
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
592       mycomm  = m_to_parent_comm
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
621   
622    winsize = idim1 * STORAGE_SIZE( ierr )/8
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
646   
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
665   
666    pmc_time = MPI_WTIME()
667
668  END FUNCTION pmc_time
669
670#endif
671 END MODULE pmc_mpi_wrapper
Note: See TracBrowser for help on using the repository browser.