Home


About us
PALM
PALM-4U
Installation
Release notes
Documentation
Getting Help
Gallery
Developers area

Ignore:
Timestamp:
Feb 14, 2018 4:01:55 PM (6 years ago)
Author:
thiele
Message:

Introduce particle transfer in nested models

File:
1 edited

Legend:

Unmodified
Added
Removed

  • palm/trunk/SOURCE/pmc_child_mod.f90

    r2718 r2801  
    2626! -----------------
    2727! $Id$
     28! Introduce particle transfer in nested models.
     29!
     30! 2718 2018-01-02 08:49:38Z maronga
    2831! Corrected "Former revisions" section
    2932!
    … …  
    8487!
    8588! Child part of Palm Model Coupler
    86 !-------------------------------------------------------------------------------!
     89!------------------------------------------------------------------------------!
    8790
    8891#if defined( __parallel )
    … …  
    97100
    98101    USE kinds
    99     USE pmc_general,                                                            &
    100         ONLY:  arraydef, childdef, da_desclen, da_namedef, da_namelen, pedef,   &
     102    USE pmc_general,                                                           &
     103        ONLY:  arraydef, childdef, da_desclen, da_namedef, da_namelen, pedef,  &
    101104               pmc_da_name_err,  pmc_g_setname, pmc_max_array, pmc_status_ok
    102105
    103     USE pmc_handle_communicator,                                                &
     106    USE pmc_handle_communicator,                                               &
    104107        ONLY:  m_model_comm, m_model_npes, m_model_rank, m_to_parent_comm
    105108
    106     USE pmc_mpi_wrapper,                                                        &
     109    USE pmc_mpi_wrapper,                                                       &
    107110        ONLY:  pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_time
    108111
    … …  
    112115    SAVE
    113116
    114     TYPE(childdef) ::  me   !<
    115 
    116     INTEGER ::  myindex = 0         !< counter and unique number for data arrays
    117     INTEGER ::  next_array_in_list = 0   !<
     117    TYPE(childdef), PUBLIC ::  me   !<
     118
     119    INTEGER(iwp) ::  myindex = 0         !< counter and unique number for data arrays
     120    INTEGER(iwp) ::  next_array_in_list = 0   !<
    118121
    119122
    … …  
    149152        MODULE PROCEDURE pmc_c_set_dataarray_2d
    150153        MODULE PROCEDURE pmc_c_set_dataarray_3d
     154        MODULE PROCEDURE pmc_c_set_dataarray_ip2d
    151155    END INTERFACE pmc_c_set_dataarray
    152156
    … …  
    157161
    158162
    159     PUBLIC pmc_childinit, pmc_c_clear_next_array_list, pmc_c_getbuffer,         &
    160            pmc_c_getnextarray, pmc_c_putbuffer, pmc_c_setind_and_allocmem,      &
     163    PUBLIC pmc_childinit, pmc_c_clear_next_array_list, pmc_c_getbuffer,        &
     164           pmc_c_getnextarray, pmc_c_putbuffer, pmc_c_setind_and_allocmem,     &
    161165           pmc_c_set_dataarray, pmc_set_dataarray_name, pmc_c_get_2d_index_list
    162166
    … …  
    169173     IMPLICIT NONE
    170174
    171      INTEGER ::  i        !<
    172      INTEGER ::  istat    !<
     175     INTEGER(iwp) ::  i        !<
     176     INTEGER(iwp) ::  istat    !<
    173177
    174178!
    … …  
    197201
    198202
    199  SUBROUTINE pmc_set_dataarray_name( parentarraydesc, parentarrayname,           &
     203 SUBROUTINE pmc_set_dataarray_name( parentarraydesc, parentarrayname,          &
    200204                                    childarraydesc, childarrayname, istat )
    201205
    … …  
    207211    CHARACTER(LEN=*), INTENT(IN) ::  childarraydesc   !<
    208212
    209     INTEGER, INTENT(OUT) ::  istat  !<
     213    INTEGER(iwp), INTENT(OUT) ::  istat  !<
    210214!
    211215!-- Local variables
    212216    TYPE(da_namedef) ::  myname  !<
    213217
    214     INTEGER ::  mype  !<
    215     INTEGER ::  my_addiarray = 0  !<
     218    INTEGER(iwp) ::  mype  !<
     219    INTEGER(iwp) ::  my_addiarray = 0  !<
    216220
    217221
    … …  
    219223!
    220224!-- Check length of array names
    221     IF ( LEN( TRIM( parentarrayname) ) > da_namelen  .OR.                       &
     225    IF ( LEN( TRIM( parentarrayname) ) > da_namelen  .OR.                      &
    222226         LEN( TRIM( childarrayname) ) > da_namelen )  THEN
    223227       istat = pmc_da_name_err
    … …  
    235239!
    236240!-- Broadcast to all child processes
    237 !-- TODO: describe what is broadcast here and why it is done
     241!
     242!-- The complete description of an transfer names array is broadcasted
     243
    238244    CALL pmc_bcast( myname%couple_index, 0, comm=m_model_comm )
    239245    CALL pmc_bcast( myname%parentdesc,   0, comm=m_model_comm )
    … …  
    243249!
    244250!-- Broadcast to all parent processes
    245 !-- TODO: describe what is broadcast here and why it is done
     251!-- The complete description of an transfer array names is broadcasted als to all parent processe
     252!   Only the root PE of the broadcasts to parent using intra communicator
     253
    246254    IF ( m_model_rank == 0 )  THEN
    247255        mype = MPI_ROOT
    … …  
    290298    IMPLICIT NONE
    291299
    292     INTEGER :: dummy               !<
    293     INTEGER :: i, ierr, i2, j, nr  !<
    294     INTEGER :: indwin              !< MPI window object
    295     INTEGER :: indwin2             !< MPI window object
     300    INTEGER(iwp) :: dummy               !<
     301    INTEGER(iwp) :: i, ierr, i2, j, nr  !<
     302    INTEGER(iwp) :: indwin              !< MPI window object
     303    INTEGER(iwp) :: indwin2             !< MPI window object
    296304
    297305    INTEGER(KIND=MPI_ADDRESS_KIND) :: win_size !< Size of MPI window 1 (in bytes)
    … …  
    307315
    308316    win_size = C_SIZEOF( dummy )
    309     CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm,    &
     317    CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm,   &
    310318                         indwin, ierr )
    311319!
    312 !-- Open window on parent side
    313 !-- TODO: why is the next MPI routine called twice??
     320!-- Close window on child side and open on parent side
    314321    CALL MPI_WIN_FENCE( 0, indwin, ierr )
    315 !
     322
     323!   Between the two MPI_WIN_FENCE calls, the parent can fill the RMA window
     324
    316325!-- Close window on parent side and open on child side
     326
    317327    CALL MPI_WIN_FENCE( 0, indwin, ierr )
    318328
    319329    DO  i = 1, me%inter_npes
    320330       disp = me%model_rank * 2
    321        CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2,            &
     331       CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2,           &
    322332                     MPI_INTEGER, indwin, ierr )
    323333    ENDDO
    … …  
    347357!-- Here, we use a dummy for the MPI window because the parent processes do
    348358!-- not access the RMA window via MPI_GET or MPI_PUT
    349     CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm,     &
     359    CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm,    &
    350360                         indwin2, ierr )
    351361!
    352362!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
    353363!-- called
    354 !-- TODO: as before: why is this called twice??
     364
    355365    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
     366
     367!   Between the two MPI_WIN_FENCE calls, the parent can fill the RMA window
     368
    356369    CALL MPI_WIN_FENCE( 0, indwin2, ierr )
    357370
    … …  
    362375          disp = nrele(2*(i-1)+1)
    363376          CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , i-1, 0, indwin2, ierr )
    364           CALL MPI_GET( myind, 2*nr, MPI_INTEGER, i-1, disp, 2*nr,              &
     377          CALL MPI_GET( myind, 2*nr, MPI_INTEGER, i-1, disp, 2*nr,             &
    365378                        MPI_INTEGER, indwin2, ierr )
    366379          CALL MPI_WIN_UNLOCK( i-1, indwin2, ierr )
    … …  
    424437    myname = ar%name
    425438!
    426 !-- Return true if legal array
    427 !-- TODO: the case of a non-legal array does not seem to appear, so why is this
    428 !-- setting required at all?
     439!-- Return true if annother array
     440!-- If all array have been processed, the RETURN statement a couple of lines above is active
     441
    429442    pmc_c_getnextarray = .TRUE.
    430443
    431  END function pmc_c_getnextarray
     444 END FUNCTION pmc_c_getnextarray
    432445
    433446
    … …  
    439452    REAL(wp), INTENT(IN) , DIMENSION(:,:), POINTER ::  array  !<
    440453
    441     INTEGER                 ::  i       !<
    442     INTEGER                 ::  nrdims  !<
    443     INTEGER, DIMENSION(4)  ::  dims    !<
     454    INTEGER(iwp)               ::  i       !<
     455    INTEGER(iwp)               ::  nrdims  !<
     456    INTEGER(iwp), DIMENSION(4) ::  dims    !<
    444457
    445458    TYPE(C_PTR)             ::  array_adr
    … …  
    459472       ar  => ape%array_list(next_array_in_list)
    460473       ar%nrdims = nrdims
     474       ar%dimkey = nrdims
    461475       ar%a_dim  = dims
    462476       ar%data   = array_adr
    … …  
    465479 END SUBROUTINE pmc_c_set_dataarray_2d
    466480
    467 
     481 SUBROUTINE pmc_c_set_dataarray_ip2d( array )
     482
     483    IMPLICIT NONE
     484
     485    INTEGER(idp), INTENT(IN) , DIMENSION(:,:), POINTER ::  array  !<
     486
     487    INTEGER(iwp)               ::  i       !<
     488    INTEGER(iwp)               ::  nrdims  !<
     489    INTEGER(iwp), DIMENSION(4) ::  dims    !<
     490
     491    TYPE(C_PTR)             ::  array_adr
     492    TYPE(arraydef), POINTER ::  ar
     493    TYPE(pedef), POINTER    ::  ape
     494
     495    dims    = 1
     496    nrdims  = 2
     497    dims(1) = SIZE( array, 1 )
     498    dims(2) = SIZE( array, 2 )
     499
     500    array_adr = C_LOC( array )
     501
     502    DO  i = 1, me%inter_npes
     503       ape => me%pes(i)
     504       ar  => ape%array_list(next_array_in_list)
     505       ar%nrdims = nrdims
     506       ar%dimkey = 22
     507       ar%a_dim  = dims
     508       ar%data   = array_adr
     509    ENDDO
     510
     511 END SUBROUTINE pmc_c_set_dataarray_ip2d
    468512
    469513 SUBROUTINE pmc_c_set_dataarray_3d (array)
    … …  
    473517    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER ::  array  !<
    474518
    475     INTEGER                 ::  i
    476     INTEGER                 ::  nrdims
    477     INTEGER, DIMENSION (4)  ::  dims
     519    INTEGER(iwp)                ::  i
     520    INTEGER(iwp)                ::  nrdims
     521    INTEGER(iwp), DIMENSION (4) ::  dims
     522   
    478523    TYPE(C_PTR)             ::  array_adr
    479524    TYPE(pedef), POINTER    ::  ape
    … …  
    493538       ar  => ape%array_list(next_array_in_list)
    494539       ar%nrdims = nrdims
     540       ar%dimkey = nrdims
    495541       ar%a_dim  = dims
    496542       ar%data   = array_adr
    … …  
    512558    CHARACTER(LEN=da_namelen) ::  myname  !<
    513559
    514     INTEGER ::  arlen    !<
    515     INTEGER ::  myindex  !<
    516     INTEGER ::  i        !<
    517     INTEGER ::  ierr     !<
    518     INTEGER ::  istat    !<
    519     INTEGER ::  j        !<
    520     INTEGER ::  rcount   !<
    521     INTEGER ::  tag      !<
    522 
    523     INTEGER, PARAMETER ::  noindex = -1  !<
     560    INTEGER(iwp) ::  arlen    !<
     561    INTEGER(iwp) ::  myindex  !<
     562    INTEGER(iwp) ::  i        !<
     563    INTEGER(iwp) ::  ierr     !<
     564    INTEGER(iwp) ::  istat    !<
     565    INTEGER(iwp) ::  j        !<
     566    INTEGER(iwp) ::  rcount   !<
     567    INTEGER(iwp) ::  tag      !<
     568
     569    INTEGER(iwp), PARAMETER ::  noindex = -1  !<
    524570
    525571    INTEGER(idp)                   ::  bufsize  !< size of MPI data window
    526572    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
    527573
    528     INTEGER,DIMENSION(1024) ::  req  !<
     574    INTEGER(iwp),DIMENSION(1024) ::  req  !<
    529575
    530576    REAL(wp), DIMENSION(:), POINTER, SAVE ::  base_array_pc  !< base array
    … …  
    549595!--       Receive index from child
    550596          tag = tag + 1
    551           CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,      &
     597          CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,     &
    552598                         MPI_STATUS_IGNORE, ierr )
    553599          ar%recvindex = myindex
    554600!
    555601!--       Determine max, because child buffer is allocated only once
    556 !--       TODO: give a more meaningful comment
    557           IF( ar%nrdims == 3 )  THEN
     602!--       All 2D and 3d arrays use the same buffer
     603
     604          IF ( ar%nrdims == 3 )  THEN
    558605             bufsize = MAX( bufsize, ar%a_dim(1)*ar%a_dim(2)*ar%a_dim(3) )
    559606          ELSE
    … …  
    588635       DO  j = 1, ape%nr_arrays
    589636          ar => ape%array_list(j)
    590           IF( ar%nrdims == 2 )  THEN
     637          IF ( ar%nrdims == 2 )  THEN
    591638             arlen = ape%nrele
    592639          ELSEIF( ar%nrdims == 3 )  THEN
    … …  
    596643          rcount = rcount + 1
    597644          IF ( ape%nrele > 0 )  THEN
    598              CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,  &
     645             CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
    599646                             req(rcount), ierr )
    600647             ar%sendindex = myindex
    601648          ELSE
    602              CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm,  &
     649             CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
    603650                             req(rcount), ierr )
    604651             ar%sendindex = noindex
    605652          ENDIF
    606653!
    607 !--       Maximum of 1024 outstanding requests
    608 !--       TODO: explain where this maximum comes from (arbitrary?).
    609 !--       Outstanding = pending?
     654!--       Maximum of 1024 pending requests
     655!         1024 is an arbitrary value just to make sure the number of pending
     656!         requests is getting too large. It is possible that this value has to
     657!         be adjusted in case of running the model on large number of cores.
     658
    610659          IF ( rcount == 1024 )  THEN
    611660             CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
    … …  
    640689    winSize = me%totalbuffersize
    641690
    642     CALL MPI_WIN_CREATE( base_array_cp, winsize, wp, MPI_INFO_NULL,             &
     691    CALL MPI_WIN_CREATE( base_array_cp, winsize, wp, MPI_INFO_NULL,            &
    643692                         me%intra_comm, me%win_parent_child, ierr )
    644693    CALL MPI_WIN_FENCE( 0, me%win_parent_child, ierr )
    … …  
    657706!--                the message-routine
    658707             IF ( ar%sendindex+ar%sendsize > bufsize )  THEN
    659                 WRITE( 0,'(a,i4,4i7,1x,a)') 'Child buffer too small ', i,       &
    660                           ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize,  &
     708                WRITE( 0,'(a,i4,4i7,1x,a)') 'Child buffer too small ', i,      &
     709                          ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize, &
    661710                          bufsize, TRIM( ar%name )
    662711                CALL MPI_ABORT( MPI_COMM_WORLD, istat, ierr )
    … …  
    670719
    671720
    672  SUBROUTINE pmc_c_getbuffer( waittime )
     721 SUBROUTINE pmc_c_getbuffer( waittime, particle_transfer )
    673722
    674723    IMPLICIT NONE
    675724
    676725    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
     726    LOGICAL, INTENT(IN), OPTIONAL   ::  particle_transfer  !<
    677727
    678728    CHARACTER(LEN=da_namelen) ::  myname  !<
    679 
    680     INTEGER                        ::  ierr     !<
    681     INTEGER                        ::  ij       !<
    682     INTEGER                        ::  ip       !<
    683     INTEGER                        ::  j        !<
    684     INTEGER                        ::  myindex  !<
    685     INTEGER                        ::  nr       !< number of elements to get
    686                                                 !< from parent
     729   
     730    LOGICAL                        ::  lo_ptrans!<
     731   
     732    INTEGER(iwp)                        ::  ierr    !<
     733    INTEGER(iwp)                        ::  ij      !<
     734    INTEGER(iwp)                        ::  ip      !<
     735    INTEGER(iwp)                        ::  j       !<
     736    INTEGER(iwp)                        ::  myindex !<
     737    INTEGER(iwp)                        ::  nr      !< number of elements to get
     738                                                    !< from parent
    687739    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp
    688740    INTEGER,DIMENSION(1)           ::  buf_shape
    … …  
    696748    TYPE(pedef), POINTER                ::  ape
    697749    TYPE(arraydef), POINTER             ::  ar
     750    INTEGER(idp), POINTER, DIMENSION(:)     ::  ibuf      !<
     751    INTEGER(idp), POINTER, DIMENSION(:,:)   ::  idata_2d  !<
    698752
    699753!
    … …  
    701755!-- Therefore the RMA window can be filled without
    702756!-- sychronization at this point and a barrier is not necessary.
     757
     758!-- In case waittime is present, the following barrier is necessary to
     759!-- insure the same number of barrier calls on parent and child
     760!-- This means, that here on child side two barriers are call successively
     761!-- The parent is filling its buffer between the two barrier calls
     762
    703763!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
    704764!-- pmc_c_getbuffer
    … …  
    709769       waittime = t2 - t1
    710770    ENDIF
     771
     772    lo_ptrans = .FALSE.
     773    IF ( PRESENT( particle_transfer))    lo_ptrans = particle_transfer
     774
    711775!
    712776!-- Wait for buffer is filled.
    713 !-- TODO: explain in more detail what is happening here. The barrier seems to
    714 !-- contradict what is said a few lines before (i.e. that no barrier is necessary)
    715 !-- TODO: In case of PRESENT( waittime ) the barrrier would be calles twice. Why?
    716 !-- Shouldn't it be done the same way as in pmc_putbuffer?
     777!
     778!-- The parent side (in pmc_s_fillbuffer) is filling the buffer in the MPI RMA window
     779!-- When the filling is complet, a MPI_BARRIER is called.
     780!-- The child is not allowd to access the parent-buffer before it is completely filled
     781!-- therefore the following barrier is required.
     782
    717783    CALL MPI_BARRIER( me%intra_comm, ierr )
    718784
    … …  
    721787       DO  j = 1, ape%nr_arrays
    722788          ar => ape%array_list(j)
    723           IF ( ar%nrdims == 2 )  THEN
     789
     790          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans)  THEN
    724791             nr = ape%nrele
    725           ELSEIF ( ar%nrdims == 3 )  THEN
     792          ELSEIF ( ar%dimkey == 3 .AND. .NOT.lo_ptrans)  THEN
    726793             nr = ape%nrele * ar%a_dim(1)
     794          ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
     795             nr = ape%nrele
     796          ELSE
     797             CYCLE                    ! Particle array ar not transferd here
    727798          ENDIF
    728799          buf_shape(1) = nr
    729           CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
     800          IF ( lo_ptrans )   THEN
     801             CALL C_F_POINTER( ar%recvbuf, ibuf, buf_shape )
     802          ELSE
     803             CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
     804          ENDIF
    730805!
    731806!--       MPI passive target RMA
    732 !--       TODO: explain the above comment
     807!--       One data array is fetcht from MPI RMA window on parent
     808
    733809          IF ( nr > 0 )  THEN
    734810             target_disp = ar%recvindex - 1
    735              CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0,                      &
     811             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0,                     &
    736812                                me%win_parent_child, ierr )
    737              CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL,  &
    738                                 me%win_parent_child, ierr )
     813             IF ( lo_ptrans )   THEN
     814                CALL MPI_GET( ibuf, nr*8, MPI_BYTE, ip-1, target_disp, nr*8, MPI_BYTE,  &               !There is no MPI_INTEGER8 datatype
     815                                   me%win_parent_child, ierr )
     816             ELSE
     817                CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr,        &
     818                              MPI_REAL, me%win_parent_child, ierr )
     819             ENDIF
    739820             CALL MPI_WIN_UNLOCK( ip-1, me%win_parent_child, ierr )
    740821          ENDIF
    741822          myindex = 1
    742           IF ( ar%nrdims == 2 )  THEN
     823          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans)  THEN
     824
    743825             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
    744826             DO  ij = 1, ape%nrele
    … …  
    746828                myindex = myindex + 1
    747829             ENDDO
    748           ELSEIF ( ar%nrdims == 3 )  THEN
     830
     831          ELSEIF ( ar%dimkey == 3 .AND. .NOT.lo_ptrans)  THEN
     832
    749833             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
    750834             DO  ij = 1, ape%nrele
    751                 data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) =                  &
     835                data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) =                 &
    752836                                              buf(myindex:myindex+ar%a_dim(1)-1)
    753837                myindex = myindex+ar%a_dim(1)
    754838             ENDDO
     839
     840          ELSEIF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
     841             CALL C_F_POINTER( ar%data, idata_2d, ar%a_dim(1:2) )
     842
     843             DO  ij = 1, ape%nrele
     844                idata_2d(ape%locind(ij)%j,ape%locind(ij)%i) = ibuf(myindex)
     845                myindex = myindex + 1
     846             ENDDO
     847
    755848          ENDIF
    756849       ENDDO
    … …  
    761854
    762855
    763  SUBROUTINE pmc_c_putbuffer( waittime )
     856 SUBROUTINE pmc_c_putbuffer( waittime , particle_transfer )
    764857
    765858    IMPLICIT NONE
    766859
    767860    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
     861    LOGICAL, INTENT(IN), OPTIONAL   ::  particle_transfer  !<
    768862
    769863    CHARACTER(LEN=da_namelen) ::  myname  !<
    770 
    771     INTEGER                        ::  ierr         !<
    772     INTEGER                        ::  ij           !<
    773     INTEGER                        ::  ip           !<
    774     INTEGER                        ::  j            !<
    775     INTEGER                        ::  myindex      !<
    776     INTEGER                        ::  nr           !< number of elements to get
    777                                                     !< from parent
     864   
     865    LOGICAL ::  lo_ptrans!<
     866   
     867    INTEGER(iwp) ::  ierr         !<
     868    INTEGER(iwp) ::  ij           !<
     869    INTEGER(iwp) ::  ip           !<
     870    INTEGER(iwp) ::  j            !<
     871    INTEGER(iwp) ::  myindex      !<
     872    INTEGER(iwp) ::  nr           !< number of elements to get from parent
     873   
    778874    INTEGER(KIND=MPI_ADDRESS_KIND) ::  target_disp  !<
    779 
    780     INTEGER, DIMENSION(1)          ::  buf_shape    !<
     875   
     876
     877    INTEGER(iwp), DIMENSION(1) ::  buf_shape    !<
    781878
    782879    REAL(wp) ::  t1  !<
    783880    REAL(wp) ::  t2  !<
    784881
    785     REAL(wp), POINTER, DIMENSION(:)     ::  buf      !<
    786     REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d  !<
    787     REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d  !<
    788 
    789     TYPE(pedef), POINTER               ::  ape  !<
    790     TYPE(arraydef), POINTER            ::  ar   !<
     882    REAL(wp), POINTER, DIMENSION(:)         ::  buf      !<
     883    REAL(wp), POINTER, DIMENSION(:,:)       ::  data_2d  !<
     884    REAL(wp), POINTER, DIMENSION(:,:,:)     ::  data_3d  !<
     885   
     886    INTEGER(idp), POINTER, DIMENSION(:)     ::  ibuf      !<
     887    INTEGER(idp), POINTER, DIMENSION(:,:)   ::  idata_2d  !<
     888
     889    TYPE(pedef), POINTER                    ::  ape  !<
     890    TYPE(arraydef), POINTER                 ::  ar   !<
    791891
    792892!
    793893!-- Wait for empty buffer
    794 !-- TODO: explain what is done here
     894!-- Switch RMA epoche
     895
    795896    t1 = pmc_time()
    796897    CALL MPI_BARRIER( me%intra_comm, ierr )
    797898    t2 = pmc_time()
    798899    IF ( PRESENT( waittime ) )  waittime = t2 - t1
     900
     901    lo_ptrans = .FALSE.
     902    IF ( PRESENT( particle_transfer))    lo_ptrans = particle_transfer
    799903
    800904    DO  ip = 1, me%inter_npes
    … …  
    803907          ar => aPE%array_list(j)
    804908          myindex = 1
    805           IF ( ar%nrdims == 2 )  THEN
     909
     910          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans )  THEN
     911
    806912             buf_shape(1) = ape%nrele
    807913             CALL C_F_POINTER( ar%sendbuf, buf,     buf_shape     )
    … …  
    811917                myindex = myindex + 1
    812918             ENDDO
    813           ELSEIF ( ar%nrdims == 3 )  THEN
     919
     920          ELSEIF ( ar%dimkey == 3 .AND. .NOT.lo_ptrans )  THEN
     921
    814922             buf_shape(1) = ape%nrele*ar%a_dim(1)
    815923             CALL C_F_POINTER( ar%sendbuf, buf,     buf_shape     )
    … …  
    820928                myindex = myindex + ar%a_dim(1)
    821929             ENDDO
     930
     931          ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
     932
     933             buf_shape(1) = ape%nrele
     934             CALL C_F_POINTER( ar%sendbuf, ibuf,     buf_shape     )
     935             CALL C_F_POINTER( ar%data,    idata_2d, ar%a_dim(1:2) )
     936
     937             DO  ij = 1, ape%nrele
     938                ibuf(myindex) = idata_2d(ape%locind(ij)%j,ape%locind(ij)%i)
     939                myindex = myindex + 1
     940             ENDDO
     941
    822942          ENDIF
    823943       ENDDO
    824944    ENDDO
    825945!
    826 !-- TODO: Fence might do it, test later
    827 !-- Call MPI_WIN_FENCE( 0, me%win_parent_child, ierr)      !
    828 !
    829946!-- Buffer is filled
    830 !-- TODO: explain in more detail what is happening here
     947!-- Switch RMA epoche
     948
    831949    CALL MPI_Barrier(me%intra_comm, ierr)
    832950
Note: See TracChangeset for help on using the changeset viewer.
                                                                                                                                                                                                                                                                                                                                                                               
  | Impressum | ©Leibniz Universität Hannover |