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

Last change on this file since 2000 was 2000, checked in by knoop, 5 years ago

Forced header and separation lines into 80 columns

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