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

Last change on this file since 4632 was 4629, checked in by raasch, 4 years ago

support for MPI Fortran77 interface (mpif.h) removed

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