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

Last change on this file since 2841 was 2841, checked in by knoop, 4 years ago

Bugfix: wrong placement of include 'mpif.h' corrected

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