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

Last change on this file since 1900 was 1900, checked in by raasch, 8 years ago

re-formatting of remaining pmc routines

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