Changeset 10175


Ignore:
Timestamp:
2018-10-05T17:20:12+02:00 (21 months ago)
Author:
smasson
Message:

dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 3b: north fold nogather performance optimisation , see #2133

Location:
NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r10173 r10175  
    88#      define K_SIZE(ptab)             1 
    99#      define L_SIZE(ptab)             1 
    10 #      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_2D),INTENT(inout)::ptab2(f) 
    11 #      define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt2d(i,j) 
    1210#   endif 
    1311#   if defined DIM_3d 
     
    1614#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    1715#      define L_SIZE(ptab)             1 
    18 #      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_3D),INTENT(inout)::ptab2(f) 
    19 #      define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt3d(i,j,k) 
    2016#   endif 
    2117#   if defined DIM_4d 
     
    2420#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    2521#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4) 
    26 #      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D),INTENT(inout)::ptab2(f) 
    27 #      define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt4d(i,j,k,l) 
    28 #   endif 
     22#   endif 
     23#   define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D),INTENT(inout)::ptab2(f) 
     24#   define J_SIZE(ptab2)            SIZE(ptab2(1)%pt4d,2) 
     25#   define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt4d(i,j,k,l) 
    2926#else 
    3027!                          !==  IN: ptab is an array  ==! 
     
    3633#      define K_SIZE(ptab)          1 
    3734#      define L_SIZE(ptab)          1 
    38 #      define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j) 
    3935#   endif 
    4036#   if defined DIM_3d 
     
    4238#      define K_SIZE(ptab)          SIZE(ptab,3) 
    4339#      define L_SIZE(ptab)          1 
    44 #      define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k) 
    4540#   endif 
    4641#   if defined DIM_4d 
     
    4843#      define K_SIZE(ptab)          SIZE(ptab,3) 
    4944#      define L_SIZE(ptab)          SIZE(ptab,4) 
    50 #      define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k,l) 
    51 #   endif 
     45#   endif 
     46#   define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k,l) 
     47#   define J_SIZE(ptab2)             SIZE(ptab2,2) 
    5248#   define ARRAY_TYPE(i,j,k,l,f)     REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
    5349#   define ARRAY2_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 
     
    6965      INTEGER  ::    ji,  jj,   jk,     jl,   jh,  jf   ! dummy loop indices 
    7066      INTEGER  ::   ipi, ipj,  ipk,    ipl,  ipf        ! dimension of the input array 
    71       INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop 
     67      INTEGER  ::   ijt, iju, ijpj, ijpjp1, ijta, ijua, jia, startloop, endloop 
     68      LOGICAL  ::   l_fast_exchanges 
    7269      !!---------------------------------------------------------------------- 
    73       ipk = K_SIZE(ptab)   ! 3rd dimension 
     70      ipj = J_SIZE(ptab2)  ! 2nd dimension of input array 
     71      ipk = K_SIZE(ptab)   ! 3rd dimension of output array 
    7472      ipl = L_SIZE(ptab)   ! 4th    - 
    7573      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    7674      ! 
     75      ! Security check for further developments 
     76      IF ( ipf > 1 ) THEN 
     77        write(6,*) 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation'  
     78        write(6,*) 'You should not be there...'  
     79        STOP 
     80      ENDIF 
    7781      ! 
    78       SELECT CASE ( jpni ) 
    79       CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction 
    80       CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction 
    81       END SELECT 
    82       ijpjm1 = ijpj-1 
    83       ! 
     82      ijpj   = 1    ! index of first modified line  
     83      ijpjp1 = 2    ! index + 1 
     84       
     85      ! 2nd dimension determines exchange speed 
     86      IF (ipj == 1 ) THEN 
     87        l_fast_exchanges = .TRUE. 
     88      ELSE 
     89        l_fast_exchanges = .FALSE. 
     90      ENDIF 
    8491      ! 
    8592      DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
     
    96103               ENDIF 
    97104               ! 
    98                DO ji = startloop, nlci 
    99                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    100                   ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf) 
    101                END DO 
     105               DO jl = 1, ipl; DO jk = 1, ipk 
     106                  DO ji = startloop, nlci 
     107                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     108                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 
     109                  END DO 
     110               END DO; END DO 
    102111               IF( nimpp == 1 ) THEN 
    103                   ARRAY_IN(1,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ijpj-2,:,:,jf) 
    104                ENDIF 
    105                ! 
    106                IF( nimpp >= jpiglo/2+1 ) THEN 
    107                   startloop = 1 
    108                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    109                   startloop = jpiglo/2+1 - nimpp + 1 
    110                ELSE 
    111                   startloop = nlci + 1 
    112                ENDIF 
    113                IF( startloop <= nlci ) THEN 
    114                   DO ji = startloop, nlci 
    115                      ijt  = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    116                      jia  = ji + nimpp - 1 
    117                      ijta = jpiglo - jia + 2 
    118                      IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
    119                         ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,ijpjm1,:,:,jf) 
    120                      ELSE 
    121                         ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf) 
    122                      ENDIF 
    123                   END DO 
    124                ENDIF 
    125                ! 
     112                  DO jl = 1, ipl; DO jk = 1, ipk 
     113                     ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf) 
     114                  END DO; END DO 
     115               ENDIF 
     116               ! 
     117               IF ( .NOT. l_fast_exchanges ) THEN 
     118                  IF( nimpp >= jpiglo/2+1 ) THEN 
     119                     startloop = 1 
     120                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
     121                     startloop = jpiglo/2+1 - nimpp + 1 
     122                  ELSE 
     123                     startloop = nlci + 1 
     124                  ENDIF 
     125                  IF( startloop <= nlci ) THEN 
     126                     DO jl = 1, ipl; DO jk = 1, ipk 
     127                        DO ji = startloop, nlci 
     128                           ijt  = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     129                           jia  = ji + nimpp - 1 
     130                           ijta = jpiglo - jia + 2 
     131                           IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
     132                              ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf) 
     133                           ELSE 
     134                              ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 
     135                           ENDIF 
     136                        END DO 
     137                     END DO; END DO 
     138                  ENDIF 
     139               ENDIF 
     140 
    126141            CASE ( 'U' )                                     ! U-point 
    127142               IF( nimpp + nlci - 1 /= jpiglo ) THEN 
     
    130145                  endloop = nlci - 1 
    131146               ENDIF 
    132                DO ji = 1, endloop 
    133                   iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    134                         ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf) 
    135                END DO 
     147               DO jl = 1, ipl; DO jk = 1, ipk 
     148                  DO ji = 1, endloop 
     149                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     150                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 
     151                  END DO 
     152               END DO; END DO 
    136153               IF (nimpp .eq. 1) THEN 
    137                         ARRAY_IN(   1  ,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(    2   ,ijpj-2,:,:,jf) 
     154                  ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 
    138155               ENDIF 
    139156               IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    140                         ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-2,:,:,jf) 
    141                ENDIF 
    142                ! 
    143                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    144                   endloop = nlci 
    145                ELSE 
    146                   endloop = nlci - 1 
    147                ENDIF 
    148                IF( nimpp >= jpiglo/2 ) THEN 
    149                   startloop = 1 
    150                   ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 
    151                   startloop = jpiglo/2 - nimpp + 1 
    152                ELSE 
    153                   startloop = endloop + 1 
    154                ENDIF 
    155                IF( startloop <= endloop ) THEN 
    156                DO ji = startloop, endloop 
    157                   iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    158                   jia = ji + nimpp - 1 
    159                   ijua = jpiglo - jia + 1 
    160                   IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
    161                            ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,ijpjm1,:,:,jf) 
    162                   ELSE 
    163                            ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf) 
    164                   ENDIF 
    165                END DO 
     157                  ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 
     158               ENDIF 
     159               ! 
     160               IF ( .NOT. l_fast_exchanges ) THEN 
     161                  IF( nimpp + nlci - 1 /= jpiglo ) THEN 
     162                     endloop = nlci 
     163                  ELSE 
     164                     endloop = nlci - 1 
     165                  ENDIF 
     166                  IF( nimpp >= jpiglo/2 ) THEN 
     167                     startloop = 1 
     168                     ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN 
     169                     startloop = jpiglo/2 - nimpp + 1 
     170                  ELSE 
     171                     startloop = endloop + 1 
     172                  ENDIF 
     173                  IF( startloop <= endloop ) THEN 
     174                  DO jl = 1, ipl; DO jk = 1, ipk 
     175                     DO ji = startloop, endloop 
     176                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     177                        jia = ji + nimpp - 1 
     178                        ijua = jpiglo - jia + 1 
     179                        IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
     180                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf) 
     181                        ELSE 
     182                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 
     183                        ENDIF 
     184                     END DO 
     185                  END DO; END DO 
     186                  ENDIF 
    166187               ENDIF 
    167188               ! 
     
    172193                 startloop = 2 
    173194               ENDIF 
    174                DO ji = startloop, nlci 
    175                  ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    176                         ARRAY_IN(ji,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf) 
    177                         ARRAY_IN(ji,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-3,:,:,jf) 
    178                END DO 
     195               IF ( .NOT. l_fast_exchanges ) THEN 
     196                  DO jl = 1, ipl; DO jk = 1, ipk 
     197                     DO ji = startloop, nlci 
     198                        ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     199                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 
     200                     END DO 
     201                  END DO; END DO 
     202               ENDIF 
     203               DO jl = 1, ipl; DO jk = 1, ipk 
     204                  DO ji = startloop, nlci 
     205                     ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
     206                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 
     207                  END DO 
     208               END DO; END DO 
    179209               IF (nimpp .eq. 1) THEN 
    180                         ARRAY_IN(1,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ijpj-3,:,:,jf) 
     210                  ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf) 
    181211               ENDIF 
    182212            CASE ( 'F' )                                     ! F-point 
     
    186216                  endloop = nlci - 1 
    187217               ENDIF 
    188                DO ji = 1, endloop 
    189                   iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    190                         ARRAY_IN(ji,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf) 
    191                         ARRAY_IN(ji,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-3,:,:,jf) 
    192                END DO 
     218               IF ( .NOT. l_fast_exchanges ) THEN 
     219                  DO jl = 1, ipl; DO jk = 1, ipk 
     220                     DO ji = 1, endloop 
     221                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     222                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 
     223                     END DO 
     224                  END DO; END DO 
     225               ENDIF 
     226               DO jl = 1, ipl; DO jk = 1, ipk 
     227                  DO ji = 1, endloop 
     228                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     229                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 
     230                  END DO 
     231               END DO; END DO 
    193232               IF (nimpp .eq. 1) THEN 
    194                         ARRAY_IN(   1  ,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(    2   ,ijpj-3,:,:,jf) 
    195                         ARRAY_IN(   1  ,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(    2   ,ijpj-2,:,:,jf) 
     233                  ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf) 
     234                  IF ( .NOT. l_fast_exchanges ) & 
     235                     ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) 
    196236               ENDIF 
    197237               IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    198                         ARRAY_IN(nlci,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-3,:,:,jf) 
    199                         ARRAY_IN(nlci,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-2,:,:,jf)  
     238                  ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf) 
     239                  IF ( .NOT. l_fast_exchanges ) & 
     240                     ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) 
    200241               ENDIF 
    201242               ! 
     
    206247            SELECT CASE ( NAT_IN(jf) ) 
    207248            CASE ( 'T' , 'W' )                               ! T-, W-point 
    208                DO ji = 1, nlci 
    209                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    210                         ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-1,:,:,jf) 
    211                END DO 
     249               DO jl = 1, ipl; DO jk = 1, ipk 
     250                  DO ji = 1, nlci 
     251                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     252                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 
     253                  END DO 
     254               END DO; END DO 
    212255               ! 
    213256            CASE ( 'U' )                                     ! U-point 
     
    217260                  endloop = nlci - 1 
    218261               ENDIF 
    219                DO ji = 1, endloop 
    220                   iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    221                         ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-1,:,:,jf) 
    222                END DO 
     262               DO jl = 1, ipl; DO jk = 1, ipk 
     263                  DO ji = 1, endloop 
     264                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
     265                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 
     266                  END DO 
     267               END DO; END DO 
    223268               IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    224                         ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,ijpj-1,:,:,jf) 
     269                  DO jl = 1, ipl; DO jk = 1, ipk 
     270                     ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf) 
     271                  END DO; END DO 
    225272               ENDIF 
    226273               ! 
    227274            CASE ( 'V' )                                     ! V-point 
    228                DO ji = 1, nlci 
    229                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    230                         ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf) 
    231                END DO 
    232                   ! 
    233                IF( nimpp >= jpiglo/2+1 ) THEN 
    234                   startloop = 1 
    235                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    236                   startloop = jpiglo/2+1 - nimpp + 1 
    237                ELSE 
    238                   startloop = nlci + 1 
    239                ENDIF 
    240                IF( startloop <= nlci ) THEN 
    241                DO ji = startloop, nlci 
    242                   ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
    243                           ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf) 
    244                END DO 
     275               DO jl = 1, ipl; DO jk = 1, ipk 
     276                  DO ji = 1, nlci 
     277                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     278                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) 
     279                  END DO 
     280               END DO; END DO 
     281 
     282               IF ( .NOT. l_fast_exchanges ) THEN 
     283                  IF( nimpp >= jpiglo/2+1 ) THEN 
     284                     startloop = 1 
     285                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
     286                     startloop = jpiglo/2+1 - nimpp + 1 
     287                  ELSE 
     288                     startloop = nlci + 1 
     289                  ENDIF 
     290                  IF( startloop <= nlci ) THEN 
     291                  DO jl = 1, ipl; DO jk = 1, ipk 
     292                     DO ji = startloop, nlci 
     293                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 
     294                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) 
     295                     END DO 
     296                  END DO; END DO 
     297                  ENDIF 
    245298               ENDIF 
    246299               ! 
     
    251304                  endloop = nlci - 1 
    252305               ENDIF 
    253                DO ji = 1, endloop 
    254                   iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    255                         ARRAY_IN(ji,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf) 
    256                END DO 
     306               DO jl = 1, ipl; DO jk = 1, ipk 
     307                  DO ji = 1, endloop 
     308                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
     309                     ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) 
     310                  END DO 
     311               END DO; END DO 
    257312               IF((nimpp + nlci - 1) .eq. jpiglo) THEN 
    258                         ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,ijpj-2,:,:,jf) 
    259                ENDIF 
    260                ! 
    261                IF( nimpp + nlci - 1 /= jpiglo ) THEN 
    262                   endloop = nlci 
    263                ELSE 
    264                   endloop = nlci - 1 
    265                ENDIF 
    266                IF( nimpp >= jpiglo/2+1 ) THEN 
    267                   startloop = 1 
    268                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
    269                   startloop = jpiglo/2+1 - nimpp + 1 
    270                ELSE 
    271                   startloop = endloop + 1 
    272                ENDIF 
    273                IF( startloop <= endloop ) THEN 
    274                   DO ji = startloop, endloop 
    275                       iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
    276                       ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf) 
    277                   END DO 
     313                  DO jl = 1, ipl; DO jk = 1, ipk 
     314                     ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf) 
     315                  END DO; END DO 
     316               ENDIF 
     317               ! 
     318               IF ( .NOT. l_fast_exchanges ) THEN 
     319                  IF( nimpp + nlci - 1 /= jpiglo ) THEN 
     320                     endloop = nlci 
     321                  ELSE 
     322                     endloop = nlci - 1 
     323                  ENDIF 
     324                  IF( nimpp >= jpiglo/2+1 ) THEN 
     325                     startloop = 1 
     326                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN 
     327                     startloop = jpiglo/2+1 - nimpp + 1 
     328                  ELSE 
     329                     startloop = endloop + 1 
     330                  ENDIF 
     331                  IF( startloop <= endloop ) THEN 
     332                     DO jl = 1, ipl; DO jk = 1, ipk 
     333                        DO ji = startloop, endloop 
     334                           iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 
     335                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) 
     336                        END DO 
     337                     END DO; END DO 
     338                  ENDIF 
    278339               ENDIF 
    279340               ! 
     
    282343         CASE DEFAULT                           ! *  closed : the code probably never go through 
    283344            ! 
    284             SELECT CASE ( NAT_IN(jf)) 
    285             CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points 
    286                ARRAY_IN(:, 1  ,:,:,jf) = 0._wp 
    287                ARRAY_IN(:,ijpj,:,:,jf) = 0._wp 
    288             CASE ( 'F' )                                   ! F-point 
    289                ARRAY_IN(:,ijpj,:,:,jf) = 0._wp 
    290             CASE ( 'I' )                                   ! ice U-V point 
    291                ARRAY_IN(:, 1  ,:,:,jf) = 0._wp 
    292                ARRAY_IN(:,ijpj,:,:,jf) = 0._wp 
    293             END SELECT 
     345            WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj 
    294346            ! 
    295347         END SELECT     !  npolj 
     
    301353#undef NAT_IN 
    302354#undef SGN_IN 
     355#undef J_SIZE 
    303356#undef K_SIZE 
    304357#undef L_SIZE 
  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lbcnfd.F90

    r10068 r10175  
    3232   INTERFACE lbc_nfd_nogather 
    3333!                        ! Currently only 4d array version is needed 
    34 !     MODULE PROCEDURE   lbc_nfd_nogather_2d    , lbc_nfd_nogather_3d 
    35       MODULE PROCEDURE   lbc_nfd_nogather_4d 
    36 !     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 
     34     MODULE PROCEDURE   lbc_nfd_nogather_2d    , lbc_nfd_nogather_3d 
     35     MODULE PROCEDURE   lbc_nfd_nogather_4d 
     36     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr 
    3737!     MODULE PROCEDURE   lbc_nfd_nogather_4d_ptr 
    3838   END INTERFACE 
     
    125125   !                       !==  2D array and array of 2D pointer  ==! 
    126126   ! 
    127 !#  define DIM_2d 
    128 !#     define ROUTINE_NFD           lbc_nfd_nogather_2d 
    129 !#     include "lbc_nfd_nogather_generic.h90" 
    130 !#     undef ROUTINE_NFD 
    131 !#     define MULTI 
    132 !#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr 
    133 !#     include "lbc_nfd_nogather_generic.h90" 
    134 !#     undef ROUTINE_NFD 
    135 !#     undef MULTI 
    136 !#  undef DIM_2d 
     127#  define DIM_2d 
     128#     define ROUTINE_NFD           lbc_nfd_nogather_2d 
     129#     include "lbc_nfd_nogather_generic.h90" 
     130#     undef ROUTINE_NFD 
     131#     define MULTI 
     132#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr 
     133#     include "lbc_nfd_nogather_generic.h90" 
     134#     undef ROUTINE_NFD 
     135#     undef MULTI 
     136#  undef DIM_2d 
    137137   ! 
    138138   !                       !==  3D array and array of 3D pointer  ==! 
    139139   ! 
    140 !#  define DIM_3d 
    141 !#     define ROUTINE_NFD           lbc_nfd_nogather_3d 
    142 !#     include "lbc_nfd_nogather_generic.h90" 
    143 !#     undef ROUTINE_NFD 
    144 !#     define MULTI 
    145 !#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr 
    146 !#     include "lbc_nfd_nogather_generic.h90" 
    147 !#     undef ROUTINE_NFD 
    148 !#     undef MULTI 
    149 !#  undef DIM_3d 
     140#  define DIM_3d 
     141#     define ROUTINE_NFD           lbc_nfd_nogather_3d 
     142#     include "lbc_nfd_nogather_generic.h90" 
     143#     undef ROUTINE_NFD 
     144#     define MULTI 
     145#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr 
     146#     include "lbc_nfd_nogather_generic.h90" 
     147#     undef ROUTINE_NFD 
     148#     undef MULTI 
     149#  undef DIM_3d 
    150150   ! 
    151151   !                       !==  4D array and array of 4D pointer  ==! 
  • NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/mpp_nfd_generic.h90

    r10172 r10175  
    5656      INTEGER  ::   ipi, ipj, ipk, ipl, ipf         ! dimension of the input array 
    5757      INTEGER  ::   imigr, iihom, ijhom             ! local integers 
    58       INTEGER  ::   ierr, itaille, ilci, ildi, ilei, iilb 
     58      INTEGER  ::   ierr, ibuffsize, ilci, ildi, ilei, iilb 
    5959      INTEGER  ::   ij, iproc 
    6060      INTEGER, DIMENSION (jpmaxngh)       ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather 
     
    6262      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat     ! for mpi_isend when avoiding mpi_allgather 
    6363      !                                                    ! Workspace for message transfers avoiding mpi_allgather 
    64       REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, ztabl, ztabr 
     64      INTEGER                             ::   ipf_j       ! sum of lines for all multi fields 
     65      INTEGER                             ::   js          ! counter 
     66      INTEGER, DIMENSION(:,:),          ALLOCATABLE ::   jj_s  ! position of sent lines 
     67      INTEGER, DIMENSION(:),            ALLOCATABLE ::   ipj_s ! number of sent lines 
     68      REAL(wp), DIMENSION(:,:,:)      , ALLOCATABLE ::   ztabl 
     69      REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, ztabr 
    6570      REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc, zfoldwk       
    6671      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthgloio 
     
    7176      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    7277      ! 
    73       ipj   = 4            ! 2nd dimension of message transfers (last j-lines) 
    74       ! 
    75       ALLOCATE( znorthloc(jpimax,4,ipk,ipl,ipf) ) 
    76       ! 
    77       znorthloc(:,:,:,:,:) = 0._wp 
    78       ! 
    79       DO jf = 1, ipf                ! put in znorthloc the last ipj j-lines of ptab 
    80          DO jl = 1, ipl 
    81             DO jk = 1, ipk 
    82                DO jj = nlcj - ipj +1, nlcj 
    83                   ij = jj - nlcj + ipj 
    84                   znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 
     78      IF( l_north_nogather ) THEN      !==  ????  ==! 
     79 
     80         ALLOCATE(ipj_s(ipf)) 
     81 
     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) 
     84                                 ! by default, only one line is exchanged 
     85 
     86         ALLOCATE( jj_s(ipf,2) ) 
     87 
     88         ! re-define number of exchanged lines : 
     89         !  must be two during the first two time steps 
     90         !  to correct possible incoherent values on North fold lines from restart  
     91 
     92         DO jf = 1, ipf 
     93            IF ( ncom_stp <= nit000 ) ipj_s(jf) = 2 
     94         ENDDO 
     95 
     96         ! Index of modifying lines in input 
     97         DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
     98            ! 
     99            SELECT CASE ( npolj ) 
     100            ! 
     101            CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
     102               ! 
     103               SELECT CASE ( NAT_IN(jf) ) 
     104               ! 
     105               CASE ( 'T' , 'W' ,'U' )                            ! T-, U-, W-point 
     106                  jj_s(jf,1) = nlcj - 2 ;  jj_s(jf,2) = nlcj - 1 
     107               CASE ( 'V' , 'F' )                                 ! V-, F-point 
     108                  jj_s(jf,1) = nlcj - 3 ;  jj_s(jf,2) = nlcj - 2 
     109               END SELECT 
     110            ! 
     111            CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
     112               SELECT CASE ( NAT_IN(jf) ) 
     113               ! 
     114               CASE ( 'T' , 'W' ,'U' )                            ! T-, U-, W-point 
     115                  jj_s(jf,1) = nlcj - 1       
     116                  ipj_s(jf) = 1                  ! need only one line anyway 
     117               CASE ( 'V' , 'F' )                                 ! V-, F-point 
     118                  jj_s(jf,1) = nlcj - 2 ;  jj_s(jf,2) = nlcj - 1 
     119               END SELECT 
     120            ! 
     121            END SELECT 
     122            ! 
     123         ENDDO 
     124         !  
     125         ipf_j = sum (ipj_s(:))      ! Total number of lines to be exchanged 
     126         ! 
     127         ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) 
     128         ! 
     129         js = 0 
     130         DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
     131            DO jj = 1, ipj_s(jf) 
     132               js = js + 1 
     133               DO jl = 1, ipl 
     134                  DO jk = 1, ipk 
     135                     znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) 
     136                  END DO 
    85137               END DO 
    86138            END DO 
    87139         END DO 
    88       END DO 
    89       ! 
    90       ! 
    91       itaille = jpimax * ipj * ipk * ipl * ipf 
    92       ! 
    93       IF( l_north_nogather ) THEN      !==  ????  ==! 
    94          ALLOCATE( zfoldwk(jpimax,4,ipk,ipl,ipf) ) 
    95          ALLOCATE( ztabl(jpimax   ,4,ipk,ipl,ipf) , ztabr(jpimax*jpmaxngh,4,ipk,ipl,ipf) )  
    96          ! 
     140         ! 
     141         ibuffsize = jpimax * ipf_j * ipk * ipl 
     142         ! 
     143         ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) 
     144         ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) )  
    97145         ! when some processors of the north fold are suppressed,  
    98146         ! values of ztab* arrays corresponding to these suppressed domain won't be defined  
    99147         ! and we need a default definition to 0. 
    100148         ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 
    101          IF ( jpni*jpnj /= jpnij ) THEN 
    102             ztabr(:,:,:,:,:) = 0._wp 
    103             ztabl(:,:,:,:,:) = 0._wp 
    104          END IF 
    105          ! 
    106          DO jf = 1, ipf 
    107             DO jl = 1, ipl 
    108                DO jk = 1, ipk 
    109                   DO jj = nlcj-ipj+1, nlcj          ! First put local values into the global array 
    110                      ij = jj - nlcj + ipj 
    111                      DO ji = nfsloop, nfeloop 
    112                         ztabl(ji,ij,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf) 
    113                      END DO 
    114                   END DO 
    115                END DO 
    116             END DO 
    117          END DO 
    118          ! 
     149         IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp 
     150         ! 
     151         ! start waiting time measurement 
    119152         IF( ln_timing ) CALL tic_tac(.TRUE.) 
    120153         ! 
    121154         DO jr = 1, nsndto 
    122155            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    123               CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
     156               CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) 
    124157            ENDIF 
    125158         END DO 
     159         ! 
    126160         DO jr = 1,nsndto 
    127161            iproc = nfipproc(isendto(jr),jpnj) 
     
    136170            ENDIF 
    137171            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    138               CALL mpprecv(5, zfoldwk, itaille, iproc) 
    139                DO jf = 1, ipf 
     172               CALL mpprecv(5, zfoldwk, ibuffsize, iproc) 
     173               js = 0 
     174               DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 
     175                  js = js + 1 
    140176                  DO jl = 1, ipl 
    141177                     DO jk = 1, ipk 
    142                         DO jj = 1, ipj 
    143                            DO ji = ildi, ilei 
    144                               ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,jj,jk,jl,jf) 
    145                            END DO 
     178                        DO ji = ildi, ilei 
     179                           ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) 
    146180                        END DO 
    147181                     END DO 
    148182                  END DO 
    149                END DO 
     183               END DO; END DO 
    150184            ELSE IF( iproc == narea-1 ) THEN 
    151                DO jf = 1, ipf 
     185               DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) 
    152186                  DO jl = 1, ipl 
    153187                     DO jk = 1, ipk 
    154                         DO jj = 1, ipj 
    155                            DO ji = ildi, ilei 
    156                               ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,nlcj-ipj+jj,jk,jl,jf) 
    157                            END DO 
     188                        DO ji = ildi, ilei 
     189                           ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) 
    158190                        END DO 
    159191                     END DO 
    160192                  END DO 
    161                END DO 
     193               END DO; END DO 
    162194            ENDIF 
    163195         END DO 
     
    166198               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN 
    167199                  CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) 
    168                ENDIF     
     200               ENDIF 
    169201            END DO 
    170202         ENDIF 
     
    172204         IF( ln_timing ) CALL tic_tac(.FALSE.) 
    173205         ! 
     206         ! North fold boundary condition 
     207         ! 
    174208         DO jf = 1, ipf 
    175             CALL lbc_nfd_nogather( ztabl(:,:,:,:,jf), ztabr(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition 
    176          END DO 
    177          DO jf = 1, ipf 
     209            CALL lbc_nfd_nogather(ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) 
     210         END DO 
     211         ! 
     212         DEALLOCATE( zfoldwk ) 
     213         DEALLOCATE( ztabr )  
     214         DEALLOCATE( jj_s )  
     215         DEALLOCATE( ipj_s )  
     216      ELSE                             !==  ????  ==! 
     217         ! 
     218         ipj   = 4            ! 2nd dimension of message transfers (last j-lines) 
     219         ! 
     220         ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) 
     221         ! 
     222         DO jf = 1, ipf                ! put in znorthloc the last ipj j-lines of ptab 
    178223            DO jl = 1, ipl 
    179224               DO jk = 1, ipk 
    180                   DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN 
     225                  DO jj = nlcj - ipj +1, nlcj 
    181226                     ij = jj - nlcj + ipj 
    182                      DO ji= 1, nlci 
    183                         ARRAY_IN(ji,jj,jk,jl,jf) = ztabl(ji,ij,jk,jl,jf) 
    184                      END DO 
     227                     znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) 
    185228                  END DO 
    186229               END DO 
     
    188231         END DO 
    189232         ! 
    190          DEALLOCATE( zfoldwk ) 
    191          DEALLOCATE( ztabl, ztabr )  
    192       ELSE                             !==  ????  ==! 
    193          ALLOCATE( ztab       (jpiglo,4,ipk,ipl,ipf     ) ) 
    194          ALLOCATE( znorthgloio(jpimax,4,ipk,ipl,ipf,jpni) ) 
     233         ibuffsize = jpimax * ipj * ipk * ipl * ipf 
     234         ! 
     235         ALLOCATE( ztab       (jpiglo,ipj,ipk,ipl,ipf     ) ) 
     236         ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) 
    195237         ! 
    196238         ! when some processors of the north fold are suppressed, 
     
    198240         ! and we need a default definition to 0. 
    199241         ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding 
    200          IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:)=0._wp 
    201          ! 
     242         IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp 
     243         ! 
     244         ! start waiting time measurement 
    202245         IF( ln_timing ) CALL tic_tac(.TRUE.) 
    203          ! 
    204          CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                & 
    205             &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
    206          ! 
     246         CALL MPI_ALLGATHER( znorthloc  , ibuffsize, MPI_DOUBLE_PRECISION,                & 
     247            &                znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     248         ! 
     249         ! stop waiting time measurement 
    207250         IF( ln_timing ) CALL tic_tac(.FALSE.) 
    208251         ! 
Note: See TracChangeset for help on using the changeset viewer.