Changeset 11719


Ignore:
Timestamp:
2019-10-18T12:52:29+02:00 (11 months ago)
Author:
francesca
Message:

add extra halo support- ticket #2009

Location:
NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src
Files:
12 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/lbc_lnk_multi_generic.h90

    r11692 r11719  
    1919      &                    , pt5, cdna5, psgn5, pt6 , cdna6 , psgn6 , pt7 , cdna7 , psgn7 , pt8, cdna8, psgn8   & 
    2020      &                    , pt9, cdna9, psgn9, pt10, cdna10, psgn10, pt11, cdna11, psgn11                      & 
    21       &                    , kfillmode, pfillval, lsend, lrecv, ihlcom ) 
     21      &                    , kfillmode, pfillval, lsend, lrecv ) 
    2222      !!--------------------------------------------------------------------- 
    2323      CHARACTER(len=*)   ,                   INTENT(in   ) :: cdname  ! name of the calling subroutine 
     
    3131      REAL(wp)           , OPTIONAL        , INTENT(in   ) :: pfillval    ! background value (used at closed boundaries) 
    3232      LOGICAL, DIMENSION(4), OPTIONAL      , INTENT(in   ) :: lsend, lrecv   ! indicate how communications are to be carried out 
    33       INTEGER            , OPTIONAL        , INTENT(in   ) :: ihlcom         ! number of ranks and rows to be communicated 
    3433      !! 
    3534      INTEGER                          ::   kfld        ! number of elements that will be attributed 
     
    5655      IF( PRESENT(psgn11) )   CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) 
    5756      ! 
    58       CALL lbc_lnk_ptr    ( cdname,               ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 
     57      CALL lbc_lnk_ptr    ( cdname,               ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv ) 
    5958      ! 
    6059   END SUBROUTINE ROUTINE_MULTI 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r11692 r11719  
    4444#      define L_SIZE(ptab)          SIZE(ptab,4) 
    4545#   endif 
    46 #   define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k,l) 
    4746#   define J_SIZE(ptab2)             SIZE(ptab2,2) 
     47#   define ARRAY2_IN(i,j,k,l,f)   ptab2(i,j,k,l) 
    4848#   define ARRAY_TYPE(i,j,k,l,f)     REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
    4949#   define ARRAY2_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 
     
    5757      !! 
    5858      !!---------------------------------------------------------------------- 
    59       ARRAY_TYPE(:,:,:,:,:)                             ! array or pointer of arrays on which the boundary condition is applied 
    60       ARRAY2_TYPE(:,:,:,:,:)                            ! array or pointer of arrays on which the boundary condition is applied 
     59      ARRAY_TYPE(1-nn_hls+1:,1-nn_hls+1:,:,:,:) 
     60      ARRAY2_TYPE(1-nn_hls+1:,:,:,:,:)  
    6161      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    6262      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
    6363      INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    6464      ! 
    65       INTEGER  ::    ji,  jj,   jk,     jl,   jh,  jf   ! dummy loop indices 
    66       INTEGER  ::   ipi, ipj,  ipk,    ipl,  ipf        ! dimension of the input array 
    67       INTEGER  ::   ijt, iju, ijpj, ijpjp1, ijta, ijua, jia, startloop, endloop 
     65      INTEGER  ::    ji,  jj,   jk, jn, ii,   jl,   jh,  jf   ! dummy loop indices 
     66      INTEGER  ::   ipi, ipj,  ipk,    ipl,  ipf, ijj   ! dimension of the input array 
     67      INTEGER  ::   ijt, iju, ijta, ijua, jia, startloop, endloop 
    6868      LOGICAL  ::   l_fast_exchanges 
    6969      !!---------------------------------------------------------------------- 
     
    7575      ! Security check for further developments 
    7676      IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 
    77       ! 
    78       ijpj   = 1    ! index of first modified line  
    79       ijpjp1 = 2    ! index + 1 
    80        
    8177      ! 2nd dimension determines exchange speed 
    8278      IF (ipj == 1 ) THEN 
     
    9591            ! 
    9692            CASE ( 'T' , 'W' )                         ! T-, W-point 
    97                IF ( nimpp /= 1 ) THEN   ;   startloop = 1 
     93               IF ( nimpp - nn_hls+1 /= 1 ) THEN  ;  startloop = 1 - nn_hls + 1 
    9894               ELSE                     ;   startloop = 2 
    9995               ENDIF 
    10096               ! 
    10197               DO jl = 1, ipl; DO jk = 1, ipk 
    102                   DO ji = startloop, nlci 
    103                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    104                      ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 
    105                   END DO 
    106                END DO; END DO 
    107                IF( nimpp == 1 ) THEN 
    108                   DO jl = 1, ipl; DO jk = 1, ipk 
    109                      ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf) 
    110                   END DO; END DO 
    111                ENDIF 
    112                ! 
    113                IF ( .NOT. l_fast_exchanges ) THEN 
    114                   IF( nimpp >= jpiglo/2+1 ) THEN 
    115                      startloop = 1 
    116                   ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    117                      startloop = jpiglo/2+1 - nimpp + 1 
     98                    DO jj = 1, nn_hls 
     99                     ijj = nlcj -jj +1 
     100                     DO ji = startloop, nlci 
     101                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     102                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
     103                    END DO 
     104                  END DO 
     105               END DO; END DO 
     106               IF( nimpp - nn_hls+1 == 1 ) THEN 
     107                  DO jl = 1, ipl; DO jk = 1, ipk 
     108                     DO jj = 1, nn_hls 
     109                        ijj = nlcj -jj +1 
     110                        DO ii = 1, nn_hls 
     111                           ARRAY_IN(1-ii+1,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii+2,nlcj-2*nn_hls+jj-1,jk,jl,jf) 
     112                        END DO 
     113                     END DO 
     114                  END DO; END DO 
     115               ENDIF               
     116               ! 
     117               IF ( .NOT. l_fast_exchanges ) THEN 
     118                  IF( nimpp - nn_hls +1 >= jpiglo/2+1 ) THEN 
     119                     startloop = 1 - nn_hls +1 
     120                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp - nn_hls +1 < jpiglo/2+1 ) THEN 
     121                     startloop = jpiglo/2+1 - nimpp + nn_hls 
    118122                  ELSE 
    119123                     startloop = nlci + 1 
     
    126130                           ijta = jpiglo - jia + 2 
    127131                           IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
    128                               ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf) 
     132                              ARRAY_IN(ji,nlcj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-nn_hls,jk,jl,jf) 
    129133                           ELSE 
    130                               ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 
     134                              ARRAY_IN(ji,nlcj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 
    131135                           ENDIF 
    132136                        END DO 
     
    134138                  ENDIF 
    135139               ENDIF 
    136  
     140            CASE ( 'U' )                                     ! U-point 
     141               IF( nimpp + nlci - nn_hls /= jpiglo ) THEN 
     142                  endloop = nlci 
     143               ELSE 
     144                  endloop = nlci - nn_hls 
     145               ENDIF 
     146               DO jl = 1, ipl; DO jk = 1, ipk 
     147              DO jj = 1, nn_hls 
     148                     ijj = nlcj -jj +1 
     149                     DO ji = 1-nn_hls+1, endloop 
     150                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     151                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 
     152                     END DO 
     153                  END DO 
     154               END DO; END DO 
     155               IF (nimpp - nn_hls+1 .eq. 1) THEN 
     156               DO jj = 1, nn_hls 
     157                  ijj = nlcj -jj +1 
     158                  DO ii = 1, nn_hls 
     159                     ARRAY_IN(2-ii,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ii+1,nlcj-2*nn_hls+jj-1,:,:,jf) 
     160                  END DO 
     161                     END DO 
     162               ENDIF 
     163               IF((nimpp + nlci - nn_hls) .eq. jpiglo) THEN 
     164                     DO jj = 1, nn_hls 
     165                        ijj = nlcj -jj +1 
     166                  DO ii = 1, nn_hls 
     167                     ARRAY_IN(nlci-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2*nn_hls+ii,nlcj-2*nn_hls+jj-1,:,:,jf) 
     168                  END DO 
     169               END DO 
     170               ENDIF 
     171               ! 
     172               IF ( .NOT. l_fast_exchanges ) THEN 
     173                  IF( nimpp + nlci - nn_hls /= jpiglo ) THEN 
     174                     endloop = nlci 
     175                  ELSE 
     176                     endloop = nlci - nn_hls 
     177                  ENDIF 
     178                  IF( nimpp - nn_hls+1 >= jpiglo/2 ) THEN 
     179                     startloop = 1- nn_hls + 1 
     180                     ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp - nn_hls+1 < jpiglo/2 ) ) THEN 
     181                     startloop = jpiglo/2 - nimpp + nn_hls 
     182                  ELSE 
     183                     startloop = endloop + 1 
     184                  ENDIF 
     185                  IF( startloop <= endloop ) THEN 
     186                  DO jl = 1, ipl; DO jk = 1, ipk 
     187                     DO ji = startloop, endloop 
     188                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     189                        jia = ji + nimpp - 1 
     190                        ijua = jpiglo - jia + 1 
     191                        IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
     192                           ARRAY_IN(ji,nlcj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-nn_hls,jk,jl,jf) 
     193                        ELSE 
     194                           ARRAY_IN(ji,nlcj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 
     195                        ENDIF 
     196                     END DO 
     197                  END DO; END DO 
     198                  ENDIF 
     199               ENDIF 
     200               ! 
     201            CASE ( 'V' )                                     ! V-point 
     202               IF( nimpp - nn_hls+1 /= 1 ) THEN 
     203                 startloop = 1 - nn_hls + 1 
     204               ELSE 
     205                 startloop = 2 
     206               ENDIF 
     207               IF ( .NOT. l_fast_exchanges ) THEN 
     208                  DO jl = 1, ipl; DO jk = 1, ipk 
     209                     DO jj = 2, nn_hls+1 
     210                        ijj = nlcj -jj +1 
     211                        DO ji = startloop, nlci 
     212                           ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     213                           ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
     214                        END DO 
     215                    END DO 
     216                  END DO; END DO 
     217               ENDIF 
     218               DO jl = 1, ipl; DO jk = 1, ipk 
     219                  DO ji = startloop, nlci 
     220                     ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     221                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf) 
     222                  END DO 
     223               END DO; END DO 
     224               IF (nimpp - nn_hls+1.eq. 1) THEN 
     225               DO jj = 1, nn_hls 
     226                        ijj = nlcj-jj+1 
     227                        DO ii = 1, nn_hls 
     228                        ARRAY_IN(1-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ii+2,nlcj-2*nn_hls+jj-1,:,:,jf) 
     229                  END DO 
     230               END DO 
     231               ENDIF 
     232            CASE ( 'F' )                                     ! F-point 
     233               IF( nimpp + nlci - nn_hls /= jpiglo ) THEN 
     234                  endloop = nlci 
     235               ELSE 
     236                  endloop = nlci - nn_hls 
     237               ENDIF 
     238               IF ( .NOT. l_fast_exchanges ) THEN 
     239                  DO jl = 1, ipl; DO jk = 1, ipk 
     240                     DO jj = 2, nn_hls+1 
     241                        ijj = nlcj -jj +1 
     242                        DO ji = 1 - nn_hls +1, endloop 
     243                           iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     244                           ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 
     245                        END DO 
     246                    END DO 
     247                  END DO; END DO 
     248               ENDIF 
     249               DO jl = 1, ipl; DO jk = 1, ipk 
     250                  DO ji = 1- nn_hls +1, endloop 
     251                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     252                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf) 
     253                  END DO 
     254               END DO; END DO 
     255      IF (nimpp - nn_hls+1.eq. 1) THEN                
     256         DO ii = 1, nn_hls 
     257                     ARRAY_IN(2-ii,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ii+1,nlcj-2*nn_hls-1,:,:,jf) 
     258         END DO 
     259         IF ( .NOT. l_fast_exchanges ) THEN 
     260            DO jj = 1, nn_hls 
     261                           ijj = nlcj -jj 
     262                           DO ii = 1, nn_hls 
     263                           ARRAY_IN(2-ii,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ii+1,nlcj-2*nn_hls+jj-1,:,:,jf) 
     264                              END DO 
     265                        END DO 
     266                     ENDIF 
     267      ENDIF 
     268      IF((nimpp + nlci - nn_hls ) .eq. jpiglo) THEN 
     269                     DO ii = 1, nn_hls 
     270                     ARRAY_IN(nlci-ii+1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2*nn_hls+ii,nlcj-2*nn_hls-1,:,:,jf) 
     271         END DO 
     272         IF ( .NOT. l_fast_exchanges ) THEN 
     273            DO jj = 1, nn_hls 
     274                           ijj = nlcj -jj 
     275                           DO ii = 1, nn_hls 
     276                           ARRAY_IN(nlci-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2*nn_hls+ii,nlcj-2*nn_hls+jj-1,:,:,jf) 
     277                           END DO 
     278                        END DO 
     279                     ENDIF 
     280                  ENDIF 
     281                  ! 
     282       END SELECT 
     283            ! 
     284         CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
     285            ! 
     286            WRITE(*,*) 'extrahalo not handled in this case', __FILE__, __LINE__ 
     287            SELECT CASE ( NAT_IN(jf) ) 
     288            CASE ( 'T' , 'W' )                               ! T-, W-point 
     289               DO jl = 1, ipl; DO jk = 1, ipk 
     290              DO jj = 1, nn_hls 
     291                      ijj = nlcj -jj+1 
     292                  DO ji = 1, nlci 
     293                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     294                     ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
     295                  END DO 
     296              END DO 
     297               END DO; END DO 
     298               ! 
    137299            CASE ( 'U' )                                     ! U-point 
    138300               IF( nimpp + nlci - 1 /= jpiglo ) THEN 
     
    143305               DO jl = 1, ipl; DO jk = 1, ipk 
    144306                  DO ji = 1, endloop 
    145                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    146                      ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 
    147                   END DO 
    148                END DO; END DO 
    149                IF (nimpp .eq. 1) THEN 
    150                   ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 
    151                ENDIF 
     307                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
     308                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-1,jk,jl,jf) 
     309                  END DO 
     310               END DO; END DO 
    152311               IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    153                   ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 
    154                ENDIF 
    155                ! 
    156                IF ( .NOT. l_fast_exchanges ) THEN 
    157                   IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    158                      endloop = nlci 
    159                   ELSE 
    160                      endloop = nlci - 1 
    161                   ENDIF 
    162                   IF( nimpp >= jpiglo/2 ) THEN 
    163                      startloop = 1 
    164                      ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 
    165                      startloop = jpiglo/2 - nimpp + 1 
    166                   ELSE 
    167                      startloop = endloop + 1 
    168                   ENDIF 
    169                   IF( startloop <= endloop ) THEN 
    170                   DO jl = 1, ipl; DO jk = 1, ipk 
    171                      DO ji = startloop, endloop 
    172                         iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    173                         jia = ji + nimpp - 1 
    174                         ijua = jpiglo - jia + 1 
    175                         IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
    176                            ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf) 
    177                         ELSE 
    178                            ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 
    179                         ENDIF 
    180                      END DO 
    181                   END DO; END DO 
    182                   ENDIF 
     312                  DO jl = 1, ipl; DO jk = 1, ipk 
     313                     ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf) 
     314                  END DO; END DO 
    183315               ENDIF 
    184316               ! 
    185317            CASE ( 'V' )                                     ! V-point 
    186                IF( nimpp /= 1 ) THEN 
    187                  startloop = 1 
    188                ELSE 
    189                  startloop = 2 
    190                ENDIF 
    191                IF ( .NOT. l_fast_exchanges ) THEN 
    192                   DO jl = 1, ipl; DO jk = 1, ipk 
    193                      DO ji = startloop, nlci 
    194                         ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    195                         ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 
    196                      END DO 
    197                   END DO; END DO 
    198                ENDIF 
    199                DO jl = 1, ipl; DO jk = 1, ipk 
    200                   DO ji = startloop, nlci 
    201                      ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    202                      ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 
    203                   END DO 
    204                END DO; END DO 
    205                IF (nimpp .eq. 1) THEN 
    206                   ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf) 
    207                ENDIF 
    208             CASE ( 'F' )                                     ! F-point 
    209                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    210                   endloop = nlci 
    211                ELSE 
    212                   endloop = nlci - 1 
    213                ENDIF 
    214                IF ( .NOT. l_fast_exchanges ) THEN 
    215                   DO jl = 1, ipl; DO jk = 1, ipk 
    216                      DO ji = 1, endloop 
    217                         iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    218                         ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 
    219                      END DO 
    220                   END DO; END DO 
    221                ENDIF 
    222                DO jl = 1, ipl; DO jk = 1, ipk 
    223                   DO ji = 1, endloop 
    224                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    225                      ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 
    226                   END DO 
    227                END DO; END DO 
    228                IF (nimpp .eq. 1) THEN 
    229                   ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf) 
    230                   IF ( .NOT. l_fast_exchanges ) & 
    231                      ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 
    232                ENDIF 
    233                IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    234                   ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf) 
    235                   IF ( .NOT. l_fast_exchanges ) & 
    236                      ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 
    237                ENDIF 
    238                ! 
    239             END SELECT 
    240             ! 
    241          CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    242             ! 
    243             SELECT CASE ( NAT_IN(jf) ) 
    244             CASE ( 'T' , 'W' )                               ! T-, W-point 
    245318               DO jl = 1, ipl; DO jk = 1, ipk 
    246319                  DO ji = 1, nlci 
    247320                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    248                      ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 
    249                   END DO 
    250                END DO; END DO 
    251                ! 
    252             CASE ( 'U' )                                     ! U-point 
    253                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    254                   endloop = nlci 
    255                ELSE 
    256                   endloop = nlci - 1 
    257                ENDIF 
    258                DO jl = 1, ipl; DO jk = 1, ipk 
    259                   DO ji = 1, endloop 
    260                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    261                      ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 
    262                   END DO 
    263                END DO; END DO 
    264                IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    265                   DO jl = 1, ipl; DO jk = 1, ipk 
    266                      ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf) 
    267                   END DO; END DO 
    268                ENDIF 
    269                ! 
    270             CASE ( 'V' )                                     ! V-point 
    271                DO jl = 1, ipl; DO jk = 1, ipk 
    272                   DO ji = 1, nlci 
    273                      ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    274                      ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 
     321                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-1,jk,jl,jf) 
    275322                  END DO 
    276323               END DO; END DO 
     
    288335                     DO ji = startloop, nlci 
    289336                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    290                         ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 
     337                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 
    291338                     END DO 
    292339                  END DO; END DO 
     
    303350                  DO ji = 1, endloop 
    304351                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    305                      ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 
     352                     ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-1,jk,jl,jf) 
    306353                  END DO 
    307354               END DO; END DO 
     
    329376                        DO ji = startloop, endloop 
    330377                           iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    331                            ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 
     378                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 
    332379                        END DO 
    333380                     END DO; END DO 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/lbcnfd.F90

    r11692 r11719  
    5353 
    5454   INTEGER, PUBLIC, PARAMETER            ::   jpmaxngh = 3               !: 
    55    INTEGER, PUBLIC                       ::   nsndto, nfsloop, nfeloop   !: 
     55   INTEGER, PUBLIC                       ::   nsndto                     !: 
    5656   INTEGER, PUBLIC, DIMENSION (jpmaxngh) ::   isendto                    !: processes to which communicate 
     57   INTEGER, PUBLIC                       ::   ijpj              
    5758 
    5859   !!---------------------------------------------------------------------- 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/mpp_lnk_generic.h90

    r11692 r11719  
    4646 
    4747#if defined MULTI 
    48    SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) 
     48   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv ) 
    4949      INTEGER             , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    5050#else 
    51    SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , kfillmode, pfillval, lsend, lrecv, ihlcom ) 
     51   SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn      , kfillmode, pfillval, lsend, lrecv ) 
    5252#endif 
    53       ARRAY_TYPE(:,:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied 
     53      ARRAY_TYPE(1-nn_hls+1:,1-nn_hls+1:,:,:,:)                                        ! array or pointer of arrays on which the boundary condition is applied 
    5454      CHARACTER(len=*)              , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    5555      CHARACTER(len=1)              , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
     
    5858      REAL(wp),             OPTIONAL, INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
    5959      LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in   ) ::   lsend, lrecv  ! communication with other 4 proc 
    60       INTEGER              ,OPTIONAL, INTENT(in   ) ::   ihlcom        ! number of ranks and rows to be communicated 
    6160      ! 
    6261      INTEGER  ::    ji,  jj,  jk,  jl,  jf      ! dummy loop indices 
     
    6665      INTEGER  ::   ierr 
    6766      INTEGER  ::   ifill_we, ifill_ea, ifill_so, ifill_no 
    68       INTEGER  ::   ihl                          ! number of ranks and rows to be communicated  
    6967      REAL(wp) ::   zland 
    7068      INTEGER , DIMENSION(MPI_STATUS_SIZE)        ::   istat          ! for mpi_isend 
     
    8381      ipl = L_SIZE(ptab)   ! 4th    - 
    8482      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    85       ! 
    86       IF( PRESENT(ihlcom) ) THEN   ;   ihl = ihlcom 
    87       ELSE                         ;   ihl = 1 
    88       END IF 
    8983      ! 
    9084      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) 
     
    148142      ! -------------------------------------------------- ! 
    149143      ! 
     144 
    150145      ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg 
    151       isize = ihl * jpj * ipk * ipl * ipf       
     146      isize = nn_hls * ( jpj + nn_hls - 1 ) * ipk * ipl * ipf       
    152147      ! 
    153148      ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent 
    154       IF( llsend_we )   ALLOCATE( zsnd_we(ihl,jpj,ipk,ipl,ipf) ) 
    155       IF( llsend_ea )   ALLOCATE( zsnd_ea(ihl,jpj,ipk,ipl,ipf) ) 
    156       IF( llrecv_we )   ALLOCATE( zrcv_we(ihl,jpj,ipk,ipl,ipf) ) 
    157       IF( llrecv_ea )   ALLOCATE( zrcv_ea(ihl,jpj,ipk,ipl,ipf) ) 
     149      IF( llsend_we )   ALLOCATE( zsnd_we(nn_hls,1-nn_hls+1:jpj,ipk,ipl,ipf) ) 
     150      IF( llsend_ea )   ALLOCATE( zsnd_ea(nn_hls,1-nn_hls+1:jpj,ipk,ipl,ipf) ) 
     151      IF( llrecv_we )   ALLOCATE( zrcv_we(nn_hls,1-nn_hls+1:jpj,ipk,ipl,ipf) ) 
     152      IF( llrecv_ea )   ALLOCATE( zrcv_ea(nn_hls,1-nn_hls+1:jpj,ipk,ipl,ipf) ) 
    158153      ! 
    159154      IF( llsend_we ) THEN   ! copy western side of the inner mpi domain in local temporary array to be sent by MPI 
    160          ishift = ihl 
    161          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
    162             zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! ihl + 1 -> 2*ihl 
    163          END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
    164       ENDIF 
    165       ! 
    166       IF(llsend_ea ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 
    167          ishift = jpi - 2 * ihl 
    168          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
    169             zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! jpi - 2*ihl + 1 -> jpi - ihl 
     155         ishift = 1 
     156         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1-nn_hls+1, jpj   ;   DO ji = 1, nn_hls 
     157            zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! nn_hls + 1 -> 2*nn_hls 
     158         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
     159      ENDIF 
     160      ! 
     161      IF( llsend_ea ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 
     162         ishift = jpi -  2 * nn_hls 
     163         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1-nn_hls+1, jpj   ;   DO ji = 1, nn_hls 
     164            zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf)   ! jpi - 2*nn_hls + 1 -> jpi - nn_hls 
    170165         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
    171166      ENDIF 
     
    174169      ! 
    175170      ! non-blocking send of the western/eastern side using local temporary arrays 
    176       IF( llsend_we )   CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) 
    177       IF( llsend_ea )   CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) 
     171      IF( llsend_we )   CALL mppsend( 1, zsnd_we(1,1-nn_hls+1,1,1,1), isize, nowe, ireq_we ) 
     172      IF( llsend_ea )   CALL mppsend( 2, zsnd_ea(1,1-nn_hls+1,1,1,1), isize, noea, ireq_ea ) 
    178173      ! blocking receive of the western/eastern halo in local temporary arrays 
    179       IF( llrecv_we )   CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe ) 
    180       IF( llrecv_ea )   CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea ) 
     174      IF( llrecv_we )   CALL mpprecv( 2, zrcv_we(1,1-nn_hls+1,1,1,1), isize, nowe ) 
     175      IF( llrecv_ea )   CALL mpprecv( 1, zrcv_ea(1,1-nn_hls+1,1,1,1), isize, noea ) 
    181176      ! 
    182177      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     
    189184      ! 2.1 fill weastern halo 
    190185      ! ---------------------- 
    191       ! ishift = 0                         ! fill halo from ji = 1 to ihl 
     186      ! ishift = 0                         ! fill halo from ji = 1 to nn_hls 
    192187      SELECT CASE ( ifill_we ) 
    193188      CASE ( jpfillnothing )               ! no filling  
    194189      CASE ( jpfillmpi   )                 ! use data received by MPI  
    195          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
    196             ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf)   ! 1 -> ihl 
     190         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1-nn_hls+1, jpj   ;   DO ji = 1, nn_hls 
     191            ARRAY_IN(ji-nn_hls+1,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf)   ! 1 -> nn_hls 
    197192         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
    198193      CASE ( jpfillperio )                 ! use east-weast periodicity 
    199          ishift2 = jpi - 2 * ihl 
    200          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
    201             ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 
     194         ishift2 = jpi - 2 * nn_hls 
     195         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1-nn_hls+1, jpj   ;   DO ji = 1, nn_hls 
     196            ARRAY_IN(ji-nn_hls+1,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 
    202197         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
    203198      CASE ( jpfillcopy  )                 ! filling with inner domain values 
    204199         DO jf = 1, ipf                               ! number of arrays to be treated 
    205200            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
    206                DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
    207                   ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) 
     201               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1-nn_hls+1, jpj   ;   DO ji = 1, nn_hls 
     202                  ARRAY_IN(ji-nn_hls+1,jj,jk,jl,jf) = ARRAY_IN(1+ji,jj,jk,jl,jf) 
    208203               END DO   ;   END DO   ;   END DO   ;   END DO 
    209204            ENDIF 
     
    212207         DO jf = 1, ipf                               ! number of arrays to be treated 
    213208            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
    214                DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
    215                   ARRAY_IN(ji,jj,jk,jl,jf) = zland 
     209               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1-nn_hls+1, jpj   ;   DO ji = 1, nn_hls 
     210                  ARRAY_IN(ji-nn_hls+1,jj,jk,jl,jf) = zland 
    216211               END DO;   END DO   ;   END DO   ;   END DO 
    217212            ENDIF 
     
    221216      ! 2.2 fill eastern halo 
    222217      ! --------------------- 
    223       ishift = jpi - ihl                ! fill halo from ji = jpi-ihl+1 to jpi  
     218      ishift = jpi - nn_hls                ! fill halo from ji = jpi-nn_hls+1 to jpi  
    224219      SELECT CASE ( ifill_ea ) 
    225220      CASE ( jpfillnothing )               ! no filling  
    226221      CASE ( jpfillmpi   )                 ! use data received by MPI  
    227          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
    228             ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf)   ! jpi - ihl + 1 -> jpi 
     222         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1-nn_hls+1, jpj   ;   DO ji = 1, nn_hls 
     223            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf)   ! jpi - nn_hls + 1 -> jpi 
    229224         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
    230225      CASE ( jpfillperio )                 ! use east-weast periodicity 
    231          ishift2 = ihl 
    232          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     226         ishift2 = 1 
     227         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1-nn_hls+1, jpj   ;   DO ji = 1, nn_hls 
    233228            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 
    234229         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
    235230      CASE ( jpfillcopy  )                 ! filling with inner domain values 
    236          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
    237             ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) 
     231       ishift2 = jpi - 2*nn_hls 
     232         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1-nn_hls+1, jpj   ;   DO ji = 1, nn_hls 
     233            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) 
    238234         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
    239235      CASE ( jpfillcst   )                 ! filling with constant value 
    240          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, jpj   ;   DO ji = 1, ihl 
     236         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1-nn_hls+1, jpj   ;   DO ji = 1, nn_hls 
    241237            ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland 
    242238         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
     
    264260      ! ---------------------------------------------------- ! 
    265261      ! 
    266       IF( llsend_so )   ALLOCATE( zsnd_so(jpi,ihl,ipk,ipl,ipf) ) 
    267       IF( llsend_no )   ALLOCATE( zsnd_no(jpi,ihl,ipk,ipl,ipf) ) 
    268       IF( llrecv_so )   ALLOCATE( zrcv_so(jpi,ihl,ipk,ipl,ipf) ) 
    269       IF( llrecv_no )   ALLOCATE( zrcv_no(jpi,ihl,ipk,ipl,ipf) ) 
    270       ! 
    271       isize = jpi * ihl * ipk * ipl * ipf       
     262      IF( llsend_so )   ALLOCATE( zsnd_so(1-nn_hls+1:jpi,nn_hls,ipk,ipl,ipf) ) 
     263      IF( llsend_no )   ALLOCATE( zsnd_no(1-nn_hls+1:jpi,nn_hls,ipk,ipl,ipf) ) 
     264      IF( llrecv_so )   ALLOCATE( zrcv_so(1-nn_hls+1:jpi,nn_hls,ipk,ipl,ipf) ) 
     265      IF( llrecv_no )   ALLOCATE( zrcv_no(1-nn_hls+1:jpi,nn_hls,ipk,ipl,ipf) ) 
     266      ! 
     267      isize = ( jpi + nn_hls - 1 ) * nn_hls * ipk * ipl * ipf       
    272268 
    273269      ! allocate local temporary arrays to be sent/received. Fill arrays to be sent 
    274270      IF( llsend_so ) THEN   ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI 
    275          ishift = ihl 
    276          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
    277             zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! ihl+1 -> 2*ihl 
     271         ishift = 1 
     272         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1-nn_hls+1, jpi 
     273            zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! nn_hls+1 -> 2*nn_hls 
    278274         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
    279275      ENDIF 
    280276      ! 
    281277      IF( llsend_no ) THEN   ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI 
    282          ishift = jpj - 2 * ihl 
    283          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
    284             zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! jpj-2*ihl+1 -> jpj-ihl 
     278         ishift = jpj - 2 * nn_hls 
     279         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1-nn_hls+1, jpi 
     280            zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf)   ! jpj-2*nn_hls+1 -> jpj-nn_hls 
    285281         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
    286282      ENDIF 
     
    289285      ! 
    290286      ! non-blocking send of the southern/northern side 
    291       IF( llsend_so )   CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) 
    292       IF( llsend_no )   CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) 
     287      IF( llsend_so )   CALL mppsend( 3, zsnd_so(1-nn_hls+1,1,1,1,1), isize, noso, ireq_so ) 
     288      IF( llsend_no )   CALL mppsend( 4, zsnd_no(1-nn_hls+1,1,1,1,1), isize, nono, ireq_no ) 
    293289      ! blocking receive of the southern/northern halo 
    294       IF( llrecv_so )   CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso ) 
    295       IF( llrecv_no )   CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono ) 
     290      IF( llrecv_so )   CALL mpprecv( 4, zrcv_so(1-nn_hls+1,1,1,1,1), isize, noso ) 
     291      IF( llrecv_no )   CALL mpprecv( 3, zrcv_no(1-nn_hls+1,1,1,1,1), isize, nono ) 
    296292      ! 
    297293      IF( ln_timing ) CALL tic_tac(.FALSE.) 
     
    303299      ! 5.1 fill southern halo 
    304300      ! ---------------------- 
    305       ! ishift = 0                         ! fill halo from jj = 1 to ihl 
     301      ! ishift = 0                         ! fill halo from jj = 1 to nn_hls 
    306302      SELECT CASE ( ifill_so ) 
    307303      CASE ( jpfillnothing )               ! no filling  
    308304      CASE ( jpfillmpi   )                 ! use data received by MPI  
    309          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
    310             ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf)   ! 1 -> ihl 
     305         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1-nn_hls+1, jpi 
     306            ARRAY_IN(ji,jj-nn_hls+1,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf)   ! 1 -> nn_hls 
    311307         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
    312308      CASE ( jpfillperio )                 ! use north-south periodicity 
    313          ishift2 = jpj - 2 * ihl 
    314          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
    315             ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 
     309         ishift2 = jpj - 2 * nn_hls 
     310         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1-nn_hls+1, jpi 
     311            ARRAY_IN(ji,jj-nn_hls+1,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 
    316312         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
    317313      CASE ( jpfillcopy  )                 ! filling with inner domain values 
    318314         DO jf = 1, ipf                               ! number of arrays to be treated 
    319315            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
    320                DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
    321                   ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) 
     316               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1-nn_hls+1, jpi 
     317                  ARRAY_IN(ji,jj-nn_hls+1,jk,jl,jf) = ARRAY_IN(ji,1+jj,jk,jl,jf) 
    322318               END DO   ;   END DO   ;   END DO   ;   END DO 
    323319            ENDIF 
     
    326322         DO jf = 1, ipf                               ! number of arrays to be treated 
    327323            IF( .NOT. NAT_IN(jf) == 'F' ) THEN        ! do nothing for F point 
    328                DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi  
    329                   ARRAY_IN(ji,jj,jk,jl,jf) = zland 
     324               DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1-nn_hls+1, jpi  
     325                  ARRAY_IN(ji,jj-nn_hls+1,jk,jl,jf) = zland 
    330326               END DO;   END DO   ;   END DO   ;   END DO 
    331327            ENDIF 
     
    335331      ! 5.2 fill northern halo 
    336332      ! ---------------------- 
    337       ishift = jpj - ihl                ! fill halo from jj = jpj-ihl+1 to jpj  
     333      ishift = jpj - nn_hls                ! fill halo from jj = jpj-nn_hls+1 to jpj  
    338334      SELECT CASE ( ifill_no ) 
    339335      CASE ( jpfillnothing )               ! no filling  
    340336      CASE ( jpfillmpi   )                 ! use data received by MPI  
    341          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
    342             ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf)   ! jpj-ihl+1 -> jpj 
     337         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1-nn_hls+1, jpi 
     338            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf)   ! jpj-nn_hls+1 -> jpj 
    343339         END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO 
    344340      CASE ( jpfillperio )                 ! use north-south periodicity 
    345          ishift2 = ihl 
    346          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     341         ishift2 = 1 
     342         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1-nn_hls+1, jpi 
    347343            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 
    348344         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
    349345      CASE ( jpfillcopy  )                 ! filling with inner domain values 
    350          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
    351             ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) 
     346          ishift2 = jpj - 2*nn_hls 
     347         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1-nn_hls+1, jpi 
     348            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) 
    352349         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
    353350      CASE ( jpfillcst   )                 ! filling with constant value 
    354          DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, ihl   ;   DO ji = 1, jpi 
     351         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk   ;   DO jj = 1, nn_hls   ;   DO ji = 1-nn_hls+1, jpi 
    355352            ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland 
    356353         END DO;   END DO   ;   END DO   ;   END DO   ;   END DO 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/mpp_nfd_generic.h90

    r11692 r11719  
    4848   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 
    4949      !!---------------------------------------------------------------------- 
    50       ARRAY_TYPE(:,:,:,:,:)   ! array or pointer of arrays on which the boundary condition is applied 
     50      ARRAY_TYPE(1-nn_hls+1:,1-nn_hls+1:,:,:,:)   ! 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 
     
    5454      ! 
    5555      INTEGER  ::   ji,  jj,  jk,  jl, jh, jf, jr   ! dummy loop indices 
    56       INTEGER  ::   ipi, ipj, ipk, ipl, ipf         ! dimension of the input array 
     56      INTEGER  ::   ipi, ipk, ipl, ipf         ! dimension of the input array 
    5757      INTEGER  ::   imigr, iihom, ijhom             ! local integers 
    5858      INTEGER  ::   ierr, ibuffsize, ilci, ildi, ilei, iilb 
     
    8080         ALLOCATE(ipj_s(ipf)) 
    8181 
    82          ipj      = 2            ! Max 2nd dimension of message transfers (last two j-line only) 
    83          ipj_s(:) = 1            ! Real 2nd dimension of message transfers (depending on perf requirement) 
     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) 
    8484                                 ! by default, only one line is exchanged 
    8585 
    86          ALLOCATE( jj_s(ipf,2) ) 
     86         ALLOCATE( jj_s(ipf,ijpj) ) 
    8787 
    8888         ! re-define number of exchanged lines : 
     
    9898         IF ( l_full_nf_update .OR.                          &    ! if coupling fields 
    9999              ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) &    ! at first time step, if not restart 
    100             ipj_s(:) = 2 
     100            ipj_s(:) = 2 + nn_hls - 1  
    101101 
    102102         ! Index of modifying lines in input 
     
    110110               ! 
    111111               CASE ( 'T' , 'W' ,'U' )                            ! T-, U-, W-point 
    112                   jj_s(jf,1) = nlcj - 2 ;  jj_s(jf,2) = nlcj - 1 
     112                     DO ji = 1, nn_hls+1 
     113                  jj_s(jf,ji) = nlcj - 2*nn_hls +ji -1 
     114               ENDDO 
    113115               CASE ( 'V' , 'F' )                                 ! V-, F-point 
    114                   jj_s(jf,1) = nlcj - 3 ;  jj_s(jf,2) = nlcj - 2 
     116               DO ji = 1, nn_hls+1 
     117                  jj_s(jf,ji) = nlcj - 2*nn_hls +ji - 2 
     118               ENDDO 
    115119               END SELECT 
    116120            ! 
     
    119123               ! 
    120124               CASE ( 'T' , 'W' ,'U' )                            ! T-, U-, W-point 
    121                   jj_s(jf,1) = nlcj - 1       
    122                   ipj_s(jf) = 1                  ! need only one line anyway 
     125               DO ji = 1, nn_hls 
     126                  jj_s(jf,ji) = nlcj - 2*nn_hls + ji      
     127               ENDDO 
     128               ipj_s(jf) = nn_hls                  ! need only one line anyway 
    123129               CASE ( 'V' , 'F' )                                 ! V-, F-point 
    124                   jj_s(jf,1) = nlcj - 2 ;  jj_s(jf,2) = nlcj - 1 
     130               DO ji = 1, nn_hls+1 
     131                  jj_s(jf,ji) = nlcj - 2*nn_hls +ji -1 
     132               ENDDO 
    125133               END SELECT 
    126134            ! 
     
    131139         ipf_j = sum (ipj_s(:))      ! Total number of lines to be exchanged 
    132140         ! 
    133          ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 
     141         ALLOCATE( znorthloc(1-nn_hls+1:jpimax,ipf_j,ipk,ipl,1) ) 
    134142         ! 
    135143         js = 0 
     
    139147               DO jl = 1, ipl 
    140148                  DO jk = 1, ipk 
    141                      znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 
     149                     znorthloc(1-nn_hls+1:jpi,js,jk,jl,1) = ARRAY_IN(1-nn_hls+1:jpi,jj_s(jf,jj),jk,jl,jf) 
    142150                  END DO 
    143151               END DO 
     
    145153         END DO 
    146154         ! 
    147          ibuffsize = jpimax * ipf_j * ipk * ipl 
    148          ! 
    149          ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 
    150          ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) )  
     155         ibuffsize = (jpimax + nn_hls -1) * ipf_j * ipk * ipl 
     156         ! 
     157         ALLOCATE( zfoldwk(1-nn_hls+1:jpimax,ipf_j,ipk,ipl,1) ) 
     158         ALLOCATE( ztabr(1-nn_hls+1:(jpi+nn_hls-1)*jpmaxngh-nn_hls+1,ijpj,ipk,ipl,ipf) )  
    151159         ! when some processors of the north fold are suppressed,  
    152160         ! values of ztab* arrays corresponding to these suppressed domain won't be defined  
     
    218226      ELSE                             !==  allgather exchanges  ==! 
    219227         ! 
    220          ipj   = 4            ! 2nd dimension of message transfers (last j-lines) 
    221          ! 
    222          ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 
    223          ! 
    224          DO jf = 1, ipf                ! put in znorthloc the last ipj j-lines of ptab 
     228         ijpj   = 4            ! 2nd dimension of message transfers (last j-lines) 
     229         ! 
     230         ALLOCATE( znorthloc(jpimax,ijpj,ipk,ipl,ipf) ) 
     231         ! 
     232         DO jf = 1, ipf                ! put in znorthloc the last ijpj j-lines of ptab 
    225233            DO jl = 1, ipl 
    226234               DO jk = 1, ipk 
    227                   DO jj = nlcj - ipj +1, nlcj 
    228                      ij = jj - nlcj + ipj 
     235                  DO jj = nlcj - ijpj +1, nlcj 
     236                     ij = jj - nlcj + ijpj 
    229237                     znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 
    230238                  END DO 
     
    233241         END DO 
    234242         ! 
    235          ibuffsize = jpimax * ipj * ipk * ipl * ipf 
    236          ! 
    237          ALLOCATE( ztab       (jpiglo,ipj,ipk,ipl,ipf     ) ) 
    238          ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 
     243         ibuffsize = jpimax * ijpj * ipk * ipl * ipf 
     244         ! 
     245         ALLOCATE( ztab       (jpiglo,ijpj,ipk,ipl,ipf     ) ) 
     246         ALLOCATE( znorthgloio(jpimax,ijpj,ipk,ipl,ipf,jpni) ) 
    239247         ! 
    240248         ! when some processors of the north fold are suppressed, 
     
    263271               DO jl = 1, ipl 
    264272                  DO jk = 1, ipk 
    265                      DO jj = 1, ipj 
     273                     DO jj = 1, ijpj 
    266274                        DO ji = ildi, ilei 
    267275                           ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr) 
     
    279287            DO jl = 1, ipl 
    280288               DO jk = 1, ipk 
    281                   DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN 
    282                      ij = jj - nlcj + ipj 
     289                  DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to ARRAY_IN 
     290                     ij = jj - nlcj + ijpj 
    283291                     DO ji= 1, nlci 
    284292                        ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf) 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/mppini.F90

    r11692 r11719  
    2525   USE bdy_oce        ! open BounDarY   
    2626   ! 
    27    USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges  
     27   USE lbcnfd  , ONLY : isendto, nsndto   ! Setup of north fold exchanges  
    2828   USE lib_mpp        ! distribued memory computing library 
    2929   USE iom            ! nemo I/O library  
     
    703703            WRITE(inum,*) 
    704704            WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 
    705             WRITE(inum,*) 'nfsloop : ', nfsloop 
    706             WRITE(inum,*) 'nfeloop : ', nfeloop 
    707705            WRITE(inum,*) 'nsndto : ', nsndto 
    708706            WRITE(inum,*) 'isendto : ', isendto 
     
    12651263            ! 
    12661264         END DO 
    1267          nfsloop = 1 
    1268          nfeloop = nlci 
    1269          DO jn = 2,jpni-1 
    1270             IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN 
    1271                IF( nfipproc(jn-1,jpnj) == -1 )   nfsloop = nldi 
    1272                IF( nfipproc(jn+1,jpnj) == -1 )   nfeloop = nlei 
    1273             ENDIF 
    1274          END DO 
    12751265         ! 
    12761266      ENDIF 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/TRA/traadv_mus.F90

    r10425 r11719  
    3030   USE lib_mpp        ! distribued memory computing 
    3131   USE lbclnk         ! ocean lateral boundary condition (or mpp link)  
    32    USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     32   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
     33   USE halo_mng 
    3334 
    3435   IMPLICIT NONE 
     
    3637 
    3738   PUBLIC   tra_adv_mus   ! routine called by traadv.F90 
     39    
     40   REAL(wp), ALLOCATABLE, DIMENSION(:,:    ) ::   r1_e1e2t_exh2, r1_e1e2u_exh2, r1_e1e2v_exh2 
     41   REAL(wp), ALLOCATABLE, DIMENSION(:,:    ) ::   rnfmsk_exh2, upsmsk_exh2, mikt_exh2 
     42   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:  ) ::   tmask_exh2, wmask_exh2, umask_exh2, vmask_exh2 
     43   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:  ) ::   e3u_n_exh2, e3v_n_exh2, e3t_n_exh2, e3w_n_exh2 
     44   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:  ) ::   pun_exh2, pvn_exh2, pwn_exh2   ! 3 ocean velocity components 
     45   REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) ::   ptb_exh2, pta_exh2        ! before and now tracer fields 
     46 
    3847    
    3948   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   upsmsk   !: mixed upstream/centered scheme near some straits 
     
    4453   LOGICAL  ::   l_ptr   ! flag to compute poleward transport 
    4554   LOGICAL  ::   l_hst   ! flag to compute heat/salt transport 
     55    
     56   INTEGER :: jphls = 2 
    4657 
    4758   !! * Substitutions 
     
    8495      ! 
    8596      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    86       INTEGER  ::   ierr             ! local integer 
     97      INTEGER  ::   last_khls, ierr             ! local integer 
    8798      REAL(wp) ::   zu, z0u, zzwx, zw , zalpha   ! local scalars 
    8899      REAL(wp) ::   zv, z0v, zzwy, z0w           !   -      - 
    89       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwx, zslpx   ! 3D workspace 
    90       REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zwy, zslpy   ! -      -  
     100      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zwx, zslpx   ! 3D workspace 
     101      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zwy, zslpy   ! -      -  
    91102      !!---------------------------------------------------------------------- 
    92103      ! 
     104       
     105   CALL halo_mng_set(jphls) 
     106    
     107   ALLOCATE(zwx(jplbi:jpi,jplbj:jpj,jpk)) 
     108   ALLOCATE(zwy(jplbi:jpi,jplbj:jpj,jpk)) 
     109   ALLOCATE(zslpx(jplbi:jpi,jplbj:jpj,jpk)) 
     110   ALLOCATE(zslpy(jplbi:jpi,jplbj:jpj,jpk)) 
     111 
     112   IF (kt==kit000) THEN 
     113      if (.not. allocated(pun_exh2))   ALLOCATE(pun_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     114      if (.not. allocated(pvn_exh2))   ALLOCATE(pvn_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     115      if (.not. allocated(pwn_exh2))   ALLOCATE(pwn_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     116      if (.not. allocated(ptb_exh2))   ALLOCATE(ptb_exh2(jplbi:jpi,jplbj:jpj,jpk,kjpt)) 
     117      if (.not. allocated(pta_exh2))   ALLOCATE(pta_exh2(jplbi:jpi,jplbj:jpj,jpk,kjpt)) 
     118      if (.not. allocated(r1_e1e2t_exh2)) ALLOCATE(r1_e1e2t_exh2(jplbi:jpi,jplbj:jpj)) 
     119      if (.not. allocated(r1_e1e2u_exh2)) ALLOCATE(r1_e1e2u_exh2(jplbi:jpi,jplbj:jpj)) 
     120      if (.not. allocated(r1_e1e2v_exh2)) ALLOCATE(r1_e1e2v_exh2(jplbi:jpi,jplbj:jpj)) 
     121      if (.not. allocated(tmask_exh2)) ALLOCATE(tmask_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     122      if (.not. allocated(wmask_exh2)) ALLOCATE(wmask_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     123      if (.not. allocated(umask_exh2)) ALLOCATE(umask_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     124      if (.not. allocated(vmask_exh2)) ALLOCATE(vmask_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     125      if (.not. allocated(e3u_n_exh2)) ALLOCATE(e3u_n_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     126      if (.not. allocated(e3v_n_exh2)) ALLOCATE(e3v_n_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     127      if (.not. allocated(e3t_n_exh2)) ALLOCATE(e3t_n_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     128      if (.not. allocated(e3w_n_exh2)) ALLOCATE(e3w_n_exh2(jplbi:jpi,jplbj:jpj,jpk)) 
     129      IF( ln_isfcav.and..not.allocated(mikt_exh2)) ALLOCATE(mikt_exh2(jplbi:jpi,jplbj:jpj)) 
     130      IF( ld_msc_ups.and..not.allocated(rnfmsk_exh2)) ALLOCATE(rnfmsk_exh2(jplbi:jpi,jplbj:jpj)) 
     131      IF( ld_msc_ups.and..not.allocated(upsmsk_exh2)) ALLOCATE(upsmsk_exh2(jplbi:jpi,jplbj:jpj)) 
     132 
     133      CALL halo_mng_copy(r1_e1e2t, r1_e1e2t_exh2) 
     134      CALL halo_mng_copy(r1_e1e2u, r1_e1e2u_exh2) 
     135      CALL halo_mng_copy(r1_e1e2v, r1_e1e2v_exh2) 
     136      CALL halo_mng_copy(tmask, tmask_exh2) 
     137      CALL halo_mng_copy(wmask, wmask_exh2) 
     138      CALL halo_mng_copy(umask, umask_exh2) 
     139      CALL halo_mng_copy(vmask, vmask_exh2) 
     140 
     141      CALL lbc_lnk( 'traadv_mus', r1_e1e2u_exh2, 'U', -1.) 
     142      CALL lbc_lnk( 'traadv_mus', r1_e1e2v_exh2, 'V', -1.) 
     143      CALL lbc_lnk( 'traadv_mus', r1_e1e2t_exh2, 'T', 1.) 
     144      CALL lbc_lnk( 'traadv_mus', tmask_exh2, 'T', 1. ) 
     145      CALL lbc_lnk( 'traadv_mus', wmask_exh2, 'W', 1.) 
     146      CALL lbc_lnk( 'traadv_mus', umask_exh2, 'U', 1. ) 
     147      CALL lbc_lnk( 'traadv_mus', vmask_exh2, 'V', 1.) 
     148   ENDIF 
     149    
     150   IF( ln_isfcav ) THEN ; CALL halo_mng_copy(REAL(mikt), mikt_exh2) ; CALL lbc_lnk( 'traadv_mus', mikt_exh2, 'T', 1.) ; ENDIF 
     151   IF( ld_msc_ups) THEN ; CALL halo_mng_copy(rnfmsk, rnfmsk_exh2) ; CALL lbc_lnk( 'traadv_mus', rnfmsk_exh2, 'T', 1.) ; ENDIF 
     152   IF( ld_msc_ups) THEN ; CALL halo_mng_copy(upsmsk, upsmsk_exh2) ; CALL lbc_lnk( 'traadv_mus', upsmsk_exh2, 'T', 1.) ; ENDIF 
     153 
     154   CALL halo_mng_copy(e3u_n, e3u_n_exh2) 
     155   CALL halo_mng_copy(e3v_n, e3v_n_exh2) 
     156   CALL halo_mng_copy(e3t_n, e3t_n_exh2) 
     157   CALL halo_mng_copy(e3w_n, e3w_n_exh2) 
     158   CALL halo_mng_copy(pun, pun_exh2) 
     159   CALL halo_mng_copy(pvn, pvn_exh2) 
     160   CALL halo_mng_copy(pwn, pwn_exh2) 
     161   CALL halo_mng_copy(ptb, ptb_exh2) 
     162   CALL halo_mng_copy(pta, pta_exh2) 
     163 
     164   CALL lbc_lnk( 'traadv_mus', e3u_n_exh2, 'U', -1., pfillval = 1.0_wp ) 
     165   CALL lbc_lnk( 'traadv_mus', e3v_n_exh2, 'V', -1., pfillval = 1.0_wp ) 
     166   CALL lbc_lnk( 'traadv_mus', e3t_n_exh2, 'T', 1., pfillval = 1.0_wp ) 
     167   CALL lbc_lnk( 'traadv_mus', e3w_n_exh2, 'W', 1., pfillval = 1.0_wp ) 
     168   CALL lbc_lnk( 'traadv_mus', pun_exh2, 'U', -1.) 
     169   CALL lbc_lnk( 'traadv_mus', pvn_exh2, 'V', -1.) 
     170   CALL lbc_lnk( 'traadv_mus', pwn_exh2, 'W', 1.) 
     171   CALL lbc_lnk( 'traadv_mus', pta_exh2, 'T', 1.) 
     172   CALL lbc_lnk( 'traadv_mus', ptb_exh2, 'T', 1.) 
     173 
     174#     define pun pun_exh2 
     175#     define pvn pvn_exh2 
     176#     define pwn pwn_exh2 
     177#     define ptb ptb_exh2 
     178#     define pta pta_exh2 
     179#     define r1_e1e2t r1_e1e2t_exh2 
     180#     define r1_e1e2u r1_e1e2u_exh2 
     181#     define r1_e1e2v r1_e1e2v_exh2 
     182#     define tmask tmask_exh2 
     183#     define wmask wmask_exh2 
     184#     define umask umask_exh2 
     185#     define vmask vmask_exh2 
     186#     define e3u_n e3u_n_exh2 
     187#     define e3v_n e3v_n_exh2 
     188#     define e3t_n e3t_n_exh2 
     189#     define e3w_n e3w_n_exh2 
     190#     define mikt mikt_exh2 
     191#     define rnfmsk rnfmsk_exh2 
     192#     define upsmsk upsmsk_exh2 
     193 
    93194      IF( kt == kit000 )  THEN 
    94195         IF(lwp) WRITE(numout,*) 
     
    100201         ! Upstream / MUSCL scheme indicator 
    101202         ! 
    102          ALLOCATE( xind(jpi,jpj,jpk), STAT=ierr ) 
     203         ALLOCATE( xind(jplbi:jpi,jplbj:jpj,jpk), STAT=ierr ) 
    103204         xind(:,:,:) = 1._wp              ! set equal to 1 where up-stream is not needed 
    104205         ! 
    105206         IF( ld_msc_ups ) THEN            ! define the upstream indicator (if asked) 
    106             ALLOCATE( upsmsk(jpi,jpj), STAT=ierr ) 
     207            ALLOCATE( upsmsk(jplbi:jpi,jplbj:jpj), STAT=ierr ) 
    107208            upsmsk(:,:) = 0._wp                             ! not upstream by default 
    108209            ! 
     
    132233         zwy(:,:,jpk) = 0._wp   
    133234         DO jk = 1, jpkm1                       ! interior values 
    134             DO jj = 1, jpjm1       
    135                DO ji = 1, fs_jpim1   ! vector opt. 
     235            DO jj = jplbj, jpj-1       
     236               DO ji = jplbi, jpi-1   ! vector opt. 
    136237                  zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptb(ji+1,jj,jk,jn) - ptb(ji,jj,jk,jn) ) 
    137238                  zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptb(ji,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) 
     
    140241         END DO 
    141242         ! lateral boundary conditions   (changed sign) 
    142          CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) 
     243         !CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) 
    143244         !                                !-- Slopes of tracer 
    144245         zslpx(:,:,jpk) = 0._wp                 ! bottom values 
    145246         zslpy(:,:,jpk) = 0._wp 
    146247         DO jk = 1, jpkm1                       ! interior values 
    147             DO jj = 2, jpj 
    148                DO ji = fs_2, jpi   ! vector opt. 
     248            DO jj = jplbj+1, jpj 
     249               DO ji = jplbi+1, jpi   ! vector opt. 
    149250                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
    150251                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
     
    156257         ! 
    157258         DO jk = 1, jpkm1                 !-- Slopes limitation 
    158             DO jj = 2, jpj 
    159                DO ji = fs_2, jpi   ! vector opt. 
     259            DO jj = jplbj+1, jpj 
     260               DO ji = jplbi+1, jpi   ! vector opt. 
    160261                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
    161262                     &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   & 
     
    169270         ! 
    170271         DO jk = 1, jpkm1                 !-- MUSCL horizontal advective fluxes 
    171             DO jj = 2, jpjm1 
    172                DO ji = fs_2, fs_jpim1   ! vector opt. 
     272            DO jj = jplbj+1, jpj-1 
     273               DO ji = jplbi+1, jpi-1   ! vector opt. 
    173274                  ! MUSCL fluxes 
    174275                  z0u = SIGN( 0.5, pun(ji,jj,jk) ) 
     
    188289            END DO 
    189290         END DO 
    190          CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. )   ! lateral boundary conditions   (changed sign) 
     291         !CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. )   ! lateral boundary conditions   (changed sign) 
    191292         ! 
    192293         DO jk = 1, jpkm1                 !-- Tracer advective trend 
    193             DO jj = 2, jpjm1       
    194                DO ji = fs_2, fs_jpim1   ! vector opt. 
     294            DO jj = jplbj+1, jpj-1       
     295               DO ji = jplbi+1, jpi-1   ! vector opt. 
    195296                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )       & 
    196297                  &                                     + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) )     & 
     
    220321         zslpx(:,:,1) = 0._wp                   ! surface values 
    221322         DO jk = 2, jpkm1                       ! interior value 
    222             DO jj = 1, jpj 
    223                DO ji = 1, jpi 
     323            DO jj = jplbj, jpj 
     324               DO ji = jplbi, jpi 
    224325                  zslpx(ji,jj,jk) =                     ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )  & 
    225326                     &            * (  0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) )  ) 
     
    228329         END DO 
    229330         DO jk = 2, jpkm1                 !-- Slopes limitation 
    230             DO jj = 1, jpj                      ! interior values 
    231                DO ji = 1, jpi 
     331            DO jj = jplbj, jpj                      ! interior values 
     332               DO ji = jplbi, jpi 
    232333                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
    233334                     &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   & 
     
    237338         END DO 
    238339         DO jk = 1, jpk-2                 !-- vertical advective flux 
    239             DO jj = 2, jpjm1       
    240                DO ji = fs_2, fs_jpim1   ! vector opt. 
     340            DO jj = jplbj+1, jpj-1       
     341               DO ji = jplbi+1, jpi-1   ! vector opt. 
    241342                  z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 
    242343                  zalpha = 0.5 + z0w 
     
    250351         IF( ln_linssh ) THEN                   ! top values, linear free surface only 
    251352            IF( ln_isfcav ) THEN                      ! ice-shelf cavities (top of the ocean) 
    252                DO jj = 1, jpj 
    253                   DO ji = 1, jpi 
     353            DO jj = jplbj, jpj       
     354               DO ji = jplbi, jpi 
    254355                     zwx(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) 
    255356                  END DO 
     
    261362         ! 
    262363         DO jk = 1, jpkm1                 !-- vertical advective trend 
    263             DO jj = 2, jpjm1       
    264                DO ji = fs_2, fs_jpim1   ! vector opt. 
     364            DO jj = jplbj+1, jpj-1       
     365               DO ji = jplbi+1, jpi-1   ! vector opt. 
    265366                  pta(ji,jj,jk,jn) =  pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
    266367               END DO 
     
    272373      END DO                     ! end of tracer loop 
    273374      ! 
     375#     undef pun 
     376#     undef pvn 
     377#     undef pwn 
     378#     undef ptb 
     379#     undef pta 
     380#     undef r1_e1e2t 
     381#     undef r1_e1e2u 
     382#     undef r1_e1e2v 
     383#     undef tmask 
     384#     undef wmask 
     385#     undef umask 
     386#     undef vmask 
     387#     undef e3u_n 
     388#     undef e3v_n 
     389#     undef e3t_n 
     390#     undef e3w_n 
     391#     undef mikt 
     392#     undef rnfmsk 
     393#     undef upsmsk 
     394 
     395   CALL halo_mng_copy(pta_exh2, pta) 
     396 
     397    last_khls = jphls - ((SIZE(pta_exh2, 1) - SIZE(pta, 1))/2) 
     398 
     399    CALL halo_mng_set(last_khls) 
     400 
     401   CALL lbc_lnk( 'traadv_mus', pta, 'T', 1. ) 
     402 
     403   IF( kt==nitend ) THEN 
     404      if (allocated(pun_exh2)) DEALLOCATE(pun_exh2) 
     405      if (allocated(pvn_exh2)) DEALLOCATE(pvn_exh2) 
     406      if (allocated(pwn_exh2)) DEALLOCATE(pwn_exh2) 
     407         if (allocated(ptb_exh2)) DEALLOCATE(ptb_exh2) 
     408      if (allocated(pta_exh2)) DEALLOCATE(pta_exh2) 
     409      if (allocated(r1_e1e2t_exh2)) DEALLOCATE(r1_e1e2t_exh2) 
     410      if (allocated(r1_e1e2u_exh2)) DEALLOCATE(r1_e1e2u_exh2) 
     411      if (allocated(r1_e1e2v_exh2)) DEALLOCATE(r1_e1e2v_exh2) 
     412      if (allocated(tmask_exh2)) DEALLOCATE(tmask_exh2) 
     413      if (allocated(wmask_exh2)) DEALLOCATE(wmask_exh2) 
     414      if (allocated(umask_exh2)) DEALLOCATE(umask_exh2) 
     415      if (allocated(vmask_exh2)) DEALLOCATE(vmask_exh2) 
     416      if (allocated(e3u_n_exh2)) DEALLOCATE(e3u_n_exh2) 
     417      if (allocated(e3v_n_exh2)) DEALLOCATE(e3v_n_exh2) 
     418      if (allocated(e3t_n_exh2)) DEALLOCATE(e3t_n_exh2) 
     419      if (allocated(e3w_n_exh2)) DEALLOCATE(e3w_n_exh2) 
     420         IF (ln_isfcav.and.allocated(mikt_exh2)) DEALLOCATE(mikt_exh2) 
     421         IF( ld_msc_ups.and.allocated(rnfmsk_exh2)) DEALLOCATE(rnfmsk_exh2) 
     422      IF( ld_msc_ups.and.allocated(upsmsk_exh2)) DEALLOCATE(upsmsk_exh2) 
     423 
     424    ENDIF 
     425 
     426   DEALLOCATE(zwx,zwy) 
     427    DEALLOCATE(zslpx,zslpy) 
    274428   END SUBROUTINE tra_adv_mus 
    275429 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/nemogcm.F90

    r11692 r11719  
    8585   USE lib_mpp        ! distributed memory computing 
    8686   USE mppini         ! shared/distributed memory setting (mpp_init routine) 
    87    USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges  
     87   USE lbcnfd  , ONLY : isendto, nsndto   ! Setup of north fold exchanges  
    8888   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    8989#if defined key_iomput 
     
    9393   USE agrif_all_update   ! Master Agrif update 
    9494#endif 
     95   USE halo_mng 
    9596 
    9697   IMPLICIT NONE 
     
    270271      ! 
    271272      cxios_context = 'nemo' 
     273      nn_hls = 1 
    272274      ! 
    273275      !                             !-------------------------------------------------! 
     
    395397      CALL mpp_init 
    396398 
     399      CALL halo_mng_init() 
    397400      ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 
    398401      CALL nemo_alloc() 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/par_oce.F90

    r10068 r11719  
    5757   INTEGER, PUBLIC ::   jpimax! = ( jpiglo-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls !: maximum jpi 
    5858   INTEGER, PUBLIC ::   jpjmax! = ( jpjglo-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls !: maximum jpj 
     59   INTEGER, PUBLIC ::   jplbi 
     60   INTEGER, PUBLIC ::   jplbj 
    5961 
    6062   !!--------------------------------------------------------------------- 
     
    7476   INTEGER, PUBLIC, PARAMETER ::   jpr2di = 0   !: number of columns for extra outer halo  
    7577   INTEGER, PUBLIC, PARAMETER ::   jpr2dj = 0   !: number of rows    for extra outer halo  
    76    INTEGER, PUBLIC, PARAMETER ::   nn_hls = 1   !: halo width (applies to both rows and columns) 
     78   INTEGER, PUBLIC            ::   nn_hls       !: halo width (applies to both rows and columns) 
    7779 
    7880   !!---------------------------------------------------------------------- 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OFF/nemogcm.F90

    r11692 r11719  
    5858   USE timing         ! Timing 
    5959   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    60    USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges 
     60   USE lbcnfd  , ONLY : isendto, nsndto  ! Setup of north fold exchanges 
     61   USE halo_mng 
    6162 
    6263   IMPLICIT NONE 
     
    169170      ! 
    170171      cxios_context = 'nemo' 
     172      nn_hls = 1 
    171173      ! 
    172174      !                             !-------------------------------------------------! 
     
    282284      CALL mpp_init 
    283285 
     286      CALL halo_mng_init() 
    284287      ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 
    285288      CALL nemo_alloc() 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/SAO/nemogcm.F90

    r11692 r11719  
    3131   USE lib_mpp        ! distributed memory computing 
    3232   USE mppini         ! shared/distributed memory setting (mpp_init routine) 
    33    USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges  
     33   USE lbcnfd  , ONLY : isendto, nsndto ! Setup of north fold exchanges  
    3434   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    3535#if defined key_iomput 
    3636   USE xios           ! xIOserver 
    3737#endif 
     38   USE halo_mng 
    3839 
    3940   IMPLICIT NONE 
     
    9899      ! 
    99100      cxios_context = 'nemo' 
     101      nn_hls = 1 
    100102      ! 
    101103      !                             !-------------------------------------------------! 
     
    223225      CALL mpp_init 
    224226 
     227      CALL halo_mng_init() 
    225228      ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 
    226229      CALL nemo_alloc() 
  • NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/SAS/nemogcm.F90

    r11692 r11719  
    3535   USE lib_mpp        ! distributed memory computing 
    3636   USE mppini         ! shared/distributed memory setting (mpp_init routine) 
    37    USE lbcnfd  , ONLY : isendto, nsndto, nfsloop, nfeloop   ! Setup of north fold exchanges 
     37   USE lbcnfd  , ONLY : isendto, nsndto  ! Setup of north fold exchanges 
    3838   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 
    3939#if defined key_iomput 
     
    4343   USE agrif_ice_update ! ice update 
    4444#endif 
     45   USE halo_mng 
    4546 
    4647   IMPLICIT NONE 
     
    194195      ELSE                  ;   cxios_context = 'nemo' 
    195196      ENDIF 
     197      nn_hls = 1 
    196198      ! 
    197199      !                             !-------------------------------------------------! 
     
    331333      CALL mpp_init 
    332334 
     335      CALL halo_mng_init() 
    333336      ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 
    334337      CALL nemo_alloc() 
Note: See TracChangeset for help on using the changeset viewer.