Changeset 12993


Ignore:
Timestamp:
2020-05-29T17:13:41+02:00 (2 months ago)
Author:
smasson
Message:

Extra_Halo: works when removing land subdomain, cleaning/rewriting of mpp_nfd_generic.h90, see #2366

Location:
NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/DOM/dom_oce.F90

    r12978 r12993  
    104104   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nis0all, njs0all  !: first, last indoor index for all i-subdomain 
    105105   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nie0all, nje0all  !: first, last indoor index for all j-subdomain 
    106    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfiimpp, nfipproc, nfijpit 
     106   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nfimpp, nfproc, nfjpi 
    107107 
    108108   !!---------------------------------------------------------------------- 
  • NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r12992 r12993  
    9999                       ijj = jpj -jj +1 
    100100                     DO ji = startloop, jpi 
    101                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     101                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
    102102                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
    103103                     END DO 
     
    126126                     DO jl = 1, ipl; DO jk = 1, ipk 
    127127                        DO ji = startloop, jpi 
    128                            ijt  = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     128                           ijt  = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
    129129                           jia  = ji + nimpp - 1 
    130130                           ijta = jpiglo - jia + 2 
     
    148148              ijj = jpj -jj +1 
    149149                     DO ji = 1, endloop 
    150                         iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     150                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    151151                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 
    152152                     END DO 
     
    186186                  DO jl = 1, ipl; DO jk = 1, ipk 
    187187                     DO ji = startloop, endloop 
    188                         iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     188                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    189189                        jia = ji + nimpp - 1  
    190190                        ijua = jpiglo - jia + 1  
     
    210210                     ijj = jpj -jj +1 
    211211                        DO ji = startloop, jpi 
    212                            ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     212                           ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
    213213                           ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
    214214                        END DO 
     
    218218               DO jl = 1, ipl; DO jk = 1, ipk 
    219219                  DO ji = startloop, jpi 
    220                      ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     220                     ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
    221221                     ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf) 
    222222                  END DO 
     
    241241                     ijj = jpj -jj +1 
    242242                        DO ji = 1, endloop 
    243                            iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     243                           iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    244244                           ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 
    245245                        END DO 
     
    249249               DO jl = 1, ipl; DO jk = 1, ipk 
    250250                  DO ji = 1, endloop 
    251                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     251                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    252252                     ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf) 
    253253                  END DO 
     
    290290           ijj = jpj-jj+1 
    291291           DO ji = 1, jpi 
    292                         ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     292                        ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    293293                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
    294294                     END DO 
     
    306306           ijj = jpj-jj+1 
    307307                     DO ji = 1, endloop 
    308                         iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
     308                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 
    309309                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 
    310310                     END DO 
     
    328328           ijj = jpj -jj +1 
    329329                     DO ji = 1, jpi 
    330                         ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     330                        ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    331331                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
    332332                     END DO 
     
    345345                  DO jl = 1, ipl; DO jk = 1, ipk 
    346346                        DO ji = startloop, jpi 
    347                         ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     347                        ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    348348                           ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 
    349349                        END DO 
     
    362362          ijj = jpj -jj +1 
    363363                    DO ji = 1, endloop 
    364                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
     364                       iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 
    365365                       ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 
    366366                     END DO 
     
    395395                     DO jl = 1, ipl; DO jk = 1, ipk 
    396396                        DO ji = startloop, endloop 
    397                            iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
     397                           iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 
    398398                           ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 
    399399                        END DO 
  • NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_lnk_generic.h90

    r12807 r12993  
    238238         ! 
    239239         SELECT CASE ( jpni ) 
    240          CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! only 1 northern proc, no mpp 
    241          CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) )   ! for all northern procs. 
     240         CASE ( 1 )     ;   CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:)                  OPT_K(:) )   ! only 1 northern proc, no mpp 
     241         CASE DEFAULT   ;   CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:), ifill_no, zland OPT_K(:) )   ! for all northern procs. 
    242242         END SELECT 
    243243         ! 
  • NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_nfd_generic.h90

    r12992 r12993  
    4646#endif 
    4747 
    48    SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 
     48   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 
    4949      !!---------------------------------------------------------------------- 
    5050      ARRAY_TYPE(:,:,:,:,:)   ! array or pointer of arrays on which the boundary condition is applied 
    5151      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    5252      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
     53      INTEGER          , INTENT(in   ) ::   kfillmode   ! filling method for halo over land  
     54      REAL(wp)         , INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
    5355      INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    5456      ! 
     57      LOGICAL  ::   ll_add_line 
    5558      INTEGER  ::   ji,  jj,  jk,  jl, jh, jf, jr   ! dummy loop indices 
    5659      INTEGER  ::   ipi, ipk, ipl, ipf         ! dimension of the input array 
    5760      INTEGER  ::   imigr, iihom, ijhom             ! local integers 
    5861      INTEGER  ::   ierr, ibuffsize, ijpi, iis0, iie0, iilb 
    59       INTEGER  ::   ij, iproc 
     62      INTEGER  ::   ijbs, ijbe, ipimax2 
     63      INTEGER  ::   ij, iproc, ipni 
    6064      INTEGER, DIMENSION (jpmaxngh)       ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather 
    6165      INTEGER                             ::   ml_err      ! for mpi_isend when avoiding mpi_allgather 
    6266      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat     ! for mpi_isend when avoiding mpi_allgather 
    6367      !                                                    ! Workspace for message transfers avoiding mpi_allgather 
    64       INTEGER                             ::   ipf_j       ! sum of lines for all multi fields 
    65       INTEGER                             ::   js          ! counter 
    66       INTEGER, DIMENSION(:,:),          ALLOCATABLE ::   jj_s  ! position of sent lines 
    67       INTEGER, DIMENSION(:),            ALLOCATABLE ::   ipj_s ! number of sent lines 
    68       REAL(wp), DIMENSION(:,:,:)      , ALLOCATABLE ::   ztabl 
    69       REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, ztabr 
    70       REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc, zfoldwk       
     68      INTEGER                             ::   ipj_b       ! sum of lines for all multi fields 
     69      INTEGER                             ::   ijs, ijb    ! j-counter for send and buffer 
     70      INTEGER                             ::   i012        ! 0, 1 or 2 
     71      INTEGER , DIMENSION(:,:)        , ALLOCATABLE ::   jj_s  ! position of sent lines 
     72      INTEGER , DIMENSION(:,:)        , ALLOCATABLE ::   jj_b  ! position of buffer lines 
     73      INTEGER , DIMENSION(:)          , ALLOCATABLE ::   ipj_s ! number of sent lines 
     74      REAL(wp), DIMENSION(:,:,:,:)    , ALLOCATABLE ::   ztabb, ztabr, ztabw  ! buffer, receive and work arrays 
     75      REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, znorthloc 
    7176      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthgloio 
    7277      !!---------------------------------------------------------------------- 
     
    7883      IF( l_north_nogather ) THEN      !==  no allgather exchanges  ==! 
    7984 
    80          ALLOCATE(ipj_s(ipf)) 
    81  
    82          ijpj     = 2 + nn_hls -1           ! Max 2nd dimension of message transfers (last two j-line only) 
    83          ipj_s(:) = 1 + nn_hls -1           ! Real 2nd dimension of message transfers (depending on perf requirement) 
    84                                  ! by default, only one line is exchanged 
    85  
    86          ALLOCATE( jj_s(ipf,ijpj) ) 
    87  
    88          ! re-define number of exchanged lines : 
    89          !  must be two during the first two time steps 
    90          !  to correct possible incoherent values on North fold lines from restart  
    91  
     85         !   ---   define number of exchanged lines   --- 
     86         ! 
     87         ! In theory we should exchange only nn_hls lines. 
     88         ! 
     89         ! However, some other points are duplicated in the north pole folding: 
     90         !  - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 
     91         !  - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 
     92         !  - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 
     93         !  - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 
     94         !  - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 
     95         !  - jperio=[56], grid=U : no points are duplicated 
     96         !  - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 
     97         !  - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 
     98         ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 
     99         ! This explain why these duplicated points may have different values even if they are at the exact same location. 
     100         ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. 
     101         ! This is slightly slower but necessary to avoid different values on identical grid points!! 
     102         ! 
    92103         !!!!!!!!!           temporary switch off this optimisation ==> force TRUE           !!!!!!!! 
    93104         !!!!!!!!!  needed to get the same results without agrif and with agrif and no zoom  !!!!!!!! 
    94105         !!!!!!!!!                    I don't know why we must do that...                    !!!!!!!! 
    95106         l_full_nf_update = .TRUE. 
    96  
    97          ! Two lines update (slower but necessary to avoid different values ion identical grid points 
    98          IF ( l_full_nf_update .OR.                          &    ! if coupling fields 
    99               ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) &    ! at first time step, if not restart 
    100             ipj_s(:) = 2 + nn_hls -1 
     107         ! also force it if not restart during the first 2 steps (leap frog?) 
     108         ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) 
     109          
     110         ALLOCATE(ipj_s(ipf))                ! how many lines do we exchange? 
     111         IF( ll_add_line ) THEN 
     112            DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
     113               ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) )  
     114            END DO 
     115         ELSE 
     116            ipj_s(:) = nn_hls 
     117         ENDIF 
     118          
     119         ijpj  = MAXVAL(ipj_s(:))            ! Max 2nd dimension of message transfers (last two j-line only) 
     120         ipj_b = SUM(   ipj_s(:))            ! Total number of lines to be exchanged 
     121         ALLOCATE( jj_s(ijpj, ipf), jj_b(ijpj, ipf) ) 
    101122 
    102123         ! Index of modifying lines in input 
     124         ijb = 0 
    103125         DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
    104126            ! 
    105127            SELECT CASE ( npolj ) 
    106             ! 
    107128            CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    108                ! 
    109129               SELECT CASE ( NAT_IN(jf) ) 
    110                ! 
    111                CASE ( 'T' , 'W' ,'U' )                            ! T-, U-, W-point 
    112                   DO ji = 1, nn_hls+1 
    113                      jj_s(jf,ji) = jpj - 2*nn_hls +ji -1 
    114                   ENDDO 
    115                CASE ( 'V' , 'F' )                                 ! V-, F-point 
    116                   DO ji = 1, nn_hls+1 
    117                      jj_s(jf,ji) = jpj - 2*nn_hls +ji - 2 
    118                   ENDDO 
     130               CASE ( 'T', 'W', 'U' )   ;   i012 = 1   ! T-, U-, W-point 
     131               CASE ( 'V', 'F'      )   ;   i012 = 2   ! V-, F-point 
    119132               END SELECT 
    120             ! 
    121             CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
     133            CASE ( 5, 6 )                       ! *  North fold  F-point pivot 
    122134               SELECT CASE ( NAT_IN(jf) ) 
    123                ! 
    124                CASE ( 'T' , 'W' ,'U' )                            ! T-, U-, W-point 
    125                   DO ji = 1, nn_hls 
    126                      jj_s(jf,ji) = jpj - 2*nn_hls + ji 
    127                   ENDDO 
    128                   ipj_s(jf) = nn_hls                  ! need only one line anyway 
    129                CASE ( 'V' , 'F' )                                 ! V-, F-point 
    130                   DO ji = 1, nn_hls+1 
    131                      jj_s(jf,ji) = jpj - 2*nn_hls +ji -1 
    132                   ENDDO 
     135               CASE ( 'T', 'W', 'U' )   ;   i012 = 0   ! T-, U-, W-point 
     136               CASE ( 'V', 'F'      )   ;   i012 = 1   ! V-, F-point 
    133137               END SELECT 
    134             ! 
    135138            END SELECT 
    136             ! 
    137          ENDDO 
    138          !  
    139          ipf_j = sum (ipj_s(:))      ! Total number of lines to be exchanged 
    140          ! 
    141          ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 
    142          ! 
    143          js = 0 
    144          DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
     139               ! 
    145140            DO jj = 1, ipj_s(jf) 
    146                js = js + 1 
    147                DO jl = 1, ipl 
    148                   DO jk = 1, ipk 
    149                      znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 
    150                   END DO 
    151                END DO 
    152             END DO 
    153          END DO 
    154          ! 
    155          ibuffsize = jpimax * ipf_j * ipk * ipl 
    156          ! 
    157          ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 
    158          ALLOCATE( ztabr(jpimax*jpmaxngh,ijpj,ipk,ipl,ipf) )  
    159          ! when some processors of the north fold are suppressed,  
    160          ! values of ztab* arrays corresponding to these suppressed domain won't be defined  
    161          ! and we need a default definition to 0. 
    162          ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 
    163          IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 
     141               ijb = ijb + 1 
     142               jj_b(jj,jf) = ijb 
     143               jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012 
     144            END DO 
     145            ! 
     146         END DO 
     147         ! 
     148         ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) )   ! store all the data to be sent in a buffer array 
     149         ibuffsize = jpimax * ipj_b * ipk * ipl 
     150         ! 
     151         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk 
     152            DO jj = 1, ipj_s(jf) 
     153               ijb = jj_b(jj,jf) 
     154               ijs = jj_s(jj,jf) 
     155               ztabb(    1:jpi   ,ijb,jk,jl) = ARRAY_IN(1:jpi,ijs,jk,jl,jf) 
     156               ztabb(jpi+1:jpimax,ijb,jk,jl) = 0._wp  ! needed? to avoid sending uninitialized values 
     157            END DO 
     158         END DO   ;   END DO   ;   END DO 
    164159         ! 
    165160         ! start waiting time measurement 
    166161         IF( ln_timing ) CALL tic_tac(.TRUE.) 
    167162         ! 
     163         ! send the data as soon as possible 
    168164         DO jr = 1, nsndto 
    169             IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    170                CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    171             ENDIF 
    172          END DO 
     165            iproc = nfproc(isendto(jr)) 
     166            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
     167               CALL mppsend( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 
     168            ENDIF 
     169         END DO 
     170         ! 
     171         ipimax2 = jpimax * jpmaxngh 
     172         ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax2,ipj_b,ipk,ipl) )  
     173         ! 
     174         DO jr = 1, nsndto 
     175            ! 
     176            ipni  = isendto(jr) 
     177            iproc = nfproc(ipni) 
     178            ijpi  = nfjpi (ipni) 
     179            ! 
     180            IF( ipni ==   1  ) THEN   ;   iis0 =   1             ! domain  left side: as e-w comm already done -> from 1st column 
     181            ELSE                      ;   iis0 =   1  + nn_hls   ! default: -> from inner domain  
     182            ENDIF 
     183            IF( ipni == jpni ) THEN   ;   iie0 = ijpi            ! domain right side: as e-w comm already done -> until last column 
     184            ELSE                      ;   iie0 = ijpi - nn_hls   ! default: -> until inner domain  
     185            ENDIF 
     186            iilb = nfimpp(ipni) - nfimpp(isendto(1)) 
     187            ! 
     188            IF(           iproc == -1 ) THEN   ! No neighbour (land proc that was suppressed) 
     189               ! 
     190               SELECT CASE ( kfillmode ) 
     191               CASE ( jpfillnothing )               ! no filling  
     192               CASE ( jpfillcopy    )               ! filling with inner domain values 
     193                  DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk 
     194                     DO jj = 1, ipj_s(jf) 
     195                        ijb = jj_b(jj,jf) 
     196                        ijs = jj_s(jj,jf) 
     197                        DO ji = iis0, iie0 
     198                           ztabr(iilb+ji,ijb,jk,jl) = ARRAY_IN(nn_hls+1,ijs,jk,jl,jf)   ! chose to take the 1st iner domain point 
     199                        END DO 
     200                     END DO 
     201                  END DO   ;   END DO   ;   END DO 
     202               CASE ( jpfillcst     )               ! filling with constant value 
     203                  DO jl = 1, ipl   ;   DO jk = 1, ipk 
     204                     DO jj = 1, ipj_b 
     205                        DO ji = iis0, iie0 
     206                           ztabr(iilb+ji,jj,jk,jl) = pfillval 
     207                        END DO 
     208                     END DO 
     209                  END DO   ;   END DO 
     210               END SELECT 
     211               ! 
     212            ELSE IF( iproc == narea-1 ) THEN   ! get data from myself! 
     213               ! 
     214               DO jf = 1, ipf   ;   DO jl = 1, ipl  ;   DO jk = 1, ipk 
     215                  DO jj = 1, ipj_s(jf) 
     216                     ijb = jj_b(jj,jf) 
     217                     ijs = jj_s(jj,jf) 
     218                     DO ji = iis0, iie0 
     219                        ztabr(iilb+ji,ijb,jk,jl) = ARRAY_IN(ji,ijs,jk,jl,jf) 
     220                     END DO 
     221                  END DO 
     222               END DO   ;   END DO   ;   END DO 
     223               ! 
     224            ELSE                               ! get data from a neighbour trough communication 
     225               !   
     226               CALL mpprecv(5, ztabw, ibuffsize, iproc) 
     227               DO jl = 1, ipl   ;   DO jk = 1, ipk 
     228                  DO jj = 1, ipj_b 
     229                     DO ji = iis0, iie0 
     230                        ztabr(iilb+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl) 
     231                     END DO 
     232                  END DO 
     233               END DO   ;   END DO 
     234                
     235            ENDIF 
     236         END DO 
     237         ! 
     238         IF( ln_timing ) CALL tic_tac(.FALSE.) 
     239         ! 
     240         ! North fold boundary condition 
     241         ! 
     242         DO jf = 1, ipf 
     243            ijbs = jj_b(       1 ,jf) 
     244            ijbe = jj_b(ipj_s(jf),jf) 
     245            CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ijbs:ijbe,:,:), cd_nat LBC_ARG, psgn LBC_ARG ) 
     246         END DO 
     247         ! 
     248         DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s ) 
    173249         ! 
    174250         DO jr = 1,nsndto 
    175             iproc = nfipproc(isendto(jr),jpnj) 
    176             IF(iproc /= -1) THEN 
    177                iilb =  nimppt(iproc+1) 
    178                ijpi =  jpiall(iproc+1) 
    179                iis0 = nis0all(iproc+1)  
    180                iie0 = nie0all(iproc+1) 
    181                IF( iilb            ==      1 )   iis0 = 1    ! e-w boundary already done -> force to take 1st column 
    182                IF( iilb + ijpi - 1 == jpiglo )   iie0 = ijpi ! e-w boundary already done -> force to take last column 
    183                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    184             ENDIF 
     251            iproc = nfproc(isendto(jr)) 
    185252            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    186                CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 
    187                js = 0 
    188                DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 
    189                   js = js + 1 
    190                   DO jl = 1, ipl 
    191                      DO jk = 1, ipk 
    192                         DO ji = iis0, iie0 
    193                            ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 
    194                         END DO 
    195                      END DO 
    196                   END DO 
    197                END DO; END DO 
    198             ELSE IF( iproc == narea-1 ) THEN 
    199                DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 
    200                   DO jl = 1, ipl 
    201                      DO jk = 1, ipk 
    202                         DO ji = iis0, iie0 
    203                            ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 
    204                         END DO 
    205                      END DO 
    206                   END DO 
    207                END DO; END DO 
    208             ENDIF 
    209          END DO 
    210          DO jr = 1,nsndto 
    211             IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    212                CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 
    213             ENDIF 
    214          END DO 
    215          ! 
    216          IF( ln_timing ) CALL tic_tac(.FALSE.) 
    217          ! 
    218          ! North fold boundary condition 
    219          ! 
    220          DO jf = 1, ipf 
    221             CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 
    222          END DO 
    223          ! 
    224          DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 
     253               CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )   ! put the wait at the very end just before the deallocate 
     254            ENDIF 
     255         END DO 
     256         DEALLOCATE( ztabb ) 
    225257         ! 
    226258      ELSE                             !==  allgather exchanges  ==! 
     
    266298            iis0  = nis0all(iproc) 
    267299            iie0  = nie0all(iproc) 
    268             IF( iilb            ==      1 )   iis0 = 1      ! e-w boundary already done -> force to take 1st column 
    269             IF( iilb + ijpi - 1 == jpiglo )   iie0 = ijpi   ! e-w boundary already done -> force to take last column 
     300            IF( iilb            ==      1 )   iis0 = 1      ! e-w boundary already done -> force to take all from 1st column 
     301            IF( iilb + ijpi - 1 == jpiglo )   iie0 = ijpi   ! e-w boundary already done -> force to take all until last column 
    270302            DO jf = 1, ipf 
    271303               DO jl = 1, ipl 
     
    298330         ! 
    299331      ! 
    300          DEALLOCATE( ztab ) 
    301          DEALLOCATE( znorthgloio ) 
     332         DEALLOCATE( ztab, znorthgloio, znorthloc ) 
    302333      ENDIF 
    303       ! 
    304       DEALLOCATE( znorthloc ) 
    305334      ! 
    306335   END SUBROUTINE ROUTINE_NFD 
  • NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mppini.F90

    r12960 r12993  
    317317      IF( numbot /= -1 )   CALL iom_close( numbot ) 
    318318      IF( numbdy /= -1 )   CALL iom_close( numbdy ) 
    319      
    320       ALLOCATE(  nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfijpit(jpni,jpnj) ,    & 
     319       
     320      ALLOCATE(  nfimpp(jpni ) , nfproc(jpni ) ,   nfjpi(jpni ) ,                     & 
    321321         &       nimppt(jpnij) , ibonit(jpnij) ,  jpiall(jpnij) ,  jpjall(jpnij) ,    & 
    322322         &       njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) ,    & 
     
    346346      ! 
    347347      CALL basic_decomposition( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 
    348       nfiimpp(:,:) = iimppt(:,:) 
    349       nfijpit(:,:) = ijpi(:,:) 
     348      nfimpp(:) = iimppt(:,jpnj) 
     349      nfjpi (:) =   ijpi(:,jpnj) 
    350350      ! 
    351351      IF(lwp) THEN 
     
    458458         ENDIF 
    459459      END DO 
    460       nfipproc(:,:) = ipproc(:,:) 
     460      nfproc(:) = ipproc(:,jpnj) 
    461461 
    462462      ! neighbour treatment: change ibondi, ibondj if next to a land zone 
     
    12601260         DO jn = 1, jpni 
    12611261            ! 
    1262             sxT = nfiimpp(jn, jpnj)                            ! sxT = 1st  point (in the global domain) of the jn process 
    1263             dxT = nfiimpp(jn, jpnj) + nfijpit(jn, jpnj) - 1    ! dxT = last point (in the global domain) of the jn process 
     1262            sxT = nfimpp(jn)                    ! sxT = 1st  point (in the global domain) of the jn process 
     1263            dxT = nfimpp(jn) + nfjpi(jn) - 1    ! dxT = last point (in the global domain) of the jn process 
    12641264            ! 
    12651265            IF    ( sxT < sxM  .AND.  sxM < dxT ) THEN 
Note: See TracChangeset for help on using the changeset viewer.