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

Last change on this file since 3301 was 3251, checked in by raasch, 6 years ago

explicit kind settings

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