New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 13899 for NEMO/branches/2020/tickets_icb_1900/src/OCE/LBC/mpp_nfd_generic.h90 – NEMO

Ignore:
Timestamp:
2020-11-27T17:26:33+01:00 (4 years ago)
Author:
mathiot
Message:

ticket #1900: update branch to trunk and add ICB test case

Location:
NEMO/branches/2020/tickets_icb_1900
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2020/tickets_icb_1900

    • Property svn:externals

      •  

        old new  
        22^/utils/build/makenemo@HEAD   makenemo 
        33^/utils/build/mk@HEAD         mk 
        4 ^/utils/tools/@HEAD           tools 
         4^/utils/tools@HEAD            tools 
        55^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS      ext/AGRIF 
        66^/vendors/FCM@HEAD            ext/FCM 
        … …  
        88 
        99# SETTE 
        10 ^/utils/CI/sette@12931        sette 
         10^/utils/CI/sette@13559        sette 

  • NEMO/branches/2020/tickets_icb_1900/src/OCE/LBC/mpp_nfd_generic.h90

    r13226 r13899  
    6767#    define RECVROUTINE mpprecv_sp 
    6868#    define MPI_TYPE MPI_REAL 
     69#    define HUGEVAL(x)   HUGE(x/**/_sp) 
    6970# else 
    7071#    define PRECISION dp 
    … …  
    7273#    define RECVROUTINE mpprecv_dp 
    7374#    define MPI_TYPE MPI_DOUBLE_PRECISION 
     75#    define HUGEVAL(x)   HUGE(x/**/_dp) 
    7476# endif 
    7577 
    76    SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 
     78   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 
    7779      !!---------------------------------------------------------------------- 
    7880      ARRAY_TYPE(:,:,:,:,:)   ! array or pointer of arrays on which the boundary condition is applied 
    7981      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    8082      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
     83      INTEGER          , INTENT(in   ) ::   kfillmode   ! filling method for halo over land  
     84      REAL(wp)         , INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
    8185      INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    8286      ! 
     87      LOGICAL  ::   ll_add_line 
    8388      INTEGER  ::   ji,  jj,  jk,  jl, jh, jf, jr   ! dummy loop indices 
    84       INTEGER  ::   ipi, ipj, ipk, ipl, ipf         ! dimension of the input array 
     89      INTEGER  ::   ipi, ipj, ipj2, ipk, ipl, ipf   ! dimension of the input array 
    8590      INTEGER  ::   imigr, iihom, ijhom             ! local integers 
    86       INTEGER  ::   ierr, ibuffsize, ilci, ildi, ilei, iilb 
    87       INTEGER  ::   ij, iproc 
     91      INTEGER  ::   ierr, ibuffsize, iis0, iie0, impp 
     92      INTEGER  ::   ii1, ii2, ij1, ij2 
     93      INTEGER  ::   ipimax, i0max 
     94      INTEGER  ::   ij, iproc, ipni, ijnr 
    8895      INTEGER, DIMENSION (jpmaxngh)       ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather 
    8996      INTEGER                             ::   ml_err      ! for mpi_isend when avoiding mpi_allgather 
    9097      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat     ! for mpi_isend when avoiding mpi_allgather 
    9198      !                                                    ! Workspace for message transfers avoiding mpi_allgather 
    92       INTEGER                             ::   ipf_j       ! sum of lines for all multi fields 
    93       INTEGER                             ::   js          ! counter 
    94       INTEGER, DIMENSION(:,:),          ALLOCATABLE ::   jj_s  ! position of sent lines 
    95       INTEGER, DIMENSION(:),            ALLOCATABLE ::   ipj_s ! number of sent lines 
    96       REAL(PRECISION), DIMENSION(:,:,:)      , ALLOCATABLE ::   ztabl 
    97       REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, ztabr 
    98       REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc, zfoldwk       
    99       REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthgloio 
     99      INTEGER                             ::   ipj_b       ! sum of lines for all multi fields 
     100      INTEGER                             ::   i012        ! 0, 1 or 2 
     101      INTEGER , DIMENSION(:,:)        , ALLOCATABLE ::   jj_s  ! position of sent lines 
     102      INTEGER , DIMENSION(:,:)        , ALLOCATABLE ::   jj_b  ! position of buffer lines 
     103      INTEGER , DIMENSION(:)          , ALLOCATABLE ::   ipj_s ! number of sent lines 
     104      REAL(PRECISION), DIMENSION(:,:,:,:)    , ALLOCATABLE ::   ztabb, ztabr, ztabw  ! buffer, receive and work arrays 
     105      REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztabglo, znorthloc 
     106      REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthglo 
    100107      !!---------------------------------------------------------------------- 
    101108      ! 
    … …  
    106113      IF( l_north_nogather ) THEN      !==  no allgather exchanges  ==! 
    107114 
    108          ALLOCATE(ipj_s(ipf)) 
    109  
    110          ipj      = 2            ! Max 2nd dimension of message transfers (last two j-line only) 
    111          ipj_s(:) = 1            ! Real 2nd dimension of message transfers (depending on perf requirement) 
    112                                  ! by default, only one line is exchanged 
    113  
    114          ALLOCATE( jj_s(ipf,2) ) 
    115  
    116          ! re-define number of exchanged lines : 
    117          !  must be two during the first two time steps 
    118          !  to correct possible incoherent values on North fold lines from restart  
    119  
     115         !   ---   define number of exchanged lines   --- 
     116         ! 
     117         ! In theory we should exchange only nn_hls lines. 
     118         ! 
     119         ! However, some other points are duplicated in the north pole folding: 
     120         !  - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 
     121         !  - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 
     122         !  - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 
     123         !  - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 
     124         !  - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 
     125         !  - jperio=[56], grid=U : no points are duplicated 
     126         !  - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 
     127         !  - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 
     128         ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 
     129         ! This explain why these duplicated points may have different values even if they are at the exact same location. 
     130         ! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE. 
     131         ! This is slightly slower but necessary to avoid different values on identical grid points!! 
     132         ! 
    120133         !!!!!!!!!           temporary switch off this optimisation ==> force TRUE           !!!!!!!! 
    121134         !!!!!!!!!  needed to get the same results without agrif and with agrif and no zoom  !!!!!!!! 
    122135         !!!!!!!!!                    I don't know why we must do that...                    !!!!!!!! 
    123136         l_full_nf_update = .TRUE. 
    124  
    125          ! Two lines update (slower but necessary to avoid different values ion identical grid points 
    126          IF ( l_full_nf_update .OR.                          &    ! if coupling fields 
    127               ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) &    ! at first time step, if not restart 
    128             ipj_s(:) = 2 
     137         ! also force it if not restart during the first 2 steps (leap frog?) 
     138         ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart ) 
     139          
     140         ALLOCATE(ipj_s(ipf))                ! how many lines do we exchange? 
     141         IF( ll_add_line ) THEN 
     142            DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
     143               ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) )  
     144            END DO 
     145         ELSE 
     146            ipj_s(:) = nn_hls 
     147         ENDIF 
     148          
     149         ipj   = MAXVAL(ipj_s(:))            ! Max 2nd dimension of message transfers 
     150         ipj_b = SUM(   ipj_s(:))            ! Total number of lines to be exchanged 
     151         ALLOCATE( jj_s(ipj, ipf), jj_b(ipj, ipf) ) 
    129152 
    130153         ! Index of modifying lines in input 
     154         ij1 = 0 
    131155         DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
    132156            ! 
    133157            SELECT CASE ( npolj ) 
    134             ! 
    135158            CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    136                ! 
    137159               SELECT CASE ( NAT_IN(jf) ) 
    138                ! 
    139                CASE ( 'T' , 'W' ,'U' )                            ! T-, U-, W-point 
    140                   jj_s(jf,1) = nlcj - 2 ;  jj_s(jf,2) = nlcj - 1 
    141                CASE ( 'V' , 'F' )                                 ! V-, F-point 
    142                   jj_s(jf,1) = nlcj - 3 ;  jj_s(jf,2) = nlcj - 2 
     160               CASE ( 'T', 'W', 'U' )   ;   i012 = 1   ! T-, U-, W-point 
     161               CASE ( 'V', 'F'      )   ;   i012 = 2   ! V-, F-point 
    143162               END SELECT 
    144             ! 
    145             CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
     163            CASE ( 5, 6 )                       ! *  North fold  F-point pivot 
    146164               SELECT CASE ( NAT_IN(jf) ) 
    147                ! 
    148                CASE ( 'T' , 'W' ,'U' )                            ! T-, U-, W-point 
    149                   jj_s(jf,1) = nlcj - 1       
    150                   ipj_s(jf) = 1                  ! need only one line anyway 
    151                CASE ( 'V' , 'F' )                                 ! V-, F-point 
    152                   jj_s(jf,1) = nlcj - 2 ;  jj_s(jf,2) = nlcj - 1 
     165               CASE ( 'T', 'W', 'U' )   ;   i012 = 0   ! T-, U-, W-point 
     166               CASE ( 'V', 'F'      )   ;   i012 = 1   ! V-, F-point 
    153167               END SELECT 
    154             ! 
    155168            END SELECT 
    156             ! 
    157          ENDDO 
    158          !  
    159          ipf_j = sum (ipj_s(:))      ! Total number of lines to be exchanged 
    160          ! 
    161          ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 
    162          ! 
    163          js = 0 
    164          DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
     169               ! 
    165170            DO jj = 1, ipj_s(jf) 
    166                js = js + 1 
    167                DO jl = 1, ipl 
    168                   DO jk = 1, ipk 
    169                      znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 
    170                   END DO 
    171                END DO 
     171               ij1 = ij1 + 1 
     172               jj_b(jj,jf) = ij1 
     173               jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012 
    172174            END DO 
     175            ! 
    173176         END DO 
    174177         ! 
    175          ibuffsize = jpimax * ipf_j * ipk * ipl 
    176          ! 
    177          ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 
    178          ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) )  
    179          ! when some processors of the north fold are suppressed,  
    180          ! values of ztab* arrays corresponding to these suppressed domain won't be defined  
    181          ! and we need a default definition to 0. 
    182          ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 
    183          IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 
     178         ALLOCATE( ztabb(jpimax,ipj_b,ipk,ipl) )   ! store all the data to be sent in a buffer array 
     179         ibuffsize = jpimax * ipj_b * ipk * ipl 
     180         ! 
     181         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk 
     182            DO jj = 1, ipj_s(jf) 
     183               ij1 = jj_b(jj,jf) 
     184               ij2 = jj_s(jj,jf) 
     185               DO ji = 1, jpi 
     186                  ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 
     187               END DO 
     188               DO ji = jpi+1, jpimax 
     189                  ztabb(ji,ij1,jk,jl) = HUGEVAL(0.)   ! avoid sending uninitialized values (make sure we don't use it) 
     190               END DO 
     191            END DO 
     192         END DO   ;   END DO   ;   END DO 
    184193         ! 
    185194         ! start waiting time measurement 
    186195         IF( ln_timing ) CALL tic_tac(.TRUE.) 
    187196         ! 
     197         ! send the data as soon as possible 
    188198         DO jr = 1, nsndto 
    189             IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    190                CALL SENDROUTINE( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
     199            iproc = nfproc(isendto(jr)) 
     200            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
     201               CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 
    191202            ENDIF 
    192203         END DO 
    193204         ! 
     205         ipimax = jpimax * jpmaxngh 
     206         ALLOCATE( ztabw(jpimax,ipj_b,ipk,ipl), ztabr(ipimax,ipj_b,ipk,ipl) )  
     207         ! 
     208         DO jr = 1, nsndto 
     209            ! 
     210            ipni  = isendto(jr) 
     211            iproc = nfproc(ipni) 
     212            ipi   = nfjpi (ipni) 
     213            ! 
     214            IF( ipni ==   1  ) THEN   ;   iis0 =   1            ! domain  left side: as e-w comm already done -> from 1st column 
     215            ELSE                      ;   iis0 =   1 + nn_hls   ! default: -> from inner domain  
     216            ENDIF 
     217            IF( ipni == jpni ) THEN   ;   iie0 = ipi            ! domain right side: as e-w comm already done -> until last column 
     218            ELSE                      ;   iie0 = ipi - nn_hls   ! default: -> until inner domain  
     219            ENDIF 
     220            impp = nfimpp(ipni) - nfimpp(isendto(1)) 
     221            ! 
     222            IF(           iproc == -1 ) THEN   ! No neighbour (land proc that was suppressed) 
     223               ! 
     224               SELECT CASE ( kfillmode ) 
     225               CASE ( jpfillnothing )               ! no filling  
     226               CASE ( jpfillcopy    )               ! filling with inner domain values 
     227                  DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk 
     228                     DO jj = 1, ipj_s(jf) 
     229                        ij1 = jj_b(jj,jf) 
     230                        ij2 = jj_s(jj,jf) 
     231                        DO ji = iis0, iie0 
     232                           ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf)   ! chose to take the 1st iner domain point 
     233                        END DO 
     234                     END DO 
     235                  END DO   ;   END DO   ;   END DO 
     236               CASE ( jpfillcst     )               ! filling with constant value 
     237                  DO jl = 1, ipl   ;   DO jk = 1, ipk 
     238                     DO jj = 1, ipj_b 
     239                        DO ji = iis0, iie0 
     240                           ztabr(impp+ji,jj,jk,jl) = pfillval 
     241                        END DO 
     242                     END DO 
     243                  END DO   ;   END DO 
     244               END SELECT 
     245               ! 
     246            ELSE IF( iproc == narea-1 ) THEN   ! get data from myself! 
     247               ! 
     248               DO jf = 1, ipf   ;   DO jl = 1, ipl  ;   DO jk = 1, ipk 
     249                  DO jj = 1, ipj_s(jf) 
     250                     ij1 = jj_b(jj,jf) 
     251                     ij2 = jj_s(jj,jf) 
     252                     DO ji = iis0, iie0 
     253                        ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 
     254                     END DO 
     255                  END DO 
     256               END DO   ;   END DO   ;   END DO 
     257               ! 
     258            ELSE                               ! get data from a neighbour trough communication 
     259               !   
     260               CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 
     261               DO jl = 1, ipl   ;   DO jk = 1, ipk 
     262                  DO jj = 1, ipj_b 
     263                     DO ji = iis0, iie0 
     264                        ztabr(impp+ji,jj,jk,jl) = ztabw(ji,jj,jk,jl) 
     265                     END DO 
     266                  END DO 
     267               END DO   ;   END DO 
     268                
     269            ENDIF 
     270            ! 
     271         END DO   ! nsndto 
     272         ! 
     273         IF( ln_timing ) CALL tic_tac(.FALSE.) 
     274         ! 
     275         ! North fold boundary condition 
     276         ! 
     277         DO jf = 1, ipf 
     278            ij1 = jj_b(       1 ,jf) 
     279            ij2 = jj_b(ipj_s(jf),jf) 
     280            CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat LBC_ARG, psgn LBC_ARG ) 
     281         END DO 
     282         ! 
     283         DEALLOCATE( ztabr, ztabw, jj_s, jj_b, ipj_s ) 
     284         ! 
    194285         DO jr = 1,nsndto 
    195             iproc = nfipproc(isendto(jr),jpnj) 
    196             IF(iproc /= -1) THEN 
    197                iilb = nimppt(iproc+1) 
    198                ilci = nlcit (iproc+1) 
    199                ildi = nldit (iproc+1) 
    200                ilei = nleit (iproc+1) 
    201                IF( iilb            ==      1 )   ildi = 1      ! e-w boundary already done -> force to take 1st column 
    202                IF( iilb + ilci - 1 == jpiglo )   ilei = ilci   ! e-w boundary already done -> force to take last column 
    203                iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
    204             ENDIF 
     286            iproc = nfproc(isendto(jr)) 
    205287            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    206                CALL RECVROUTINE(5, zfoldwk, ibuffsize, iproc) 
    207                js = 0 
    208                DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 
    209                   js = js + 1 
    210                   DO jl = 1, ipl 
    211                      DO jk = 1, ipk 
    212                         DO ji = ildi, ilei 
    213                            ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 
    214                         END DO 
    215                      END DO 
    216                   END DO 
    217                END DO; END DO 
    218             ELSE IF( iproc == narea-1 ) THEN 
    219                DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 
    220                   DO jl = 1, ipl 
    221                      DO jk = 1, ipk 
    222                         DO ji = ildi, ilei 
    223                            ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 
    224                         END DO 
    225                      END DO 
    226                   END DO 
    227                END DO; END DO 
     288               CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )   ! put the wait at the very end just before the deallocate 
    228289            ENDIF 
    229290         END DO 
    230          DO jr = 1,nsndto 
    231             IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    232                CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 
    233             ENDIF 
    234          END DO 
    235          ! 
    236          IF( ln_timing ) CALL tic_tac(.FALSE.) 
    237          ! 
    238          ! North fold boundary condition 
    239          ! 
    240          DO jf = 1, ipf 
    241             CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 
    242          END DO 
    243          ! 
    244          DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) 
     291         DEALLOCATE( ztabb ) 
    245292         ! 
    246293      ELSE                             !==  allgather exchanges  ==! 
    247294         ! 
    248          ipj   = 4            ! 2nd dimension of message transfers (last j-lines) 
    249          ! 
    250          ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 
    251          ! 
    252          DO jf = 1, ipf                ! put in znorthloc the last ipj j-lines of ptab 
    253             DO jl = 1, ipl 
    254                DO jk = 1, ipk 
    255                   DO jj = nlcj - ipj +1, nlcj 
    256                      ij = jj - nlcj + ipj 
    257                      znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 
    258                   END DO 
     295         ! how many lines do we exchange at max? -> ipj    (no further optimizations in this case...) 
     296         ipj =      nn_hls + 2 
     297         ! how many lines do we     need at max? -> ipj2   (no further optimizations in this case...) 
     298         ipj2 = 2 * nn_hls + 2 
     299         ! 
     300         i0max = jpimax - 2 * nn_hls 
     301         ibuffsize = i0max * ipj * ipk * ipl * ipf 
     302         ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) 
     303         ! 
     304         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk               ! put in znorthloc ipj j-lines of ptab 
     305            DO jj = 1, ipj 
     306               ij2 = jpj - ipj2 + jj                        ! the first ipj lines of the last ipj2 lines 
     307               DO ji = 1, Ni_0 
     308                  ii2 = Nis0 - 1 + ji                       ! inner domain: Nis0 to Nie0 
     309                  znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) 
     310               END DO 
     311               DO ji = Ni_0+1, i0max 
     312                  znorthloc(ji,jj,jk,jl,jf) = HUGEVAL(0.)   ! avoid sending uninitialized values (make sure we don't use it) 
    259313               END DO 
    260314            END DO 
    261          END DO 
    262          ! 
    263          ibuffsize = jpimax * ipj * ipk * ipl * ipf 
    264          ! 
    265          ALLOCATE( ztab       (jpiglo,ipj,ipk,ipl,ipf     ) ) 
    266          ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 
    267          ! 
    268          ! when some processors of the north fold are suppressed, 
    269          ! values of ztab* arrays corresponding to these suppressed domain won't be defined 
    270          ! and we need a default definition to 0. 
    271          ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 
    272          IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 
     315         END DO   ;   END DO   ;   END DO 
    273316         ! 
    274317         ! start waiting time measurement 
    275318         IF( ln_timing ) CALL tic_tac(.TRUE.) 
    276          CALL MPI_ALLGATHER( znorthloc  , ibuffsize, MPI_TYPE,                & 
    277             &                znorthgloio, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 
    278          ! 
     319#if defined key_mpp_mpi 
     320         CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr ) 
     321#endif 
    279322         ! stop waiting time measurement 
    280323         IF( ln_timing ) CALL tic_tac(.FALSE.) 
    281          ! 
    282          DO jr = 1, ndim_rank_north         ! recover the global north array 
    283             iproc = nrank_north(jr) + 1 
    284             iilb  = nimppt(iproc) 
    285             ilci  = nlcit (iproc) 
    286             ildi  = nldit (iproc) 
    287             ilei  = nleit (iproc) 
    288             IF( iilb            ==      1 )   ildi = 1      ! e-w boundary already done -> force to take 1st column 
    289             IF( iilb + ilci - 1 == jpiglo )   ilei = ilci   ! e-w boundary already done -> force to take last column 
    290             DO jf = 1, ipf 
    291                DO jl = 1, ipl 
    292                   DO jk = 1, ipk 
     324         DEALLOCATE( znorthloc ) 
     325         ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) ) 
     326         ! 
     327         ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines 
     328         ijnr = 0 
     329         DO jr = 1, jpni                                                        ! recover the global north array 
     330            iproc = nfproc(jr) 
     331            impp  = nfimpp(jr) 
     332            ipi   = nfjpi( jr) - 2 * nn_hls                       ! corresponds to Ni_0 but for subdomain iproc 
     333            IF( iproc == -1 ) THEN   ! No neighbour (land proc that was suppressed) 
     334              ! 
     335               SELECT CASE ( kfillmode ) 
     336               CASE ( jpfillnothing )               ! no filling  
     337               CASE ( jpfillcopy    )               ! filling with inner domain values 
     338                  DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk 
    293339                     DO jj = 1, ipj 
    294                         DO ji = ildi, ilei 
    295                            ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr) 
     340                        ij2 = jpj - ipj2 + jj                    ! the first ipj lines of the last ipj2 lines 
     341                        DO ji = 1, ipi 
     342                           ii1 = impp + nn_hls + ji - 1          ! corresponds to mig(nn_hls + ji) but for subdomain iproc 
     343                           ztabglo(ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf)   ! chose to take the 1st iner domain point 
    296344                        END DO 
    297345                     END DO 
     346                  END DO   ;   END DO   ;   END DO 
     347               CASE ( jpfillcst     )               ! filling with constant value 
     348                  DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk 
     349                     DO jj = 1, ipj 
     350                        DO ji = 1, ipi 
     351                           ii1 = impp + nn_hls + ji - 1          ! corresponds to mig(nn_hls + ji) but for subdomain iproc 
     352                           ztabglo(ii1,jj,jk,jl,jf) = pfillval 
     353                        END DO 
     354                     END DO 
     355                 END DO   ;   END DO   ;   END DO 
     356               END SELECT 
     357               ! 
     358            ELSE 
     359               ijnr = ijnr + 1 
     360               DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk 
     361                  DO jj = 1, ipj 
     362                     DO ji = 1, ipi 
     363                        ii1 = impp + nn_hls + ji - 1             ! corresponds to mig(nn_hls + ji) but for subdomain iproc 
     364                        ztabglo(ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr) 
     365                     END DO 
    298366                  END DO 
     367               END DO   ;   END DO   ;   END DO 
     368            ENDIF 
     369            ! 
     370         END DO   ! jpni 
     371         DEALLOCATE( znorthglo ) 
     372         ! 
     373         DO jf = 1, ipf 
     374            CALL lbc_nfd( ztabglo(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition 
     375            DO jl = 1, ipl   ;   DO jk = 1, ipk                  ! e-w periodicity 
     376               DO jj = 1, nn_hls + 1 
     377                  ij1 = ipj2 - (nn_hls + 1) + jj                 ! need only the last nn_hls + 1 lines until ipj2 
     378                  ztabglo(              1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf) 
     379                  ztabglo(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo(         nn_hls+1:     2*nn_hls,ij1,jk,jl,jf) 
     380               END DO 
     381            END DO   ;   END DO 
     382         END DO      
     383         ! 
     384         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk               ! Scatter back to ARRAY_IN 
     385            DO jj = 1, nn_hls + 1 
     386               ij1 = jpj  - (nn_hls + 1) + jj   ! last nn_hls + 1 lines until jpj 
     387               ij2 = ipj2 - (nn_hls + 1) + jj   ! last nn_hls + 1 lines until ipj2 
     388               DO ji= 1, jpi 
     389                  ii2 = mig(ji) 
     390                  ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf) 
    299391               END DO 
    300392            END DO 
    301          END DO 
    302          DO jf = 1, ipf 
    303             CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition 
    304          END DO 
    305          ! 
    306          DO jf = 1, ipf 
    307             DO jl = 1, ipl 
    308                DO jk = 1, ipk 
    309                   DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN 
    310                      ij = jj - nlcj + ipj 
    311                      DO ji= 1, nlci 
    312                         ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf) 
    313                      END DO 
    314                   END DO 
    315                END DO 
    316             END DO 
    317          END DO 
    318          ! 
    319       ! 
    320          DEALLOCATE( ztab ) 
    321          DEALLOCATE( znorthgloio ) 
    322       ENDIF 
    323       ! 
    324       DEALLOCATE( znorthloc ) 
     393         END DO   ;   END DO   ;   END DO 
     394         ! 
     395         DEALLOCATE( ztabglo ) 
     396         ! 
     397      ENDIF   ! l_north_nogather 
    325398      ! 
    326399   END SUBROUTINE ROUTINE_NFD 
    … …  
    338411#undef F_SIZE 
    339412#undef LBC_ARG 
     413#undef HUGEVAL 
Note: See TracChangeset for help on using the changeset viewer.