source: palm/trunk/SOURCE/pmc_child_mod.f90 @ 3943

Last change on this file since 3943 was 3943, checked in by maronga, 2 years ago

bugfixes in urban surface model; output of greenz roof transpiration added/corrected; minor formatting improvements

  • Property svn:keywords set to Id
File size: 29.5 KB
Line 
1MODULE pmc_child
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-2019 Leibniz Universitaet Hannover
19!------------------------------------------------------------------------------!
20!
21! Current revisions:
22! ------------------
23!
24!
25! Former revisions:
26! -----------------
27! $Id: pmc_child_mod.f90 3943 2019-05-02 09:50:41Z maronga $
28! typo removed
29!
30! 3932 2019-04-24 17:31:34Z suehring
31! statement added to avoid compiler warning
32!
33! 3655 2019-01-07 16:51:22Z knoop
34! explicit kind settings
35!
36! 3241 2018-09-12 15:02:00Z raasch
37! unused variables removed
38!
39! 2841 2018-02-27 15:02:57Z knoop
40! Bugfix: wrong placement of include 'mpif.h' corrected
41!
42! 2809 2018-02-15 09:55:58Z schwenkel
43! Bugfix for gfortran: Replace the function C_SIZEOF with STORAGE_SIZE
44!
45! 2801 2018-02-14 16:01:55Z thiele
46! Introduce particle transfer in nested models.
47!
48! 2718 2018-01-02 08:49:38Z maronga
49! Corrected "Former revisions" section
50!
51! 2696 2017-12-14 17:12:51Z kanani
52! Change in file header (GPL part)
53!
54! 2599 2017-11-01 13:18:45Z hellstea
55! Some cleanup and commenting improvements only.
56!
57! 2101 2017-01-05 16:42:31Z suehring
58!
59! 2000 2016-08-20 18:09:15Z knoop
60! Forced header and separation lines into 80 columns
61!
62! 1897 2016-05-03 08:10:23Z raasch
63! Module renamed. Code clean up. The words server/client changed to parent/child.
64!
65! 1896 2016-05-03 08:06:41Z raasch
66! re-formatted to match PALM style
67!
68! 1850 2016-04-08 13:29:27Z maronga
69! Module renamed
70!
71!
72! 1833 2016-04-07 14:23:03Z raasch
73! gfortran requires pointer attributes for some array declarations,
74! long line wrapped
75!
76! 1808 2016-04-05 19:44:00Z raasch
77! MPI module used by default on all machines
78!
79! 1797 2016-03-21 16:50:28Z raasch
80! introduction of different datatransfer modes
81!
82! 1791 2016-03-11 10:41:25Z raasch
83! Debug write-statement commented out
84!
85! 1786 2016-03-08 05:49:27Z raasch
86! change in child-parent data transfer: parent now gets data from child
87! instead of that child puts it to the parent
88!
89! 1783 2016-03-06 18:36:17Z raasch
90! Bugfix: wrong data-type in MPI_WIN_CREATE replaced
91!
92! 1779 2016-03-03 08:01:28Z raasch
93! kind=dp replaced by wp, dim_order removed
94! array management changed from linked list to sequential loop
95!
96! 1764 2016-02-28 12:45:19Z raasch
97! cpp-statement added (nesting can only be used in parallel mode),
98! all kinds given in PALM style
99!
100! 1762 2016-02-25 12:31:13Z hellstea
101! Initial revision by K. Ketelsen
102!
103! Description:
104! ------------
105!
106! Child part of Palm Model Coupler
107!------------------------------------------------------------------------------!
108
109#if defined( __parallel )
110
111    USE, INTRINSIC ::  iso_c_binding
112
113#if !defined( __mpifh )
114    USE MPI
115#endif
116
117    USE kinds
118
119    USE pmc_general,                                                           &
120        ONLY:  arraydef, childdef, da_desclen, da_namedef, da_namelen, pedef,  &
121               pmc_da_name_err,  pmc_g_setname, pmc_max_array, pmc_status_ok
122
123    USE pmc_handle_communicator,                                               &
124        ONLY:  m_model_comm, m_model_npes, m_model_rank, m_to_parent_comm
125
126    USE pmc_mpi_wrapper,                                                       &
127        ONLY:  pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_time
128
129    IMPLICIT NONE
130
131#if defined( __mpifh )
132    INCLUDE "mpif.h"
133#endif
134
135    PRIVATE
136    SAVE
137
138    TYPE(childdef), PUBLIC ::  me   !<
139
140    INTEGER(iwp) ::  myindex = 0         !< counter and unique number for data arrays
141    INTEGER(iwp) ::  next_array_in_list = 0   !<
142
143
144    INTERFACE pmc_childinit
145        MODULE PROCEDURE pmc_childinit
146    END INTERFACE pmc_childinit
147
148    INTERFACE pmc_c_clear_next_array_list
149        MODULE PROCEDURE pmc_c_clear_next_array_list
150    END INTERFACE pmc_c_clear_next_array_list
151
152    INTERFACE pmc_c_getbuffer
153        MODULE PROCEDURE pmc_c_getbuffer
154    END INTERFACE pmc_c_getbuffer
155
156    INTERFACE pmc_c_getnextarray
157        MODULE PROCEDURE pmc_c_getnextarray
158    END INTERFACE pmc_c_getnextarray
159
160    INTERFACE pmc_c_get_2d_index_list
161        MODULE PROCEDURE pmc_c_get_2d_index_list
162    END INTERFACE pmc_c_get_2d_index_list
163
164    INTERFACE pmc_c_putbuffer
165        MODULE PROCEDURE pmc_c_putbuffer
166    END INTERFACE pmc_c_putbuffer
167
168    INTERFACE pmc_c_setind_and_allocmem
169        MODULE PROCEDURE pmc_c_setind_and_allocmem
170    END INTERFACE pmc_c_setind_and_allocmem
171
172    INTERFACE pmc_c_set_dataarray
173        MODULE PROCEDURE pmc_c_set_dataarray_2d
174        MODULE PROCEDURE pmc_c_set_dataarray_3d
175        MODULE PROCEDURE pmc_c_set_dataarray_ip2d
176    END INTERFACE pmc_c_set_dataarray
177
178    INTERFACE pmc_set_dataarray_name
179        MODULE PROCEDURE pmc_set_dataarray_name
180        MODULE PROCEDURE pmc_set_dataarray_name_lastentry
181    END INTERFACE pmc_set_dataarray_name
182
183
184    PUBLIC pmc_childinit, pmc_c_clear_next_array_list, pmc_c_getbuffer,        &
185           pmc_c_getnextarray, pmc_c_putbuffer, pmc_c_setind_and_allocmem,     &
186           pmc_c_set_dataarray, pmc_set_dataarray_name, pmc_c_get_2d_index_list
187
188 CONTAINS
189
190
191
192 SUBROUTINE pmc_childinit
193
194     IMPLICIT NONE
195
196     INTEGER(iwp) ::  i        !<
197     INTEGER(iwp) ::  istat    !<
198
199!
200!--  Get / define the MPI environment
201     me%model_comm = m_model_comm
202     me%inter_comm = m_to_parent_comm
203
204     CALL MPI_COMM_RANK( me%model_comm, me%model_rank, istat )
205     CALL MPI_COMM_SIZE( me%model_comm, me%model_npes, istat )
206     CALL MPI_COMM_REMOTE_SIZE( me%inter_comm, me%inter_npes, istat )
207!
208!--  Intra-communicator is used for MPI_GET
209     CALL MPI_INTERCOMM_MERGE( me%inter_comm, .TRUE., me%intra_comm, istat )
210     CALL MPI_COMM_RANK( me%intra_comm, me%intra_rank, istat )
211
212     ALLOCATE( me%pes(me%inter_npes) )
213!
214!--  Allocate an array of type arraydef for all parent processes to store
215!--  information of then transfer array
216     DO  i = 1, me%inter_npes
217        ALLOCATE( me%pes(i)%array_list(pmc_max_array) )
218     ENDDO
219
220 END SUBROUTINE pmc_childinit
221
222
223
224 SUBROUTINE pmc_set_dataarray_name( parentarraydesc, parentarrayname,          &
225                                    childarraydesc, childarrayname, istat )
226
227    IMPLICIT NONE
228
229    CHARACTER(LEN=*), INTENT(IN) ::  parentarrayname  !<
230    CHARACTER(LEN=*), INTENT(IN) ::  parentarraydesc  !<
231    CHARACTER(LEN=*), INTENT(IN) ::  childarrayname   !<
232    CHARACTER(LEN=*), INTENT(IN) ::  childarraydesc   !<
233
234    INTEGER(iwp), INTENT(OUT) ::  istat  !<
235!
236!-- Local variables
237    TYPE(da_namedef) ::  myname  !<
238
239    INTEGER(iwp) ::  mype  !<
240
241
242    istat = pmc_status_ok
243!
244!-- Check length of array names
245    IF ( LEN( TRIM( parentarrayname) ) > da_namelen  .OR.                      &
246         LEN( TRIM( childarrayname) ) > da_namelen )  THEN
247       istat = pmc_da_name_err
248    ENDIF
249
250    IF ( m_model_rank == 0 )  THEN
251       myindex = myindex + 1
252       myname%couple_index = myindex
253       myname%parentdesc   = TRIM( parentarraydesc )
254       myname%nameonparent = TRIM( parentarrayname )
255       myname%childdesc    = TRIM( childarraydesc )
256       myname%nameonchild  = TRIM( childarrayname )
257    ENDIF
258
259!
260!-- Broadcast to all child processes
261!
262!-- The complete description of an transfer names array is broadcasted
263
264    CALL pmc_bcast( myname%couple_index, 0, comm=m_model_comm )
265    CALL pmc_bcast( myname%parentdesc,   0, comm=m_model_comm )
266    CALL pmc_bcast( myname%nameonparent, 0, comm=m_model_comm )
267    CALL pmc_bcast( myname%childdesc,    0, comm=m_model_comm )
268    CALL pmc_bcast( myname%nameonchild,  0, comm=m_model_comm )
269!
270!-- Broadcast to all parent processes
271!-- The complete description of an transfer array names is broadcasted als to all parent processe
272!   Only the root PE of the broadcasts to parent using intra communicator
273
274    IF ( m_model_rank == 0 )  THEN
275        mype = MPI_ROOT
276    ELSE
277        mype = MPI_PROC_NULL
278    ENDIF
279
280    CALL pmc_bcast( myname%couple_index, mype, comm=m_to_parent_comm )
281    CALL pmc_bcast( myname%parentdesc,   mype, comm=m_to_parent_comm )
282    CALL pmc_bcast( myname%nameonparent, mype, comm=m_to_parent_comm )
283    CALL pmc_bcast( myname%childdesc,    mype, comm=m_to_parent_comm )
284    CALL pmc_bcast( myname%nameonchild,  mype, comm=m_to_parent_comm )
285
286    CALL pmc_g_setname( me, myname%couple_index, myname%nameonchild )
287
288 END SUBROUTINE pmc_set_dataarray_name
289
290
291
292 SUBROUTINE pmc_set_dataarray_name_lastentry( lastentry )
293
294    IMPLICIT NONE
295
296    LOGICAL, INTENT(IN), OPTIONAL ::  lastentry  !<
297!
298!-- Local variables
299    INTEGER ::  idum  !<
300    INTEGER ::  mype  !<
301    TYPE(dA_namedef) ::  myname  !<
302
303    myname%couple_index = -1
304
305    IF ( m_model_rank == 0 )  THEN
306       mype = MPI_ROOT
307    ELSE
308       mype = MPI_PROC_NULL
309    ENDIF
310
311    CALL pmc_bcast( myname%couple_index, mype, comm=m_to_parent_comm )
312
313!
314!-- Next statement is just to avoid compiler warnings about unused variables
315    IF ( PRESENT( lastentry ) )  idum = 1
316
317 END SUBROUTINE pmc_set_dataarray_name_lastentry
318
319
320
321 SUBROUTINE pmc_c_get_2d_index_list
322
323    IMPLICIT NONE
324
325    INTEGER(iwp) :: dummy               !<
326    INTEGER(iwp) :: i, ierr, i2, j, nr  !<
327    INTEGER(iwp) :: indwin              !< MPI window object
328    INTEGER(iwp) :: indwin2             !< MPI window object
329
330    INTEGER(KIND=MPI_ADDRESS_KIND) :: win_size !< Size of MPI window 1 (in bytes)
331    INTEGER(KIND=MPI_ADDRESS_KIND) :: disp     !< Displacement unit (Integer = 4, floating poit = 8
332    INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize  !< Size of MPI window 2 (in bytes)
333
334    INTEGER, DIMENSION(me%inter_npes*2) :: nrele  !< Number of Elements of a
335                                                  !< horizontal slice
336    INTEGER, DIMENSION(:), POINTER ::  myind  !<
337
338    TYPE(pedef), POINTER ::  ape  !> Pointer to pedef structure
339
340
341    win_size = STORAGE_SIZE( dummy )/8
342    CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm,   &
343                         indwin, ierr )
344!
345!-- Close window on child side and open on parent side
346    CALL MPI_WIN_FENCE( 0, indwin, ierr )
347
348!   Between the two MPI_WIN_FENCE calls, the parent can fill the RMA window
349
350!-- Close window on parent side and open on child side
351
352    CALL MPI_WIN_FENCE( 0, indwin, ierr )
353
354    DO  i = 1, me%inter_npes
355       disp = me%model_rank * 2
356       CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2,           &
357                     MPI_INTEGER, indwin, ierr )
358    ENDDO
359!
360!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
361!-- called
362    CALL MPI_WIN_FENCE( 0, indwin, ierr )
363!
364!-- Allocate memory for index array
365    winsize = 0
366    DO  i = 1, me%inter_npes
367       ape => me%pes(i)
368       i2 = ( i-1 ) * 2 + 1
369       nr = nrele(i2+1)
370       IF ( nr > 0 )  THEN
371          ALLOCATE( ape%locind(nr) )
372       ELSE
373          NULLIFY( ape%locind )
374       ENDIF
375       winsize = MAX( INT( nr, MPI_ADDRESS_KIND ), winsize )
376    ENDDO
377
378    ALLOCATE( myind(2*winsize) )
379    winsize = 1
380!
381!-- Local buffer used in MPI_GET can but must not be inside the MPI Window.
382!-- Here, we use a dummy for the MPI window because the parent processes do
383!-- not access the RMA window via MPI_GET or MPI_PUT
384    CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm,    &
385                         indwin2, ierr )
386!
387!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
388!-- called
389
390    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
391
392!   Between the two MPI_WIN_FENCE calls, the parent can fill the RMA window
393
394    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
395
396    DO  i = 1, me%inter_npes
397       ape => me%pes(i)
398       nr = nrele(i*2)
399       IF ( nr > 0 )  THEN
400          disp = nrele(2*(i-1)+1)
401          CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , i-1, 0, indwin2, ierr )
402          CALL MPI_GET( myind, 2*nr, MPI_INTEGER, i-1, disp, 2*nr,             &
403                        MPI_INTEGER, indwin2, ierr )
404          CALL MPI_WIN_UNLOCK( i-1, indwin2, ierr )
405          DO  j = 1, nr
406             ape%locind(j)%i = myind(2*j-1)
407             ape%locind(j)%j = myind(2*j)
408          ENDDO
409          ape%nrele = nr
410       ELSE
411          ape%nrele = -1
412       ENDIF
413    ENDDO
414!
415!-- Don't know why, but this barrier is necessary before we can free the windows
416    CALL MPI_BARRIER( me%intra_comm, ierr )
417
418    CALL MPI_WIN_FREE( indWin,  ierr )
419    CALL MPI_WIN_FREE( indwin2, ierr )
420    DEALLOCATE( myind )
421
422 END SUBROUTINE pmc_c_get_2d_index_list
423
424
425
426 SUBROUTINE pmc_c_clear_next_array_list
427
428    IMPLICIT NONE
429
430    next_array_in_list = 0
431
432 END SUBROUTINE pmc_c_clear_next_array_list
433
434
435
436 LOGICAL FUNCTION pmc_c_getnextarray( myname )
437
438!
439!--  List handling is still required to get minimal interaction with
440!--  pmc_interface
441     CHARACTER(LEN=*), INTENT(OUT) ::  myname  !<
442!
443!-- Local variables
444    TYPE(pedef), POINTER    :: ape
445    TYPE(arraydef), POINTER :: ar
446
447
448    next_array_in_list = next_array_in_list + 1
449!
450!-- Array names are the same on all child PEs, so take first process to
451!-- get the name   
452    ape => me%pes(1)
453!
454!-- Check if all arrays have been processed
455    IF ( next_array_in_list > ape%nr_arrays )  THEN
456       pmc_c_getnextarray = .FALSE.
457       RETURN
458    ENDIF
459
460    ar => ape%array_list( next_array_in_list )
461
462    myname = ar%name
463!
464!-- Return true if annother array
465!-- If all array have been processed, the RETURN statement a couple of lines above is active
466
467    pmc_c_getnextarray = .TRUE.
468
469 END FUNCTION pmc_c_getnextarray
470
471
472
473 SUBROUTINE pmc_c_set_dataarray_2d( array )
474
475    IMPLICIT NONE
476
477    REAL(wp), INTENT(IN) , DIMENSION(:,:), POINTER ::  array  !<
478
479    INTEGER(iwp)               ::  i       !<
480    INTEGER(iwp)               ::  nrdims  !<
481    INTEGER(iwp), DIMENSION(4) ::  dims    !<
482
483    TYPE(C_PTR)             ::  array_adr
484    TYPE(arraydef), POINTER ::  ar
485    TYPE(pedef), POINTER    ::  ape
486
487
488    dims    = 1
489    nrdims  = 2
490    dims(1) = SIZE( array, 1 )
491    dims(2) = SIZE( array, 2 )
492
493    array_adr = C_LOC( array )
494
495    DO  i = 1, me%inter_npes
496       ape => me%pes(i)
497       ar  => ape%array_list(next_array_in_list)
498       ar%nrdims = nrdims
499       ar%dimkey = nrdims
500       ar%a_dim  = dims
501       ar%data   = array_adr
502    ENDDO
503
504 END SUBROUTINE pmc_c_set_dataarray_2d
505
506 SUBROUTINE pmc_c_set_dataarray_ip2d( array )
507
508    IMPLICIT NONE
509
510    INTEGER(idp), INTENT(IN) , DIMENSION(:,:), POINTER ::  array  !<
511
512    INTEGER(iwp)               ::  i       !<
513    INTEGER(iwp)               ::  nrdims  !<
514    INTEGER(iwp), DIMENSION(4) ::  dims    !<
515
516    TYPE(C_PTR)             ::  array_adr
517    TYPE(arraydef), POINTER ::  ar
518    TYPE(pedef), POINTER    ::  ape
519
520    dims    = 1
521    nrdims  = 2
522    dims(1) = SIZE( array, 1 )
523    dims(2) = SIZE( array, 2 )
524
525    array_adr = C_LOC( array )
526
527    DO  i = 1, me%inter_npes
528       ape => me%pes(i)
529       ar  => ape%array_list(next_array_in_list)
530       ar%nrdims = nrdims
531       ar%dimkey = 22
532       ar%a_dim  = dims
533       ar%data   = array_adr
534    ENDDO
535
536 END SUBROUTINE pmc_c_set_dataarray_ip2d
537
538 SUBROUTINE pmc_c_set_dataarray_3d (array)
539
540    IMPLICIT NONE
541
542    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER ::  array  !<
543
544    INTEGER(iwp)                ::  i
545    INTEGER(iwp)                ::  nrdims
546    INTEGER(iwp), DIMENSION (4) ::  dims
547   
548    TYPE(C_PTR)             ::  array_adr
549    TYPE(pedef), POINTER    ::  ape
550    TYPE(arraydef), POINTER ::  ar
551
552
553    dims    = 1
554    nrdims  = 3
555    dims(1) = SIZE( array, 1 )
556    dims(2) = SIZE( array, 2 )
557    dims(3) = SIZE( array, 3 )
558
559    array_adr = C_LOC( array )
560
561    DO  i = 1, me%inter_npes
562       ape => me%pes(i)
563       ar  => ape%array_list(next_array_in_list)
564       ar%nrdims = nrdims
565       ar%dimkey = nrdims
566       ar%a_dim  = dims
567       ar%data   = array_adr
568    ENDDO
569
570 END SUBROUTINE pmc_c_set_dataarray_3d
571
572
573
574 SUBROUTINE pmc_c_setind_and_allocmem
575
576    IMPLICIT NONE
577
578!
579!-- Naming convention for appendices:  _pc  -> parent to child transfer
580!--                                    _cp  -> child to parent transfer
581!--                                    recv -> parent to child transfer
582!--                                    send -> child to parent transfer
583    INTEGER(iwp) ::  arlen    !<
584    INTEGER(iwp) ::  myindex  !<
585    INTEGER(iwp) ::  i        !<
586    INTEGER(iwp) ::  ierr     !<
587    INTEGER(iwp) ::  istat    !<
588    INTEGER(iwp) ::  j        !<
589    INTEGER(iwp) ::  rcount   !<
590    INTEGER(iwp) ::  tag      !<
591
592    INTEGER(iwp), PARAMETER ::  noindex = -1  !<
593
594    INTEGER(idp)                   ::  bufsize  !< size of MPI data window
595    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
596
597    INTEGER(iwp),DIMENSION(1024) ::  req  !<
598
599    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_pc  !< base array
600    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_cp  !< base array
601
602    TYPE(pedef), POINTER    ::  ape       !<
603    TYPE(arraydef), POINTER ::  ar        !<
604    Type(C_PTR)             ::  base_ptr  !<
605
606
607    myindex = 0
608    bufsize = 8
609!
610!-- Parent to child direction.
611!-- First stride: compute size and set index
612    DO  i = 1, me%inter_npes
613       ape => me%pes(i)
614       tag = 200
615       DO  j = 1, ape%nr_arrays
616          ar => ape%array_list(j)
617!
618!--       Receive index from child
619          tag = tag + 1
620          CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,     &
621                         MPI_STATUS_IGNORE, ierr )
622          ar%recvindex = myindex
623!
624!--       Determine max, because child buffer is allocated only once
625!--       All 2D and 3d arrays use the same buffer
626
627          IF ( ar%nrdims == 3 )  THEN
628             bufsize = MAX( bufsize,                                           &
629                            INT( ar%a_dim(1)*ar%a_dim(2)*ar%a_dim(3),          &
630                                 MPI_ADDRESS_KIND ) )
631          ELSE
632             bufsize = MAX( bufsize,                                           &
633                            INT( ar%a_dim(1)*ar%a_dim(2), MPI_ADDRESS_KIND ) )
634          ENDIF
635       ENDDO
636    ENDDO
637!
638!-- Create RMA (one sided communication) data buffer.
639!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
640!-- the MPI RMA window
641    CALL pmc_alloc_mem( base_array_pc, bufsize, base_ptr )
642    me%totalbuffersize = bufsize*wp  ! total buffer size in byte
643!
644!-- Second stride: set buffer pointer
645    DO  i = 1, me%inter_npes
646       ape => me%pes(i)
647       DO  j = 1, ape%nr_arrays
648          ar => ape%array_list(j)
649          ar%recvbuf = base_ptr
650       ENDDO
651    ENDDO
652!
653!-- Child to parent direction
654    myindex = 1
655    rcount  = 0
656    bufsize = 8
657
658    DO  i = 1, me%inter_npes
659       ape => me%pes(i)
660       tag = 300
661       DO  j = 1, ape%nr_arrays
662          ar => ape%array_list(j)
663          IF ( ar%nrdims == 2 )  THEN
664             arlen = ape%nrele
665          ELSEIF( ar%nrdims == 3 )  THEN
666             arlen = ape%nrele*ar%a_dim(1)
667          ENDIF
668          tag    = tag + 1
669          rcount = rcount + 1
670          IF ( ape%nrele > 0 )  THEN
671             CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
672                             req(rcount), ierr )
673             ar%sendindex = myindex
674          ELSE
675             CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
676                             req(rcount), ierr )
677             ar%sendindex = noindex
678          ENDIF
679!
680!--       Maximum of 1024 pending requests
681!         1024 is an arbitrary value just to make sure the number of pending
682!         requests is getting too large. It is possible that this value has to
683!         be adjusted in case of running the model on large number of cores.
684
685          IF ( rcount == 1024 )  THEN
686             CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
687             rcount = 0
688          ENDIF
689
690          IF ( ape%nrele > 0 )  THEN
691             ar%sendsize = arlen
692             myindex     = myindex + arlen
693             bufsize     = bufsize + arlen
694          ENDIF
695
696       ENDDO
697
698       IF ( rcount > 0 )  THEN
699          CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
700       ENDIF
701
702    ENDDO
703!
704!-- Create RMA (one sided communication) window for data buffer child to parent
705!-- transfer.
706!-- The buffer of MPI_GET (counter part of transfer) can be PE-local, i.e. it
707!-- can but must not be part of the MPI RMA window. Only one RMA window is
708!-- required to prepare the data
709!--        for parent -> child transfer on the parent side
710!-- and
711!--        for child -> parent transfer on the child side
712    CALL pmc_alloc_mem( base_array_cp, bufsize )
713    me%totalbuffersize = bufsize * wp  ! total buffer size in byte
714
715    winSize = me%totalbuffersize
716
717    CALL MPI_WIN_CREATE( base_array_cp, winsize, wp, MPI_INFO_NULL,            &
718                         me%intra_comm, me%win_parent_child, ierr )
719    CALL MPI_WIN_FENCE( 0, me%win_parent_child, ierr )
720    CALL MPI_BARRIER( me%intra_comm, ierr )
721!
722!-- Second stride: set buffer pointer
723    DO  i = 1, me%inter_npes
724       ape => me%pes(i)
725       DO  j = 1, ape%nr_arrays
726          ar => ape%array_list(j)         
727          IF ( ape%nrele > 0 )  THEN
728             ar%sendbuf = C_LOC( base_array_cp(ar%sendindex) )
729!
730!--          TODO: if this is an error to be really expected, replace the
731!--                following message by a meaningful standard PALM message using
732!--                the message-routine
733             IF ( ar%sendindex+ar%sendsize > bufsize )  THEN
734                WRITE( 0,'(a,i4,4i7,1x,a)') 'Child buffer too small ', i,      &
735                          ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize, &
736                          bufsize, TRIM( ar%name )
737                CALL MPI_ABORT( MPI_COMM_WORLD, istat, ierr )
738             ENDIF
739          ENDIF
740       ENDDO
741    ENDDO
742
743 END SUBROUTINE pmc_c_setind_and_allocmem
744
745
746
747 SUBROUTINE pmc_c_getbuffer( waittime, particle_transfer )
748
749    IMPLICIT NONE
750
751    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
752    LOGICAL, INTENT(IN), OPTIONAL   ::  particle_transfer  !<
753
754    LOGICAL                        ::  lo_ptrans!<
755   
756    INTEGER(iwp)                        ::  ierr    !<
757    INTEGER(iwp)                        ::  ij      !<
758    INTEGER(iwp)                        ::  ip      !<
759    INTEGER(iwp)                        ::  j       !<
760    INTEGER(iwp)                        ::  myindex !<
761    INTEGER(iwp)                        ::  nr      !< number of elements to get
762                                                    !< from parent
763    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp
764    INTEGER,DIMENSION(1)           ::  buf_shape
765
766    REAL(wp)                            ::  t1
767    REAL(wp)                            ::  t2
768
769    REAL(wp), POINTER, DIMENSION(:)     ::  buf
770    REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
771    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
772    TYPE(pedef), POINTER                ::  ape
773    TYPE(arraydef), POINTER             ::  ar
774    INTEGER(idp), POINTER, DIMENSION(:)     ::  ibuf      !<
775    INTEGER(idp), POINTER, DIMENSION(:,:)   ::  idata_2d  !<
776
777!
778!-- Synchronization of the model is done in pmci_synchronize.
779!-- Therefore the RMA window can be filled without
780!-- sychronization at this point and a barrier is not necessary.
781
782!-- In case waittime is present, the following barrier is necessary to
783!-- insure the same number of barrier calls on parent and child
784!-- This means, that here on child side two barriers are call successively
785!-- The parent is filling its buffer between the two barrier calls
786
787!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
788!-- pmc_c_getbuffer
789    IF ( PRESENT( waittime ) )  THEN
790       t1 = pmc_time()
791       CALL MPI_BARRIER( me%intra_comm, ierr )
792       t2 = pmc_time()
793       waittime = t2 - t1
794    ENDIF
795
796    lo_ptrans = .FALSE.
797    IF ( PRESENT( particle_transfer))    lo_ptrans = particle_transfer
798
799!
800!-- Wait for buffer is filled.
801!
802!-- The parent side (in pmc_s_fillbuffer) is filling the buffer in the MPI RMA window
803!-- When the filling is complet, a MPI_BARRIER is called.
804!-- The child is not allowd to access the parent-buffer before it is completely filled
805!-- therefore the following barrier is required.
806
807    CALL MPI_BARRIER( me%intra_comm, ierr )
808
809    DO  ip = 1, me%inter_npes
810       ape => me%pes(ip)
811       DO  j = 1, ape%nr_arrays
812          ar => ape%array_list(j)
813
814          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans)  THEN
815             nr = ape%nrele
816          ELSEIF ( ar%dimkey == 3 .AND. .NOT.lo_ptrans)  THEN
817             nr = ape%nrele * ar%a_dim(1)
818          ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
819             nr = ape%nrele
820          ELSE
821             CYCLE                    ! Particle array ar not transferd here
822          ENDIF
823          buf_shape(1) = nr
824          IF ( lo_ptrans )   THEN
825             CALL C_F_POINTER( ar%recvbuf, ibuf, buf_shape )
826          ELSE
827             CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
828          ENDIF
829!
830!--       MPI passive target RMA
831!--       One data array is fetcht from MPI RMA window on parent
832
833          IF ( nr > 0 )  THEN
834             target_disp = ar%recvindex - 1
835             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0,                     &
836                                me%win_parent_child, ierr )
837             IF ( lo_ptrans )   THEN
838                CALL MPI_GET( ibuf, nr*8, MPI_BYTE, ip-1, target_disp, nr*8, MPI_BYTE,  &               !There is no MPI_INTEGER8 datatype
839                                   me%win_parent_child, ierr )
840             ELSE
841                CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr,        &
842                              MPI_REAL, me%win_parent_child, ierr )
843             ENDIF
844             CALL MPI_WIN_UNLOCK( ip-1, me%win_parent_child, ierr )
845          ENDIF
846          myindex = 1
847          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans)  THEN
848
849             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
850             DO  ij = 1, ape%nrele
851                data_2d(ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex)
852                myindex = myindex + 1
853             ENDDO
854
855          ELSEIF ( ar%dimkey == 3 .AND. .NOT.lo_ptrans)  THEN
856
857             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
858             DO  ij = 1, ape%nrele
859                data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) =                 &
860                                              buf(myindex:myindex+ar%a_dim(1)-1)
861                myindex = myindex+ar%a_dim(1)
862             ENDDO
863
864          ELSEIF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
865             CALL C_F_POINTER( ar%data, idata_2d, ar%a_dim(1:2) )
866
867             DO  ij = 1, ape%nrele
868                idata_2d(ape%locind(ij)%j,ape%locind(ij)%i) = ibuf(myindex)
869                myindex = myindex + 1
870             ENDDO
871
872          ENDIF
873       ENDDO
874    ENDDO
875
876 END SUBROUTINE pmc_c_getbuffer
877
878
879
880 SUBROUTINE pmc_c_putbuffer( waittime , particle_transfer )
881
882    IMPLICIT NONE
883
884    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
885    LOGICAL, INTENT(IN), OPTIONAL   ::  particle_transfer  !<
886
887    LOGICAL ::  lo_ptrans!<
888   
889    INTEGER(iwp) ::  ierr         !<
890    INTEGER(iwp) ::  ij           !<
891    INTEGER(iwp) ::  ip           !<
892    INTEGER(iwp) ::  j            !<
893    INTEGER(iwp) ::  myindex      !<
894
895    INTEGER(iwp), DIMENSION(1) ::  buf_shape    !<
896
897    REAL(wp) ::  t1  !<
898    REAL(wp) ::  t2  !<
899
900    REAL(wp), POINTER, DIMENSION(:)         ::  buf      !<
901    REAL(wp), POINTER, DIMENSION(:,:)       ::  data_2d  !<
902    REAL(wp), POINTER, DIMENSION(:,:,:)     ::  data_3d  !<
903   
904    INTEGER(idp), POINTER, DIMENSION(:)     ::  ibuf      !<
905    INTEGER(idp), POINTER, DIMENSION(:,:)   ::  idata_2d  !<
906
907    TYPE(pedef), POINTER                    ::  ape  !<
908    TYPE(arraydef), POINTER                 ::  ar   !<
909
910!
911!-- Wait for empty buffer
912!-- Switch RMA epoche
913
914    t1 = pmc_time()
915    CALL MPI_BARRIER( me%intra_comm, ierr )
916    t2 = pmc_time()
917    IF ( PRESENT( waittime ) )  waittime = t2 - t1
918
919    lo_ptrans = .FALSE.
920    IF ( PRESENT( particle_transfer))    lo_ptrans = particle_transfer
921
922    DO  ip = 1, me%inter_npes
923       ape => me%pes(ip)
924       DO  j = 1, ape%nr_arrays
925          ar => aPE%array_list(j)
926          myindex = 1
927
928          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans )  THEN
929
930             buf_shape(1) = ape%nrele
931             CALL C_F_POINTER( ar%sendbuf, buf,     buf_shape     )
932             CALL C_F_POINTER( ar%data,    data_2d, ar%a_dim(1:2) )
933             DO  ij = 1, ape%nrele
934                buf(myindex) = data_2d(ape%locind(ij)%j,ape%locind(ij)%i)
935                myindex = myindex + 1
936             ENDDO
937
938          ELSEIF ( ar%dimkey == 3 .AND. .NOT.lo_ptrans )  THEN
939
940             buf_shape(1) = ape%nrele*ar%a_dim(1)
941             CALL C_F_POINTER( ar%sendbuf, buf,     buf_shape     )
942             CALL C_F_POINTER( ar%data,    data_3d, ar%a_dim(1:3) )
943             DO  ij = 1, ape%nrele
944                buf(myindex:myindex+ar%a_dim(1)-1) =                            &
945                                    data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i)
946                myindex = myindex + ar%a_dim(1)
947             ENDDO
948
949          ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
950
951             buf_shape(1) = ape%nrele
952             CALL C_F_POINTER( ar%sendbuf, ibuf,     buf_shape     )
953             CALL C_F_POINTER( ar%data,    idata_2d, ar%a_dim(1:2) )
954
955             DO  ij = 1, ape%nrele
956                ibuf(myindex) = idata_2d(ape%locind(ij)%j,ape%locind(ij)%i)
957                myindex = myindex + 1
958             ENDDO
959
960          ENDIF
961       ENDDO
962    ENDDO
963!
964!-- Buffer is filled
965!-- Switch RMA epoche
966
967    CALL MPI_Barrier(me%intra_comm, ierr)
968
969 END SUBROUTINE pmc_c_putbuffer
970
971#endif
972 END MODULE pmc_child
Note: See TracBrowser for help on using the repository browser.