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

Last change on this file since 2809 was 2809, checked in by schwenkel, 4 years ago

Bugfix for gfortran: Replace the function C_SIZEOF with STORAGE_SIZE

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