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_parent_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!
    … …  
    8891!
    8992! Parent part of Palm Model Coupler
    90 !-------------------------------------------------------------------------------!
     93!------------------------------------------------------------------------------!
    9194
    9295#if defined( __parallel )
    … …  
    99102#endif
    100103    USE kinds
    101     USE pmc_general,                                                            &
    102         ONLY: arraydef, childdef, da_namedef, da_namelen, pedef,                &
     104    USE pmc_general,                                                           &
     105        ONLY: arraydef, childdef, da_namedef, da_namelen, pedef,               &
    103106              pmc_g_setname, pmc_max_array, pmc_max_models, pmc_sort
    104107
    105     USE pmc_handle_communicator,                                                &
    106         ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_child_comm,          &
     108    USE pmc_handle_communicator,                                               &
     109        ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_child_comm,         &
    107110              m_world_rank, pmc_parent_for_child
    108111
    109     USE pmc_mpi_wrapper,                                                        &
     112    USE pmc_mpi_wrapper,                                                       &
    110113        ONLY: pmc_alloc_mem, pmc_bcast, pmc_time
    111114
    … …  
    120123   END TYPE childindexdef
    121124
    122    TYPE(childdef), DIMENSION(pmc_max_models)       ::  children     !<
    123    TYPE(childindexdef), DIMENSION(pmc_max_models)  ::  indchildren  !<
     125   TYPE(childdef), DIMENSION(pmc_max_models),PUBLIC   ::  children     !<
     126   TYPE(childindexdef), DIMENSION(pmc_max_models)     ::  indchildren  !<
    124127
    125128   INTEGER ::  next_array_in_list = 0  !<
    … …  
    148151        MODULE PROCEDURE pmc_s_set_dataarray_2d
    149152        MODULE PROCEDURE pmc_s_set_dataarray_3d
     153        MODULE PROCEDURE pmc_s_set_dataarray_ip2d
    150154    END INTERFACE pmc_s_set_dataarray
    151155
    … …  
    166170    END INTERFACE pmc_s_set_active_data_array
    167171
    168     PUBLIC pmc_parentinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer,       &
    169            pmc_s_getdata_from_buffer, pmc_s_getnextarray,                       &
    170            pmc_s_setind_and_allocmem, pmc_s_set_active_data_array,              &
    171            pmc_s_set_dataarray, pmc_s_set_2d_index_list
     172    INTERFACE pmc_s_get_child_npes
     173        MODULE PROCEDURE pmc_s_get_child_npes
     174    END INTERFACE pmc_s_get_child_npes
     175
     176    PUBLIC pmc_parentinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer,      &
     177           pmc_s_getdata_from_buffer, pmc_s_getnextarray,                      &
     178           pmc_s_setind_and_allocmem, pmc_s_set_active_data_array,             &
     179           pmc_s_set_dataarray, pmc_s_set_2d_index_list,                       &
     180           pmc_s_get_child_npes
    172181
    173182 CONTAINS
    … …  
    178187    IMPLICIT NONE
    179188
    180     INTEGER ::  childid   !<
    181     INTEGER ::  i         !<
    182     INTEGER ::  j         !<
    183     INTEGER ::  istat     !<
     189    INTEGER(iwp) ::  childid   !<
     190    INTEGER(iwp) ::  i         !<
     191    INTEGER(iwp) ::  j         !<
     192    INTEGER(iwp) ::  istat     !<
    184193
    185194
    … …  
    193202!
    194203!--    Get rank and size
    195        CALL MPI_COMM_RANK( children(childid)%model_comm,                        &
     204       CALL MPI_COMM_RANK( children(childid)%model_comm,                       &
    196205                           children(childid)%model_rank, istat )
    197        CALL MPI_COMM_SIZE( children(childid)%model_comm,                        &
     206       CALL MPI_COMM_SIZE( children(childid)%model_comm,                       &
    198207                           children(childid)%model_npes, istat )
    199        CALL MPI_COMM_REMOTE_SIZE( children(childid)%inter_comm,                 &
     208       CALL MPI_COMM_REMOTE_SIZE( children(childid)%inter_comm,                &
    200209                                  children(childid)%inter_npes, istat )
    201210
    202211!
    203212!--    Intra communicator is used for MPI_GET
    204        CALL MPI_INTERCOMM_MERGE( children(childid)%inter_comm, .FALSE.,         &
     213       CALL MPI_INTERCOMM_MERGE( children(childid)%inter_comm, .FALSE.,        &
    205214                                 children(childid)%intra_comm, istat )
    206        CALL MPI_COMM_RANK( children(childid)%intra_comm,                        &
     215       CALL MPI_COMM_RANK( children(childid)%intra_comm,                       &
    207216                           children(childid)%intra_rank, istat )
    208217
    … …  
    228237     IMPLICIT NONE
    229238
    230      INTEGER, INTENT(IN)                    :: childid     !<
    231      INTEGER, DIMENSION(:,:), INTENT(INOUT) :: index_list  !<
    232 
    233      INTEGER ::  ian    !<
    234      INTEGER ::  ic     !<
    235      INTEGER ::  ie     !<
    236      INTEGER ::  ip     !<
    237      INTEGER ::  is     !<
    238      INTEGER ::  istat  !<
    239      INTEGER ::  n      !<
     239     INTEGER(iwp), INTENT(IN)                    :: childid     !<
     240     INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: index_list  !<
     241
     242     INTEGER(iwp) ::  ian    !<
     243     INTEGER(iwp) ::  ic     !<
     244     INTEGER(iwp) ::  ie     !<
     245     INTEGER(iwp) ::  ip     !<
     246     INTEGER(iwp) ::  is     !<
     247     INTEGER(iwp) ::  istat  !<
     248     INTEGER(iwp) ::  n,i    !<
    240249
    241250
    … …  
    268277              IF ( ian > 0)  THEN
    269278                  ALLOCATE( indchildren(childid)%index_list_2d(6,ian) )
    270                   indchildren(childid)%index_list_2d(:,1:ian) =                 &
     279                  indchildren(childid)%index_list_2d(:,1:ian) =                &
    271280                                                             index_list(:,is:ie)
    272281              ENDIF
    273282           ELSE
    274               CALL MPI_SEND( ian, 1, MPI_INTEGER, ip, 1000, m_model_comm,       &
     283              CALL MPI_SEND( ian, 1, MPI_INTEGER, ip, 1000, m_model_comm,      &
    275284                             istat )
    276285              IF ( ian > 0)  THEN
    277                   CALL MPI_SEND( index_list(1,is), 6*ian, MPI_INTEGER, ip,      &
     286                  CALL MPI_SEND( index_list(1,is), 6*ian, MPI_INTEGER, ip,     &
    278287                                 1001, m_model_comm, istat )
    279288              ENDIF
    … …  
    282291        ENDDO
    283292     ELSE
    284         CALL MPI_RECV( indchildren(childid)%nrpoints, 1, MPI_INTEGER, 0, 1000,  &
     293        CALL MPI_RECV( indchildren(childid)%nrpoints, 1, MPI_INTEGER, 0, 1000, &
    285294                       m_model_comm, MPI_STATUS_IGNORE, istat )
    286295        ian = indchildren(childid)%nrpoints
    287296        IF ( ian > 0 )  THEN
    288297           ALLOCATE( indchildren(childid)%index_list_2d(6,ian) )
    289            CALL MPI_RECV( indchildren(childid)%index_list_2d, 6*ian,            &
    290                           MPI_INTEGER, 0, 1001, m_model_comm,                   &
     298           CALL MPI_RECV( indchildren(childid)%index_list_2d, 6*ian,           &
     299                          MPI_INTEGER, 0, 1001, m_model_comm,                  &
    291300                          MPI_STATUS_IGNORE, istat)
    292301        ENDIF
    293302     ENDIF
    294      CALL set_pe_index_list( childid, children(childid),                        &
    295                              indchildren(childid)%index_list_2d,                &
     303     CALL set_pe_index_list( childid, children(childid),                       &
     304                             indchildren(childid)%index_list_2d,               &
    296305                             indchildren(childid)%nrpoints )
    297306
    … …  
    313322
    314323!
    315 !-- List handling is still required to get minimal interaction with
    316 !-- pmc_interface
    317 !-- TODO: what does "still" mean? Is there a chance to change this!
     324!-- Althoug there are no linked lists any more in PMC, this call still looks like working with a list
     325
    318326    CHARACTER(LEN=*), INTENT(OUT) ::  myname    !<
    319327    INTEGER(iwp), INTENT(IN)      ::  childid   !<
    … …  
    338346    myname = ar%name
    339347!
    340 !-- Return true if legal array
    341 !-- TODO: what does this comment mean? Can there be non-legal arrays??
     348!-- Return true if there is still an array in the list
     349
    342350    pmc_s_getnextarray = .TRUE.
    343351
    … …  
    350358    IMPLICIT NONE
    351359
    352     INTEGER,INTENT(IN) ::  childid   !<
     360    INTEGER(iwp), INTENT(IN) ::  childid   !<
    353361
    354362    REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER           ::  array    !<
    355363    REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER, OPTIONAL ::  array_2  !<
    356364
    357     INTEGER               ::  nrdims      !<
    358     INTEGER, DIMENSION(4) ::  dims        !<
     365    INTEGER(iwp)               ::  nrdims      !<
     366    INTEGER(iwp), DIMENSION(4) ::  dims        !<
    359367    TYPE(C_PTR)           ::  array_adr   !<
    360368    TYPE(C_PTR)           ::  second_adr  !<
    … …  
    369377    IF ( PRESENT( array_2 ) )  THEN
    370378       second_adr = C_LOC(array_2)
    371        CALL pmc_s_setarray( childid, nrdims, dims, array_adr,                   &
     379       CALL pmc_s_setarray( childid, nrdims, dims, array_adr,                  &
    372380                            second_adr = second_adr)
    373381    ELSE
    … …  
    377385 END SUBROUTINE pmc_s_set_dataarray_2d
    378386
     387 SUBROUTINE pmc_s_set_dataarray_ip2d( childid, array )
     388
     389    IMPLICIT NONE
     390
     391    INTEGER(iwp),INTENT(IN) ::  childid   !<
     392
     393    INTEGER(idp), INTENT(IN), DIMENSION(:,:), POINTER           ::  array    !<
     394
     395    INTEGER(iwp)               ::  nrdims      !<
     396    INTEGER(iwp), DIMENSION(4) ::  dims        !<
     397    TYPE(C_PTR)           ::  array_adr   !<
     398
     399
     400    dims      = 1
     401    nrdims    = 2
     402    dims(1)   = SIZE( array,1 )
     403    dims(2)   = SIZE( array,2 )
     404    array_adr = C_LOC( array )
     405
     406    CALL pmc_s_setarray( childid, nrdims, dims, array_adr , dimkey=22)
     407
     408 END SUBROUTINE pmc_s_set_dataarray_ip2d
    379409
    380410
    … …  
    383413    IMPLICIT NONE
    384414
    385     INTEGER, INTENT(IN) ::  childid   !<
    386     INTEGER, INTENT(IN) ::  nz        !<
    387     INTEGER, INTENT(IN) ::  nz_cl     !<
     415    INTEGER(iwp), INTENT(IN) ::  childid   !<
     416    INTEGER(iwp), INTENT(IN) ::  nz        !<
     417    INTEGER(iwp), INTENT(IN) ::  nz_cl     !<
    388418
    389419    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER           ::  array    !<
    390420    REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER, OPTIONAL ::  array_2  !<
    391421
    392     INTEGER               ::  nrdims      !<
    393     INTEGER, DIMENSION(4) ::  dims        !<
     422    INTEGER(iwp)               ::  nrdims      !<
     423    INTEGER(iwp), DIMENSION(4) ::  dims        !<
    394424    TYPE(C_PTR)           ::  array_adr   !<
    395425    TYPE(C_PTR)           ::  second_adr  !<
    396426
    397 !
    398 !-- TODO: the next assignment seems to be obsolete. Please check!
    399     dims      = 1
    400     dims      = 0
    401427    nrdims    = 3
    402428    dims(1)   = SIZE( array,1 )
    … …  
    411437    IF ( PRESENT( array_2 ) )  THEN
    412438      second_adr = C_LOC( array_2 )
    413       CALL pmc_s_setarray( childid, nrdims, dims, array_adr,                    &
     439      CALL pmc_s_setarray( childid, nrdims, dims, array_adr,                   &
    414440                           second_adr = second_adr)
    415441    ELSE
    … …  
    423449 SUBROUTINE pmc_s_setind_and_allocmem( childid )
    424450
    425     USE control_parameters,                                                     &
     451    USE control_parameters,                                                    &
    426452        ONLY:  message_string
    427453
    … …  
    433459!--                                     send -> parent to child transfer
    434460!--                                     recv -> child to parent transfer
    435     INTEGER, INTENT(IN) ::  childid   !<
    436 
    437     INTEGER                        ::  arlen    !<
    438     INTEGER                        ::  i        !<
    439     INTEGER                        ::  ierr     !<
    440     INTEGER                        ::  istat    !<
    441     INTEGER                        ::  j        !<
    442     INTEGER                        ::  myindex  !<
    443     INTEGER                        ::  rcount   !< count MPI requests
    444     INTEGER                        ::  tag      !<
     461    INTEGER(iwp), INTENT(IN) ::  childid   !<
     462
     463    INTEGER(iwp)                   ::  arlen    !<
     464    INTEGER(iwp)                   ::  i        !<
     465    INTEGER(iwp)                   ::  ierr     !<
     466    INTEGER(iwp)                   ::  istat    !<
     467    INTEGER(iwp)                   ::  j        !<
     468    INTEGER(iwp)                   ::  myindex  !<
     469    INTEGER(iwp)                   ::  rcount   !< count MPI requests
     470    INTEGER(iwp)                   ::  tag      !<
    445471
    446472    INTEGER(idp)                   ::  bufsize  !< size of MPI data window
    447473    INTEGER(KIND=MPI_ADDRESS_KIND) ::  winsize  !<
    448474
    449     INTEGER, DIMENSION(1024)       ::  req      !<
     475    INTEGER(iwp), DIMENSION(1024)       ::  req      !<
    450476
    451477    TYPE(C_PTR)             ::  base_ptr  !<
    … …  
    482508          tag    = tag + 1
    483509          rcount = rcount + 1
    484           CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag,                    &
     510          CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag,                   &
    485511                          children(childid)%inter_comm, req(rcount), ierr )
    486512!
    487 !--       Maximum of 1024 outstanding requests
    488 !--       TODO: what does this limit mean? Does outstanding mean pending?
     513!--       Maximum of 1024 pending requests
     514
    489515          IF ( rcount == 1024 )  THEN
    490516             CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
    … …  
    515541
    516542    winsize = bufsize * wp
    517     CALL MPI_WIN_CREATE( base_array_pc, winsize, wp, MPI_INFO_NULL,             &
    518                          children(childid)%intra_comm,                          &
     543    CALL MPI_WIN_CREATE( base_array_pc, winsize, wp, MPI_INFO_NULL,            &
     544                         children(childid)%intra_comm,                         &
    519545                         children(childid)%win_parent_child, ierr )
    520546!
    … …  
    533559
    534560          IF ( ar%sendindex + ar%sendsize > bufsize )  THEN             
    535              WRITE( message_string, '(a,i4,4i7,1x,a)' )                         &
    536                     'parent buffer too small ',i,                               &
    537                     ar%sendindex,ar%sendsize,ar%sendindex+ar%sendsize,          &
     561             WRITE( message_string, '(a,i4,4i7,1x,a)' )                        &
     562                    'parent buffer too small ',i,                              &
     563                    ar%sendindex,ar%sendsize,ar%sendindex+ar%sendsize,         &
    538564                    bufsize,trim(ar%name)
    539565             CALL message( 'pmc_s_setind_and_allocmem', 'PA0429', 3, 2, 0, 6, 0 )
    … …  
    554580!--       Receive index from child
    555581          tag = tag + 1
    556           CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag,                     &
     582          CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag,                    &
    557583                         children(childid)%inter_comm, MPI_STATUS_IGNORE, ierr )
    558584          IF ( ar%nrdims == 3 )  THEN
    … …  
    586612
    587613
    588  SUBROUTINE pmc_s_fillbuffer( childid, waittime )
    589 
    590     IMPLICIT NONE
    591 
    592     INTEGER, INTENT(IN)             ::  childid   !<
     614 SUBROUTINE pmc_s_fillbuffer( childid, waittime, particle_transfer )
     615
     616    IMPLICIT NONE
     617
     618    INTEGER(iwp), INTENT(IN)             ::  childid   !<
    593619
    594620    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime  !<
    595 
    596     INTEGER               ::  ierr     !<
    597     INTEGER               ::  ij       !<
    598     INTEGER               ::  ip       !<
    599     INTEGER               ::  istat    !<
    600     INTEGER               ::  j        !<
    601     INTEGER               ::  myindex  !<
    602 
    603     INTEGER, DIMENSION(1) ::  buf_shape
     621    LOGICAL, INTENT(IN), OPTIONAL   ::  particle_transfer  !<
     622
     623
     624    INTEGER(iwp)               ::  ierr     !<
     625    INTEGER(iwp)               ::  ij       !<
     626    INTEGER(iwp)               ::  ip       !<
     627    INTEGER(iwp)               ::  istat    !<
     628    INTEGER(iwp)               ::  j        !<
     629    INTEGER(iwp)               ::  myindex  !<
     630   
     631    LOGICAL                    ::  lo_ptrans
     632
     633    INTEGER(iwp), DIMENSION(1) ::  buf_shape
    604634
    605635    REAL(wp)                            ::  t1       !<
    … …  
    608638    REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d  !<
    609639    REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d  !<
     640    INTEGER(idp), POINTER, DIMENSION(:)     ::  ibuf      !<
     641    INTEGER(idp), POINTER, DIMENSION(:,:)   ::  idata_2d  !<
    610642
    611643    TYPE(pedef), POINTER    ::  ape  !<
    … …  
    625657    ENDIF
    626658
     659    lo_ptrans = .FALSE.
     660    IF ( PRESENT( particle_transfer))    lo_ptrans = particle_transfer
     661
    627662    DO  ip = 1, children(childid)%inter_npes
    628663       ape => children(childid)%pes(ip)
    … …  
    630665          ar => ape%array_list(j)
    631666          myindex = 1
    632           IF ( ar%nrdims == 2 )  THEN
     667
     668          IF ( ar%dimkey == 2 .AND. .NOT.lo_ptrans  )  THEN                            ! PALM 2D REAL*8 Array
     669
    633670             buf_shape(1) = ape%nrele
    634671             CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
    … …  
    638675                myindex = myindex + 1
    639676             ENDDO
    640           ELSEIF ( ar%nrdims == 3 )  THEN
     677
     678          ELSEIF ( ar%dimkey == 3  .AND. .NOT.lo_ptrans  )  THEN                       ! PALM 3D REAL*8 Array
     679
    641680             buf_shape(1) = ape%nrele*ar%a_dim(4)
    642681             CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
    … …  
    647686                myindex = myindex + ar%a_dim(4)
    648687             ENDDO
     688          ELSEIF ( ar%dimkey == 22 .AND. lo_ptrans  )  THEN                           ! 2D INTEGER*8 Array for particle Transfer
     689
     690             buf_shape(1) = ape%nrele
     691             CALL C_F_POINTER( ar%sendbuf, ibuf, buf_shape )
     692             CALL C_F_POINTER( ar%data, idata_2d, ar%a_dim(1:2) )
     693             DO  ij = 1, ape%nrele
     694                ibuf(myindex) = idata_2d(ape%locind(ij)%j,ape%locind(ij)%i)
     695                myindex = myindex + 1
     696             ENDDO
    649697          ENDIF
    650698        ENDDO
    … …  
    658706
    659707
    660  SUBROUTINE pmc_s_getdata_from_buffer( childid, waittime )
    661 
    662     IMPLICIT NONE
    663 
    664     INTEGER, INTENT(IN)             ::  childid      !<
     708 SUBROUTINE pmc_s_getdata_from_buffer( childid, waittime , particle_transfer, child_process_nr )
     709
     710    IMPLICIT NONE
     711
     712    INTEGER(iwp), INTENT(IN)             ::  childid      !<
    665713    REAL(wp), INTENT(OUT), OPTIONAL ::  waittime     !<
    666 
    667     INTEGER                        ::  ierr          !<
    668     INTEGER                        ::  ij            !<
    669     INTEGER                        ::  ip            !<
    670     INTEGER                        ::  istat         !<
    671     INTEGER                        ::  j             !<
    672     INTEGER                        ::  myindex       !<
    673     INTEGER                        ::  nr            !<
    674     INTEGER                        ::  target_pe     !<
     714    LOGICAL, INTENT(IN), OPTIONAL   ::  particle_transfer     !<
     715    INTEGER(iwp), INTENT(IN), OPTIONAL   ::  child_process_nr      !<
     716
     717    INTEGER(iwp)                        ::  ierr          !<
     718    INTEGER(iwp)                   ::  ij            !<
     719    INTEGER(iwp)                   ::  ip            !<
     720    INTEGER(iwp)                   ::  ip_start      !<
     721    INTEGER(iwp)                   ::  ip_end        !<
     722    INTEGER(iwp)                   ::  istat         !<
     723    INTEGER(iwp)                   ::  j             !<
     724    INTEGER(iwp)                   ::  myindex       !<
     725    INTEGER(iwp)                   ::  nr            !<
     726    INTEGER(iwp)                   ::  target_pe     !<
    675727    INTEGER(kind=MPI_ADDRESS_KIND) ::  target_disp   !<
    676 
    677     INTEGER, DIMENSION(1)          ::  buf_shape     !<
    678 
    679     REAL(wp)                            ::  t1       !<
    680     REAL(wp)                            ::  t2       !<
    681     REAL(wp), POINTER, DIMENSION(:)     ::  buf      !<
    682     REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d  !<
    683     REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d  !<
    684 
    685     TYPE(pedef), POINTER    ::  ape  !<
    686     TYPE(arraydef), POINTER ::  ar   !<
     728   
     729    LOGICAL                        ::  lo_ptrans
     730
     731    INTEGER(iwp), DIMENSION(1)          ::  buf_shape     !<
     732
     733    REAL(wp)                                ::  t1       !<
     734    REAL(wp)                                ::  t2       !<
     735    REAL(wp), POINTER, DIMENSION(:)         ::  buf      !<
     736    REAL(wp), POINTER, DIMENSION(:,:)       ::  data_2d  !<
     737    REAL(wp), POINTER, DIMENSION(:,:,:)     ::  data_3d  !<
     738    INTEGER(idp), POINTER, DIMENSION(:)     ::  ibuf      !<
     739    INTEGER(idp), POINTER, DIMENSION(:,:)   ::  idata_2d  !<
     740
     741    TYPE(pedef), POINTER                    ::  ape  !<
     742    TYPE(arraydef), POINTER                 ::  ar   !<
    687743
    688744
    689745    t1 = pmc_time()
    690 !
    691 !-- Wait for child to fill buffer
    692     CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
    693     t2 = pmc_time() - t1
    694     IF ( PRESENT( waittime ) )  waittime = t2
    695 !
    696 !-- TODO: check next statement
    697 !-- Fence might do it, test later
    698 !-- CALL MPI_WIN_FENCE( 0, children(childid)%win_parent_child, ierr)
    699     CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
    700 
    701     DO  ip = 1, children(childid)%inter_npes
     746
     747    IF(PRESENT(child_process_nr)) then
     748       ip_start = child_process_nr
     749       ip_end   = child_process_nr
     750    ELSE
     751       ip_start = 1
     752       ip_end   = children(childid)%inter_npes
     753    END IF
     754
     755    lo_ptrans = .FALSE.
     756    IF ( PRESENT( particle_transfer))    lo_ptrans = particle_transfer
     757
     758    IF(ip_start == 1)   THEN
     759!
     760!--    Wait for child to fill buffer
     761       CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
     762       t2 = pmc_time() - t1
     763       IF ( PRESENT( waittime ) )  waittime = t2
     764
     765       CALL MPI_BARRIER( children(childid)%intra_comm, ierr )
     766    ENDIF
     767
     768    DO  ip = ip_start,ip_end
    702769       ape => children(childid)%pes(ip)
    703770       DO  j = 1, ape%nr_arrays
    … …  
    706773          IF ( ar%recvindex < 0 )  CYCLE
    707774
    708           IF ( ar%nrdims == 2 )  THEN
     775          IF ( ar%dimkey == 2  .AND. .NOT.lo_ptrans )  THEN
    709776             nr = ape%nrele
    710           ELSEIF ( ar%nrdims == 3 )  THEN
     777          ELSEIF ( ar%dimkey == 3  .AND. .NOT.lo_ptrans )  THEN
    711778             nr = ape%nrele * ar%a_dim(4)
     779          ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
     780             nr = ape%nrele
     781          ELSE
     782             CYCLE                                        !particle array are not transfered here
    712783          ENDIF
    713784          buf_shape(1) = nr
    714           CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
     785          IF(lo_ptrans)   THEN
     786             CALL C_F_POINTER( ar%recvbuf, ibuf, buf_shape )
     787          ELSE
     788             CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
     789          ENDIF
     790
    715791!
    716792!--       MPI passive target RMA
    … …  
    720796!--          Child processes are located behind parent process
    721797             target_pe = ip - 1 + m_model_npes
    722              CALL MPI_WIN_LOCK( MPI_LOCK_SHARED, target_pe, 0,                  &
     798             CALL MPI_WIN_LOCK( MPI_LOCK_SHARED, target_pe, 0,                      &
    723799                                children(childid)%win_parent_child, ierr )
    724              CALL MPI_GET( buf, nr, MPI_REAL, target_pe, target_disp, nr,       &
    725                            MPI_REAL, children(childid)%win_parent_child, ierr )
    726              CALL MPI_WIN_UNLOCK( target_pe,                                    &
     800             IF(lo_ptrans)   THEN
     801                CALL MPI_GET( ibuf, nr*8, MPI_BYTE, target_pe, target_disp, nr*8,    &              !There is no MPI_INTEGER8 datatype
     802                              MPI_BYTE, children(childid)%win_parent_child, ierr )
     803             ELSE
     804                CALL MPI_GET( buf, nr, MPI_REAL, target_pe, target_disp, nr,        &
     805                              MPI_REAL, children(childid)%win_parent_child, ierr )
     806             ENDIF
     807             CALL MPI_WIN_UNLOCK( target_pe,                                        &
    727808                                  children(childid)%win_parent_child, ierr )
    728809          ENDIF
    729810          myindex = 1
    730           IF ( ar%nrdims == 2 )  THEN
     811          IF ( ar%dimkey == 2  .AND. .NOT.lo_ptrans  )  THEN
     812
    731813             CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
    732814             DO  ij = 1, ape%nrele
    … …  
    734816                myindex = myindex + 1
    735817             ENDDO
    736           ELSEIF ( ar%nrdims == 3 )  THEN
     818
     819          ELSEIF ( ar%dimkey == 3  .AND. .NOT.lo_ptrans  )  THEN
     820
    737821             CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3))
    738822             DO  ij = 1, ape%nrele
    739                 data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i) =      &
     823                data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i) =     &
    740824                                              buf(myindex:myindex+ar%a_dim(4)-1)
    741825                myindex = myindex + ar%a_dim(4)
    742826             ENDDO
     827
     828          ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans)  THEN
     829
     830             CALL C_F_POINTER( ar%data, idata_2d, ar%a_dim(1:2) )
     831             DO  ij = 1, ape%nrele
     832                idata_2d(ape%locind(ij)%j,ape%locind(ij)%i) = ibuf(myindex)
     833                myindex = myindex + 1
     834             ENDDO
     835
    743836          ENDIF
    744837       ENDDO
    … …  
    755848    IMPLICIT NONE
    756849
    757     INTEGER, INTENT(IN) ::  childid  !<
     850    INTEGER(iwp), INTENT(IN) ::  childid  !<
    758851
    759852    TYPE(da_namedef) ::  myname  !<
    … …  
    767860       CALL pmc_bcast( myname%nameonchild,  0, comm=m_to_child_comm(childid) )
    768861
    769        CALL pmc_g_setname( children(childid), myname%couple_index,              &
     862       CALL pmc_g_setname( children(childid), myname%couple_index,             &
    770863                           myname%nameonparent )
    771864   ENDDO
    … …  
    775868
    776869
    777  SUBROUTINE pmc_s_setarray(childid, nrdims, dims, array_adr, second_adr )
     870 SUBROUTINE pmc_s_setarray(childid, nrdims, dims, array_adr, second_adr, dimkey )
    778871
    779872!
    … …  
    781874    IMPLICIT NONE
    782875
    783     INTEGER, INTENT(IN)               ::  childid    !<
    784     INTEGER, INTENT(IN)               ::  nrdims     !<
    785     INTEGER, INTENT(IN), DIMENSION(:) ::  dims       !<
    786 
    787     TYPE(C_PTR), INTENT(IN)           :: array_adr   !<
    788     TYPE(C_PTR), INTENT(IN), OPTIONAL :: second_adr  !<
    789 
    790     INTEGER ::  i  !< local counter
     876    INTEGER(iwp), INTENT(IN)               :: childid    !<
     877    INTEGER(iwp), INTENT(IN)               :: nrdims     !<
     878    INTEGER(iwp), INTENT(IN), DIMENSION(:) :: dims       !<
     879
     880    TYPE(C_PTR), INTENT(IN)           :: array_adr  !<
     881    TYPE(C_PTR), INTENT(IN), OPTIONAL :: second_adr !<
     882    INTEGER(iwp), INTENT(IN), OPTIONAL     :: dimkey     !<
     883
     884    INTEGER(iwp) ::  i  !< local counter
    791885
    792886    TYPE(pedef), POINTER    ::  ape  !<
    … …  
    798892       ar  => ape%array_list(next_array_in_list)
    799893       ar%nrdims = nrdims
     894       ar%dimkey = nrdims
     895       IF(PRESENT(dimkey)) ar%dimkey = dimkey
    800896       ar%a_dim  = dims
    801897       ar%data   = array_adr
    … …  
    817913    IMPLICIT NONE
    818914
    819     INTEGER, INTENT(IN) ::  childid   !<
    820     INTEGER, INTENT(IN) ::  iactive   !<
    821 
    822     INTEGER :: i   !<
    823     INTEGER :: ip  !<
    824     INTEGER :: j   !<
     915    INTEGER(iwp), INTENT(IN) ::  childid   !<
     916    INTEGER(iwp), INTENT(IN) ::  iactive   !<
     917
     918    INTEGER(iwp) :: i   !<
     919    INTEGER(iwp) :: ip  !<
     920    INTEGER(iwp) :: j   !<
    825921
    826922    TYPE(pedef), POINTER    ::  ape  !<
    … …  
    831927       DO  j = 1, ape%nr_arrays
    832928          ar => ape%array_list(j)
     929          if(mod(ar%dimkey,10) == 2) CYCLE           !Not for 2D array
    833930          IF ( iactive == 1  .OR.  iactive == 2 )  THEN
    834931             ar%data = ar%po_data(iactive)
    … …  
    839936 END SUBROUTINE pmc_s_set_active_data_array
    840937
     938 INTEGER FUNCTION pmc_s_get_child_npes (child_id)
     939   IMPLICIT NONE
     940
     941   INTEGER(iwp),INTENT(IN)                 :: child_id
     942
     943   pmc_s_get_child_npes = children(child_id)%inter_npes
     944
     945   RETURN
     946 END FUNCTION pmc_s_get_child_npes
    841947
    842948
    … …  
    845951    IMPLICIT NONE
    846952
    847     INTEGER, INTENT(IN)                 ::  childid     !<
    848     INTEGER, INTENT(IN), DIMENSION(:,:) ::  index_list  !<
    849     INTEGER, INTENT(IN)                 ::  nrp         !<
     953    INTEGER(iwp), INTENT(IN)                 ::  childid     !<
     954    INTEGER(iwp), INTENT(IN), DIMENSION(:,:) ::  index_list  !<
     955    INTEGER(iwp), INTENT(IN)                 ::  nrp         !<
    850956
    851957    TYPE(childdef), INTENT(INOUT)       ::  mychild     !<
    852958
    853     INTEGER                                 :: i        !<
    854     INTEGER                                 :: ierr     !<
    855     INTEGER                                 :: ind      !<
    856     INTEGER                                 :: indwin   !<
    857     INTEGER                                 :: indwin2  !<
    858     INTEGER                                 :: i2       !<
    859     INTEGER                                 :: j        !<
    860     INTEGER                                 :: rempe    !<
     959    INTEGER(iwp)                            :: i        !<
     960    INTEGER(iwp)                            :: ierr     !<
     961    INTEGER(iwp)                            :: ind      !<
     962    INTEGER(iwp)                            :: indwin   !<
     963    INTEGER(iwp)                            :: indwin2  !<
     964    INTEGER(iwp)                            :: i2       !<
     965    INTEGER(iwp)                            :: j        !<
     966    INTEGER(iwp)                            :: rempe    !<
    861967    INTEGER(KIND=MPI_ADDRESS_KIND)          :: winsize  !<
    862968
    863     INTEGER, DIMENSION(mychild%inter_npes)  :: remind   !<
    864 
    865     INTEGER, DIMENSION(:), POINTER          :: remindw  !<
    866     INTEGER, DIMENSION(:), POINTER          :: rldef    !<
     969    INTEGER(iwp), DIMENSION(mychild%inter_npes)  :: remind   !<
     970
     971    INTEGER(iwp), DIMENSION(:), POINTER          :: remindw  !<
     972    INTEGER(iwp), DIMENSION(:), POINTER          :: rldef    !<
    867973
    868974    TYPE(pedef), POINTER                    :: ape      !<
    … …  
    9061012    winsize = mychild%inter_npes*c_sizeof(i)*2
    9071013
    908     CALL MPI_WIN_CREATE( rldef, winsize, iwp, MPI_INFO_NULL,                    &
     1014    CALL MPI_WIN_CREATE( rldef, winsize, iwp, MPI_INFO_NULL,                   &
    9091015                         mychild%intra_comm, indwin, ierr )
    9101016!
    … …  
    9371043
    9381044    CALL MPI_BARRIER( m_model_comm, ierr )
    939     CALL MPI_WIN_CREATE( remindw, winsize*c_sizeof(i), iwp, MPI_INFO_NULL,      &
     1045    CALL MPI_WIN_CREATE( remindw, winsize*c_sizeof(i), iwp, MPI_INFO_NULL,     &
    9401046                         mychild%intra_comm, indwin2, ierr )
    9411047!
Note: See TracChangeset for help on using the changeset viewer.
                                                                                                                                                                                                                                                                                                                                                                               
  | Impressum | ©Leibniz Universität Hannover |