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

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

Correction of "Former revisions" section

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