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

Last change on this file since 4180 was 4180, checked in by scharf, 2 years ago

removed comments in 'Former revisions' section that are older than 01.01.2019

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