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

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

last commit documented

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