source: palm/tags/release-5.0/SOURCE/pmc_mpi_wrapper_mod.f90 @ 4383

Last change on this file since 4383 was 2696, checked in by kanani, 6 years ago

Merge of branch palm4u into trunk

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