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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 14574 for NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE – NEMO

Ignore:
Timestamp:
2021-03-03T16:04:57+01:00 (3 years ago)
Author:
hadcv
Message:

#2600: Merge in trunk changes to r14509

Location:
NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE
Files:
4 deleted
96 edited
3 copied

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/BDY/bdydyn2d.F90

    r13226 r14574  
    1818   USE bdylib          ! BDY library routines 
    1919   USE phycst          ! physical constants 
     20   USE lib_mpp, ONLY: jpfillnothing 
    2021   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2122   USE wet_dry         ! Use wet dry to get reference ssh level 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/BDY/bdydyn3d.F90

    r13226 r14574  
    1515   USE bdy_oce         ! ocean open boundary conditions 
    1616   USE bdylib          ! for orlanski library routines 
     17   USE lib_mpp, ONLY: jpfillnothing 
    1718   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    1819   USE in_out_manager  ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/BDY/bdyice.F90

    r13601 r14574  
    9292         IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN   ! if need to send/recv in at least one direction 
    9393            ! exchange 3d arrays 
    94             CALL lbc_lnk_multi('bdyice', a_i , 'T', 1._wp, h_i , 'T', 1._wp, h_s , 'T', 1._wp, oa_i, 'T', 1._wp                   & 
    95                &                       , s_i , 'T', 1._wp, t_su, 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp & 
    96                &                       , a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp                                     & 
    97                &                       , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     94            CALL lbc_lnk('bdyice', a_i , 'T', 1._wp, h_i , 'T', 1._wp, h_s , 'T', 1._wp, oa_i, 'T', 1._wp                   & 
     95               &                 , s_i , 'T', 1._wp, t_su, 'T', 1._wp, v_i , 'T', 1._wp, v_s , 'T', 1._wp, sv_i, 'T', 1._wp & 
     96               &                 , a_ip, 'T', 1._wp, v_ip, 'T', 1._wp, v_il, 'T', 1._wp                                     & 
     97               &                 , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    9898            ! exchange 4d arrays :   third dimension = 1   and then   third dimension = jpk 
    99             CALL lbc_lnk_multi('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    100             CALL lbc_lnk_multi('bdyice', t_i , 'T', 1._wp, e_i , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     99            CALL lbc_lnk('bdyice', t_s , 'T', 1._wp, e_s , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
     100            CALL lbc_lnk('bdyice', t_i , 'T', 1._wp, e_i , 'T', 1._wp, kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) 
    101101         END IF 
    102102      END DO   ! ir 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/BDY/bdyini.F90

    r13541 r14574  
    166166      ! Check and write out namelist parameters 
    167167      ! ----------------------------------------- 
    168       IF( jperio /= 0 )   CALL ctl_stop( 'bdy_segs: Cyclic or symmetric,',   & 
    169          &                               ' and general open boundary condition are not compatible' ) 
    170  
     168       
    171169      IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy 
    172170 
    … …  
    575573               ! check if point has to be sent     to   a neighbour 
    576574               ! W neighbour and on the inner left  side 
    577                IF( ii == 2     .and. (nbondi == 0 .or. nbondi ==  1) )   lsend_bdy(ib_bdy,igrd,1,ir) = .true. 
     575               IF( ii == 2     .AND. mpiSnei(nn_hls,jpwe) > -1 )   lsend_bdy(ib_bdy,igrd,jpwe,ir) = .TRUE. 
    578576               ! E neighbour and on the inner right side 
    579                IF( ii == jpi-1 .and. (nbondi == 0 .or. nbondi == -1) )   lsend_bdy(ib_bdy,igrd,2,ir) = .true. 
     577               IF( ii == jpi-1 .AND. mpiSnei(nn_hls,jpea) > -1 )   lsend_bdy(ib_bdy,igrd,jpea,ir) = .TRUE. 
    580578               ! S neighbour and on the inner down side 
    581                IF( ij == 2     .and. (nbondj == 0 .or. nbondj ==  1) )   lsend_bdy(ib_bdy,igrd,3,ir) = .true. 
     579               IF( ij == 2     .AND. mpiSnei(nn_hls,jpso) > -1 )   lsend_bdy(ib_bdy,igrd,jpso,ir) = .TRUE. 
    582580               ! N neighbour and on the inner up   side 
    583                IF( ij == jpj-1 .and. (nbondj == 0 .or. nbondj == -1) )   lsend_bdy(ib_bdy,igrd,4,ir) = .true. 
     581               IF( ij == jpj-1 .AND. mpiSnei(nn_hls,jpno) > -1 )   lsend_bdy(ib_bdy,igrd,jpno,ir) = .TRUE. 
    584582               ! 
    585583               ! check if point has to be received from a neighbour 
    586584               ! W neighbour and on the outter left  side 
    587                IF( ii == 1     .and. (nbondi == 0 .or. nbondi ==  1) )   lrecv_bdy(ib_bdy,igrd,1,ir) = .true. 
     585               IF( ii == 1     .AND. mpiRnei(nn_hls,jpwe) > -1 )   lrecv_bdy(ib_bdy,igrd,jpwe,ir) = .TRUE. 
    588586               ! E neighbour and on the outter right side 
    589                IF( ii == jpi   .and. (nbondi == 0 .or. nbondi == -1) )   lrecv_bdy(ib_bdy,igrd,2,ir) = .true. 
     587               IF( ii == jpi   .AND. mpiRnei(nn_hls,jpea) > -1 )   lrecv_bdy(ib_bdy,igrd,jpea,ir) = .TRUE. 
    590588               ! S neighbour and on the outter down side 
    591                IF( ij == 1     .and. (nbondj == 0 .or. nbondj ==  1) )   lrecv_bdy(ib_bdy,igrd,3,ir) = .true. 
     589               IF( ij == 1     .AND. mpiRnei(nn_hls,jpso) > -1 )   lrecv_bdy(ib_bdy,igrd,jpso,ir) = .TRUE. 
    592590               ! N neighbour and on the outter up   side 
    593                IF( ij == jpj   .and. (nbondj == 0 .or. nbondj == -1) )   lrecv_bdy(ib_bdy,igrd,4,ir) = .true. 
     591               IF( ij == jpj   .AND. mpiRnei(nn_hls,jpno) > -1 )   lrecv_bdy(ib_bdy,igrd,jpno,ir) = .TRUE. 
    594592               ! 
    595593            END DO 
    … …  
    654652         END DO 
    655653      END DO 
    656       CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1.0_wp , bdyvmask, 'V', 1.0_wp )   ! Lateral boundary cond.  
     654      CALL lbc_lnk( 'bdyini', bdyumask, 'U', 1.0_wp , bdyvmask, 'V', 1.0_wp )   ! Lateral boundary cond.  
    657655 
    658656      ! bdy masks are now set to zero on rim 0 points: 
    … …  
    739737               !      <--    (o exterior)     -->   
    740738               ! (1)  o|x         OR    (2)   x|o 
    741                !       |___                 ___|  
    742                IF( iibi == 0     .OR. ii1 == 0     .OR. ii2 == 0     .OR. ii3 == 0     )   lrecv_bdyint(ib_bdy,igrd,1,ir) = .true. 
    743                IF( iibi == jpi+1 .OR. ii1 == jpi+1 .OR. ii2 == jpi+1 .OR. ii3 == jpi+1 )   lrecv_bdyint(ib_bdy,igrd,2,ir) = .true.   
    744                IF( iibe == 0                                                           )   lrecv_bdyext(ib_bdy,igrd,1,ir) = .true. 
    745                IF( iibe == jpi+1                                                       )   lrecv_bdyext(ib_bdy,igrd,2,ir) = .true.   
     739               !       |___                 ___| 
     740               IF( iibi==0     .OR. ii1==0     .OR. ii2==0     .OR. ii3==0     )   lrecv_bdyint(ib_bdy,igrd,jpwe,ir) = .TRUE. 
     741               IF( iibi==jpi+1 .OR. ii1==jpi+1 .OR. ii2==jpi+1 .OR. ii3==jpi+1 )   lrecv_bdyint(ib_bdy,igrd,jpea,ir) = .TRUE.   
     742               IF( iibe==0                                                     )   lrecv_bdyext(ib_bdy,igrd,jpwe,ir) = .TRUE. 
     743               IF( iibe==jpi+1                                                 )   lrecv_bdyext(ib_bdy,igrd,jpea,ir) = .TRUE.   
    746744               ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo 
    747745               ! :¨¨¨¨¨|¨¨-->    |                                             |    <--¨¨|¨¨¨¨¨:  
    748746               ! :     |  x:o    |    neighbour limited by ... would need o    |    o:x  |     : 
    749747               ! :.....|_._:_____|   (1) W neighbour         E neighbour (2)   |_____:_._|.....: 
    750                IF( ii == 2     .AND. ( nbondi ==  1 .OR. nbondi == 0 ) .AND. & 
    751                   & ( iibi == 3     .OR. ii1 == 3     .OR. ii2 == 3     .OR. ii3 == 3    ) )   lsend_bdyint(ib_bdy,igrd,1,ir)=.true. 
    752                IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. & 
    753                   & ( iibi == jpi-2 .OR. ii1 == jpi-2 .OR. ii2 == jpi-2 .OR. ii3 == jpi-2) )   lsend_bdyint(ib_bdy,igrd,2,ir)=.true. 
    754                IF( ii == 2     .AND. ( nbondi ==  1 .OR. nbondi == 0 ) .AND. iibe == 3     )   lsend_bdyext(ib_bdy,igrd,1,ir)=.true. 
    755                IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. iibe == jpi-2 )   lsend_bdyext(ib_bdy,igrd,2,ir)=.true. 
     748               IF( ii==2     .AND. mpiSnei(nn_hls,jpwe) > -1 .AND. & 
     749                  & ( iibi==3     .OR. ii1==3     .OR. ii2==3     .OR. ii3==3    ) )   lsend_bdyint(ib_bdy,igrd,jpwe,ir) = .TRUE. 
     750               IF( ii==jpi-1 .AND. mpiSnei(nn_hls,jpea) > -1 .AND. & 
     751                  & ( iibi==jpi-2 .OR. ii1==jpi-2 .OR. ii2==jpi-2 .OR. ii3==jpi-2) )   lsend_bdyint(ib_bdy,igrd,jpea,ir) = .TRUE. 
     752               IF( ii==2     .AND. mpiSnei(nn_hls,jpwe) > -1 .AND. iibe==3     )   lsend_bdyext(ib_bdy,igrd,jpwe,ir) = .TRUE. 
     753               IF( ii==jpi-1 .AND. mpiSnei(nn_hls,jpea) > -1 .AND. iibe==jpi-2 )   lsend_bdyext(ib_bdy,igrd,jpea,ir) = .TRUE. 
    756754               ! 
    757755               ! search neighbour in the north/south direction    
    … …  
    760758               !  |   |___x___|   OR    |  |   x   | 
    761759               !  v       o           (4)  |       | 
    762                IF( ijbi == 0     .OR. ij1 == 0     .OR. ij2 == 0     .OR. ij3 == 0     )   lrecv_bdyint(ib_bdy,igrd,3,ir) = .true. 
    763                IF( ijbi == jpj+1 .OR. ij1 == jpj+1 .OR. ij2 == jpj+1 .OR. ij3 == jpj+1 )   lrecv_bdyint(ib_bdy,igrd,4,ir) = .true. 
    764                IF( ijbe == 0                                                           )   lrecv_bdyext(ib_bdy,igrd,3,ir) = .true. 
    765                IF( ijbe == jpj+1                                                       )   lrecv_bdyext(ib_bdy,igrd,4,ir) = .true. 
     760               IF( ijbi==0     .OR. ij1==0     .OR. ij2==0     .OR. ij3==0     )   lrecv_bdyint(ib_bdy,igrd,jpso,ir) = .TRUE. 
     761               IF( ijbi==jpj+1 .OR. ij1==jpj+1 .OR. ij2==jpj+1 .OR. ij3==jpj+1 )   lrecv_bdyint(ib_bdy,igrd,jpno,ir) = .TRUE. 
     762               IF( ijbe==0                                                     )   lrecv_bdyext(ib_bdy,igrd,jpso,ir) = .TRUE. 
     763               IF( ijbe==jpj+1                                                 )   lrecv_bdyext(ib_bdy,igrd,jpno,ir) = .TRUE. 
    766764               ! Check if neighbour has its rim parallel to its mpi subdomain     _________  border and next to its halo 
    767765               !   ^  |    o    |                                                :         :  
    768766               !   |  |¨¨¨¨x¨¨¨¨|   neighbour limited by ... would need o     |  |....x....| 
    769767               !      :_________:  (3) S neighbour          N neighbour (4)   v  |    o    |    
    770                IF( ij == 2     .AND. ( nbondj ==  1 .OR. nbondj == 0 ) .AND. & 
    771                   & ( ijbi == 3     .OR. ij1 == 3     .OR. ij2 == 3     .OR. ij3 == 3    ) )   lsend_bdyint(ib_bdy,igrd,3,ir)=.true. 
    772                IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. & 
    773                   & ( ijbi == jpj-2 .OR. ij1 == jpj-2 .OR. ij2 == jpj-2 .OR. ij3 == jpj-2) )   lsend_bdyint(ib_bdy,igrd,4,ir)=.true. 
    774                IF( ij == 2     .AND. ( nbondj ==  1 .OR. nbondj == 0 ) .AND. ijbe == 3     )   lsend_bdyext(ib_bdy,igrd,3,ir)=.true. 
    775                IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. ijbe == jpj-2 )   lsend_bdyext(ib_bdy,igrd,4,ir)=.true. 
     768               IF( ij==2     .AND. mpiSnei(nn_hls,jpso) > -1 .AND. & 
     769                  & ( ijbi==3     .OR. ij1==3     .OR. ij2==3     .OR. ij3==3    ) )   lsend_bdyint(ib_bdy,igrd,jpso,ir) = .TRUE. 
     770               IF( ij==jpj-1 .AND. mpiSnei(nn_hls,jpno) > -1 .AND. & 
     771                  & ( ijbi==jpj-2 .OR. ij1==jpj-2 .OR. ij2==jpj-2 .OR. ij3==jpj-2) )   lsend_bdyint(ib_bdy,igrd,jpno,ir) = .TRUE. 
     772               IF( ij==2     .AND. mpiSnei(nn_hls,jpso) > -1 .AND. ijbe==3     )   lsend_bdyext(ib_bdy,igrd,jpso,ir) = .TRUE. 
     773               IF( ij==jpj-1 .AND. mpiSnei(nn_hls,jpno) > -1 .AND. ijbe==jpj-2 )   lsend_bdyext(ib_bdy,igrd,jpno,ir) = .TRUE. 
    776774            END DO 
    777775         END DO 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/BDY/bdytra.F90

    r14537 r14574  
    1818   ! 
    1919   USE in_out_manager ! I/O manager 
     20   USE lib_mpp, ONLY: jpfillnothing 
    2021   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
    2122   USE lib_mpp, ONLY: ctl_stop 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/CRS/crs.F90

    r13286 r14574  
    3232      INTEGER  ::  jpi_crsm1, jpj_crsm1         !: loop indices       
    3333      INTEGER  ::  jpiglo_crsm1, jpjglo_crsm1   !: loop indices       
    34       INTEGER  ::  nperio_full, nperio_crs      !: jperio of parent and coarse grids 
    35       INTEGER  ::  npolj_full, npolj_crs        !: north fold mark 
     34!!$      INTEGER  ::  nperio_full, nperio_crs      !: jperio of parent and coarse grids 
     35!!$      INTEGER  ::  npolj_full, npolj_crs        !: north fold mark 
    3636      INTEGER  ::  jpiglo_full, jpjglo_full     !: jpiglo / jpjglo 
    3737      INTEGER  ::  npiglo, npjglo               !: jpjglo 
    … …  
    4646      INTEGER  ::  nimpp_full, njmpp_full       !: global position of point (1,1) of subdomain on parent grid 
    4747      INTEGER  ::  nimpp_crs, njmpp_crs         !: set to 1,1 for now .  Valid only for monoproc 
    48       !cc 
    49       INTEGER ::   noea_full, nowe_full        !: index of the local neighboring processors in 
    50       INTEGER ::   noso_full, nono_full        !: east, west, south and north directions 
    51       INTEGER ::   npne_full, npnw_full        !: index of north east and north west processor 
    52       INTEGER ::   npse_full, npsw_full        !: index of south east and south west processor 
    53       INTEGER ::   nbne_full, nbnw_full        !: logical of north east & north west processor 
    54       INTEGER ::   nbse_full, nbsw_full        !: logical of south east & south west processor 
    55       INTEGER ::   nidom_full                  !: ??? 
    56       INTEGER ::   nproc_full                  !:number for local processor 
    57       INTEGER ::   nbondi_full, nbondj_full    !: mark of i- and j-direction local boundaries 
    58       INTEGER ::   noea_crs, nowe_crs          !: index of the local neighboring processors in 
    59       INTEGER ::   noso_crs, nono_crs          !: east, west, south and north directions 
    60       INTEGER ::   npne_crs, npnw_crs          !: index of north east and north west processor 
    61       INTEGER ::   npse_crs, npsw_crs          !: index of south east and south west processor 
    62       INTEGER ::   nbne_crs, nbnw_crs          !: logical of north east & north west processor 
    63       INTEGER ::   nbse_crs, nbsw_crs          !: logical of south east & south west processor 
    64       INTEGER ::   nidom_crs                   !: ??? 
    65       INTEGER ::   nproc_crs                   !:number for local processor 
    66       INTEGER ::   nbondi_crs, nbondj_crs      !: mark of i- and j-direction local boundaries 
    67        
    68  
     48      
    6949      INTEGER, DIMENSION(:), ALLOCATABLE :: mis_crs, mie_crs, mis2_crs, mie2_crs  ! starting and ending i-indices of parent subset 
    7050      INTEGER, DIMENSION(:), ALLOCATABLE :: mjs_crs, mje_crs, mjs2_crs, mje2_crs ! starting and ending  j-indices of parent subset 
    … …  
    7252      INTEGER, DIMENSION(:), ALLOCATABLE :: mi0_crs, mi1_crs, mj0_crs, mj1_crs 
    7353      INTEGER  :: mxbinctr, mybinctr            ! central point in grid box 
    74       INTEGER, DIMENSION(:), ALLOCATABLE ::    jpiall_crs,  jpiall_full   !: dimensions of every subdomain 
    75       INTEGER, DIMENSION(:), ALLOCATABLE ::   nis0all_crs, nis0all_full   !: first, last indoor index for each i-domain 
    76       INTEGER, DIMENSION(:), ALLOCATABLE ::   nie0all_crs, nie0all_full   !: first, last indoor index for each j-domain 
    77       INTEGER, DIMENSION(:), ALLOCATABLE ::    nimppt_crs,  nimppt_full   !: first, last indoor index for each j-domain 
    78       INTEGER, DIMENSION(:), ALLOCATABLE ::    jpjall_crs,  jpjall_full   !: dimensions of every subdomain 
    79       INTEGER, DIMENSION(:), ALLOCATABLE ::   njs0all_crs, njs0all_full   !: first, last indoor index for each i-domain 
    80       INTEGER, DIMENSION(:), ALLOCATABLE ::   nje0all_crs, nje0all_full   !: first, last indoor index for each j-domain 
    81       INTEGER, DIMENSION(:), ALLOCATABLE ::    njmppt_crs,  njmppt_full   !: first, last indoor index for each j-domain 
     54!!$      INTEGER, DIMENSION(:), ALLOCATABLE ::    jpiall_crs,  jpiall_full   !: dimensions of every subdomain 
     55!!$      INTEGER, DIMENSION(:), ALLOCATABLE ::   nis0all_crs, nis0all_full   !: first, last indoor index for each i-domain 
     56!!$      INTEGER, DIMENSION(:), ALLOCATABLE ::   nie0all_crs, nie0all_full   !: first, last indoor index for each j-domain 
     57!!$      INTEGER, DIMENSION(:), ALLOCATABLE ::    nimppt_crs,  nimppt_full   !: first, last indoor index for each j-domain 
     58!!$      INTEGER, DIMENSION(:), ALLOCATABLE ::    jpjall_crs,  jpjall_full   !: dimensions of every subdomain 
     59!!$      INTEGER, DIMENSION(:), ALLOCATABLE ::   njs0all_crs, njs0all_full   !: first, last indoor index for each i-domain 
     60!!$      INTEGER, DIMENSION(:), ALLOCATABLE ::   nje0all_crs, nje0all_full   !: first, last indoor index for each j-domain 
     61!!$      INTEGER, DIMENSION(:), ALLOCATABLE ::    njmppt_crs,  njmppt_full   !: first, last indoor index for each j-domain 
    8262 
    8363  
    … …  
    231211         &      hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) ) 
    232212          
    233       ALLOCATE( nimppt_crs (jpnij) , jpiall_crs (jpnij) , nis0all_crs (jpnij) , nie0all_crs (jpnij),   & 
    234          &      nimppt_full(jpnij) , jpiall_full(jpnij) , nis0all_full(jpnij) , nie0all_full(jpnij),   & 
    235                 njmppt_crs (jpnij) , jpjall_crs (jpnij) , njs0all_crs (jpnij) , nje0all_crs (jpnij),   & 
    236          &      njmppt_full(jpnij) , jpjall_full(jpnij) , njs0all_full(jpnij) , nje0all_full(jpnij)  , STAT=ierr(15) ) 
     213!!$      ALLOCATE( nimppt_crs (jpnij) , jpiall_crs (jpnij) , nis0all_crs (jpnij) , nie0all_crs (jpnij),   & 
     214!!$         &      nimppt_full(jpnij) , jpiall_full(jpnij) , nis0all_full(jpnij) , nie0all_full(jpnij),   & 
     215!!$                njmppt_crs (jpnij) , jpjall_crs (jpnij) , njs0all_crs (jpnij) , nje0all_crs (jpnij),   & 
     216!!$         &      njmppt_full(jpnij) , jpjall_full(jpnij) , njs0all_full(jpnij) , nje0all_full(jpnij)  , STAT=ierr(15) ) 
    237217    
    238218      crs_dom_alloc = MAXVAL(ierr) 
    … …  
    269249      jpim1  = jpim1_full 
    270250      jpjm1  = jpjm1_full 
    271       jperio = nperio_full 
    272  
    273       npolj  = npolj_full 
     251!!$      jperio = nperio_full 
     252 
     253!!$      npolj  = npolj_full 
    274254      jpiglo = jpiglo_full 
    275255      jpjglo = jpjglo_full 
    … …  
    284264      njmpp = njmpp_full 
    285265       
    286       jpiall (:) = jpiall_full (:) 
    287       nis0all(:) = nis0all_full(:) 
    288       nie0all(:) = nie0all_full(:) 
    289       nimppt (:) = nimppt_full (:) 
    290       jpjall (:) = jpjall_full (:) 
    291       njs0all(:) = njs0all_full(:) 
    292       nje0all(:) = nje0all_full(:) 
    293       njmppt (:) = njmppt_full (:) 
     266!!$      jpiall (:) = jpiall_full (:) 
     267!!$      nis0all(:) = nis0all_full(:) 
     268!!$      nie0all(:) = nie0all_full(:) 
     269!!$      nimppt (:) = nimppt_full (:) 
     270!!$      jpjall (:) = jpjall_full (:) 
     271!!$      njs0all(:) = njs0all_full(:) 
     272!!$      nje0all(:) = nje0all_full(:) 
     273!!$      njmppt (:) = njmppt_full (:) 
    294274 
    295275   END SUBROUTINE dom_grid_glo 
    … …  
    308288      jpim1  = jpi_crsm1 
    309289      jpjm1  = jpj_crsm1 
    310       jperio = nperio_crs 
    311  
    312       npolj  = npolj_crs 
     290!!$      jperio = nperio_crs 
     291 
     292!!$      npolj  = npolj_crs 
    313293      jpiglo = jpiglo_crs 
    314294      jpjglo = jpjglo_crs 
    … …  
    324304      njmpp = njmpp_crs 
    325305       
    326       jpiall (:) = jpiall_crs (:) 
    327       nis0all(:) = nis0all_crs(:) 
    328       nie0all(:) = nie0all_crs(:) 
    329       nimppt (:) = nimppt_crs (:) 
    330       jpjall (:) = jpjall_crs (:) 
    331       njs0all(:) = njs0all_crs(:) 
    332       nje0all(:) = nje0all_crs(:) 
    333       njmppt (:) = njmppt_crs (:) 
     306!!$      jpiall (:) = jpiall_crs (:) 
     307!!$      nis0all(:) = nis0all_crs(:) 
     308!!$      nie0all(:) = nie0all_crs(:) 
     309!!$      nimppt (:) = nimppt_crs (:) 
     310!!$      jpjall (:) = jpjall_crs (:) 
     311!!$      njs0all(:) = njs0all_crs(:) 
     312!!$      nje0all(:) = nje0all_crs(:) 
     313!!$      njmppt (:) = njmppt_crs (:) 
    334314      ! 
    335315   END SUBROUTINE dom_grid_crs 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/CRS/crsdom.F90

    r13286 r14574  
    3030   !!       Original.   May 2012.  (J. Simeon, C. Calone, G. Madec, C. Ethe) 
    3131   !!=================================================================== 
    32    USE dom_oce        ! ocean space and time domain and to get jperio 
     32   USE dom_oce        ! ocean space and time domain 
    3333   USE crs            ! domain for coarse grid 
    3434   ! 
    … …  
    18771877  
    18781878   
    1879      ! 1.a. Define global domain indices  : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points  
    1880       jpiglo_crs   = INT( (jpiglo - 2) / nn_factx ) + 2 
    1881   !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 2  ! the -2 removes j=1, j=jpj 
    1882   !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 3 
    1883       jpjglo_crs   = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3 
    1884       jpiglo_crsm1 = jpiglo_crs - 1 
    1885       jpjglo_crsm1 = jpjglo_crs - 1   
    1886  
    1887       jpi_crs = ( jpiglo_crs   - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls 
    1888       jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls    
    1889                
    1890       IF( noso < 0 ) jpj_crs = jpj_crs + 1    ! add a local band on southern processors   
    1891         
    1892       jpi_crsm1   = jpi_crs - 1 
    1893       jpj_crsm1   = jpj_crs - 1 
    1894       nperio_crs  = jperio 
    1895       npolj_crs   = npolj 
    1896        
    1897       ierr = crs_dom_alloc()          ! allocate most coarse grid arrays 
    1898  
    1899       ! 2.a Define processor domain 
    1900       IF( .NOT. lk_mpp ) THEN 
    1901          nimpp_crs = 1 
    1902          njmpp_crs = 1 
    1903          Nis0_crs  = 1 
    1904          Njs0_crs  = 1 
    1905          Nie0_crs  = jpi_crs 
    1906          Nje0_crs  = jpj_crs 
    1907       ELSE 
    1908          ! Initialisation of most local variables - 
    1909          nimpp_crs = 1 
    1910          njmpp_crs = 1 
    1911          Nis0_crs  = 1 
    1912          Njs0_crs  = 1 
    1913          Nie0_crs  = jpi_crs 
    1914          Nje0_crs  = jpj_crs 
    1915           
    1916         ! Calculs suivant une découpage en j 
    1917         DO jn = 1, jpnij, jpni 
    1918            IF( jn < ( jpnij - jpni + 1 ) ) THEN 
    1919               nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn     ) - 1) ) / nn_facty, wp ) ) & 
    1920                        &    - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) ) 
    1921            ELSE                                              
    1922               nje0all_crs(jn) = AINT( REAL(  nje0all(jn) / nn_facty, wp ) ) + 1             
    1923            ENDIF 
    1924            IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1              
    1925            SELECT CASE( ibonjt(jn) ) 
    1926               CASE ( -1 ) 
    1927                 IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 )  nje0all_crs(jn) = nje0all_crs(jn) + 1 
    1928                 jpjall_crs (jn) = nje0all_crs(jn) + nn_hls 
    1929                 njs0all_crs(jn) = njs0all(jn) 
    1930                
    1931               CASE ( 0 ) 
    1932                
    1933                 njs0all_crs(jn) = njs0all(jn) 
    1934                 IF( njs0all(jn) == 1 )  nje0all_crs(jn) = nje0all_crs(jn) + 1 
    1935                 nje0all_crs(jn) = nje0all_crs(jn) + nn_hls 
    1936                 jpjall_crs (jn) = nje0all_crs(jn) + nn_hls 
    1937                  
    1938               CASE ( 1, 2 ) 
    1939                
    1940                 nje0all_crs(jn) = nje0all_crs(jn) + nn_hls 
    1941                 jpjall_crs (jn) = nje0all_crs(jn) 
    1942                 njs0all_crs(jn) = njs0all(jn) 
    1943                  
    1944               CASE DEFAULT 
    1945                  CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' ) 
    1946            END SELECT 
    1947            IF( jpjall_crs(jn) > jpj_crs )     jpj_crs = jpj_crs + 1 
    1948  
    1949            IF(njs0all_crs(jn) == 1 ) THEN 
    1950               njmppt_crs(jn) = 1 
    1951            ELSE 
    1952               njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) ) 
    1953            ENDIF            
    1954             
    1955            DO jj = jn + 1, jn + jpni - 1 
    1956               nje0all_crs(jj) = nje0all_crs(jn)  
    1957               jpjall_crs (jj) = jpjall_crs(jn) 
    1958               njs0all_crs(jj) = njs0all_crs(jn) 
    1959               njmppt_crs (jj) = njmppt_crs(jn) 
    1960            ENDDO 
    1961         ENDDO  
    1962         Nje0_crs  = nje0all_crs(nproc + 1)  
    1963         jpj_crs   = jpjall_crs (nproc + 1) 
    1964         Njs0_crs  = njs0all_crs(nproc + 1) 
    1965         njmpp_crs = njmppt_crs (nproc + 1) 
    1966  
    1967         ! Calcul suivant un decoupage en i 
    1968         DO jn = 1, jpni 
    1969            IF( jn == 1 ) THEN           
    1970               nie0all_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + jpiall(jn  ) )  / nn_factx, wp) ) 
    1971            ELSE 
    1972               nie0all_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + jpiall(jn  ) )  / nn_factx, wp) ) & 
    1973                  &            - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) )  / nn_factx, wp) ) 
    1974            ENDIF 
    1975  
    1976            SELECT CASE( ibonit(jn) ) 
    1977               CASE ( -1 ) 
    1978                  nie0all_crs(jn) = nie0all_crs(jn) + nn_hls            
    1979                  jpiall_crs (jn) = nie0all_crs(jn) + nn_hls 
    1980                  nis0all_crs(jn) = nis0all(jn)  
    1981                
    1982               CASE ( 0 ) 
    1983                  nie0all_crs(jn) = nie0all_crs(jn) + nn_hls 
    1984                  jpiall_crs (jn) = nie0all_crs(jn) + nn_hls 
    1985                  nis0all_crs(jn) = nis0all(jn)  
    1986                  
    1987               CASE ( 1, 2 ) 
    1988                  IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 )  nie0all_crs(jn) = nie0all_crs(jn) + 1 
    1989                  nie0all_crs(jn) = nie0all_crs(jn) + nn_hls 
    1990                  jpiall_crs (jn) = nie0all_crs(jn) 
    1991                  nis0all_crs(jn) = nis0all(jn)  
    1992  
    1993               CASE DEFAULT 
    1994                  CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' ) 
    1995            END SELECT 
    1996  
    1997            nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 
    1998            DO jj = jn + jpni , jpnij, jpni 
    1999               nie0all_crs(jj) = nie0all_crs(jn)  
    2000               jpiall_crs (jj) = jpiall_crs (jn) 
    2001               nis0all_crs(jj) = nis0all_crs(jn) 
    2002               nimppt_crs (jj) = nimppt_crs (jn) 
    2003            ENDDO 
    2004          ENDDO  
    2005          
    2006          Nie0_crs  = nie0all_crs(nproc + 1)  
    2007          jpi_crs   = jpiall_crs (nproc + 1) 
    2008          Nis0_crs  = nis0all_crs(nproc + 1) 
    2009          nimpp_crs = nimppt_crs (nproc + 1) 
    2010  
    2011          DO ji = 1, jpi_crs 
    2012             mig_crs(ji) = ji + nimpp_crs - 1 
    2013          ENDDO 
    2014          DO jj = 1, jpj_crs 
    2015             mjg_crs(jj) = jj + njmpp_crs - 1! 
    2016          ENDDO 
    2017         
    2018          DO ji = 1, jpiglo_crs 
    2019             mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) 
    2020             mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs     ) ) 
    2021          ENDDO 
    2022           
    2023          DO jj = 1, jpjglo_crs 
    2024             mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) 
    2025             mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs     ) ) 
    2026          ENDDO 
    2027  
    2028       ENDIF 
    2029        
    2030       !                         Save the parent grid information 
    2031       jpi_full    = jpi 
    2032       jpj_full    = jpj 
    2033       jpim1_full  = jpim1 
    2034       jpjm1_full  = jpjm1 
    2035       nperio_full = jperio 
    2036  
    2037       npolj_full  = npolj 
    2038       jpiglo_full = jpiglo 
    2039       jpjglo_full = jpjglo 
    2040  
    2041       jpj_full   = jpj 
    2042       jpi_full   = jpi 
    2043       Nis0_full  = Nis0 
    2044       Njs0_full  = Njs0 
    2045       Nie0_full  = Nie0 
    2046       Nje0_full  = Nje0 
    2047       nimpp_full = nimpp      
    2048       njmpp_full = njmpp 
    2049        
    2050       jpiall_full (:) = jpiall (:) 
    2051       nis0all_full(:) = nis0all(:) 
    2052       nie0all_full(:) = nie0all(:) 
    2053       nimppt_full (:) = nimppt (:) 
    2054       jpjall_full (:) = jpjall (:) 
    2055       njs0all_full(:) = njs0all(:) 
    2056       nje0all_full(:) = nje0all(:) 
    2057       njmppt_full (:) = njmppt (:) 
     1879!!$     ! 1.a. Define global domain indices  : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points  
     1880!!$      jpiglo_crs   = INT( (jpiglo - 2) / nn_factx ) + 2 
     1881!!$  !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 2  ! the -2 removes j=1, j=jpj 
     1882!!$  !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 3 
     1883!!$      jpjglo_crs   = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3 
     1884!!$      jpiglo_crsm1 = jpiglo_crs - 1 
     1885!!$      jpjglo_crsm1 = jpjglo_crs - 1   
     1886!!$ 
     1887!!$      jpi_crs = ( jpiglo_crs   - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls 
     1888!!$      jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls    
     1889!!$               
     1890!!$      IF( noso < 0 ) jpj_crs = jpj_crs + 1    ! add a local band on southern processors   
     1891!!$        
     1892!!$      jpi_crsm1   = jpi_crs - 1 
     1893!!$      jpj_crsm1   = jpj_crs - 1 
     1894!!$      nperio_crs  = jperio 
     1895!!$      npolj_crs   = npolj 
     1896!!$       
     1897!!$      ierr = crs_dom_alloc()          ! allocate most coarse grid arrays 
     1898!!$ 
     1899!!$      ! 2.a Define processor domain 
     1900!!$      IF( .NOT. lk_mpp ) THEN 
     1901!!$         nimpp_crs = 1 
     1902!!$         njmpp_crs = 1 
     1903!!$         Nis0_crs  = 1 
     1904!!$         Njs0_crs  = 1 
     1905!!$         Nie0_crs  = jpi_crs 
     1906!!$         Nje0_crs  = jpj_crs 
     1907!!$      ELSE 
     1908!!$         ! Initialisation of most local variables - 
     1909!!$         nimpp_crs = 1 
     1910!!$         njmpp_crs = 1 
     1911!!$         Nis0_crs  = 1 
     1912!!$         Njs0_crs  = 1 
     1913!!$         Nie0_crs  = jpi_crs 
     1914!!$         Nje0_crs  = jpj_crs 
     1915!!$          
     1916!!$        ! Calculs suivant une découpage en j 
     1917!!$        DO jn = 1, jpnij, jpni 
     1918!!$           IF( jn < ( jpnij - jpni + 1 ) ) THEN 
     1919!!$              nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn     ) - 1) ) / nn_facty, wp ) ) & 
     1920!!$                       &    - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) ) 
     1921!!$           ELSE                                              
     1922!!$              nje0all_crs(jn) = AINT( REAL(  nje0all(jn) / nn_facty, wp ) ) + 1             
     1923!!$           ENDIF 
     1924!!$           IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1              
     1925!!$           SELECT CASE( ibonjt(jn) ) 
     1926!!$              CASE ( -1 ) 
     1927!!$                IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 )  nje0all_crs(jn) = nje0all_crs(jn) + 1 
     1928!!$                jpjall_crs (jn) = nje0all_crs(jn) + nn_hls 
     1929!!$                njs0all_crs(jn) = njs0all(jn) 
     1930!!$               
     1931!!$              CASE ( 0 ) 
     1932!!$               
     1933!!$                njs0all_crs(jn) = njs0all(jn) 
     1934!!$                IF( njs0all(jn) == 1 )  nje0all_crs(jn) = nje0all_crs(jn) + 1 
     1935!!$                nje0all_crs(jn) = nje0all_crs(jn) + nn_hls 
     1936!!$                jpjall_crs (jn) = nje0all_crs(jn) + nn_hls 
     1937!!$                 
     1938!!$              CASE ( 1, 2 ) 
     1939!!$               
     1940!!$                nje0all_crs(jn) = nje0all_crs(jn) + nn_hls 
     1941!!$                jpjall_crs (jn) = nje0all_crs(jn) 
     1942!!$                njs0all_crs(jn) = njs0all(jn) 
     1943!!$                 
     1944!!$              CASE DEFAULT 
     1945!!$                 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' ) 
     1946!!$           END SELECT 
     1947!!$           IF( jpjall_crs(jn) > jpj_crs )     jpj_crs = jpj_crs + 1 
     1948!!$ 
     1949!!$           IF(njs0all_crs(jn) == 1 ) THEN 
     1950!!$              njmppt_crs(jn) = 1 
     1951!!$           ELSE 
     1952!!$              njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) ) 
     1953!!$           ENDIF            
     1954!!$            
     1955!!$           DO jj = jn + 1, jn + jpni - 1 
     1956!!$              nje0all_crs(jj) = nje0all_crs(jn)  
     1957!!$              jpjall_crs (jj) = jpjall_crs(jn) 
     1958!!$              njs0all_crs(jj) = njs0all_crs(jn) 
     1959!!$              njmppt_crs (jj) = njmppt_crs(jn) 
     1960!!$           ENDDO 
     1961!!$        ENDDO  
     1962!!$        Nje0_crs  = nje0all_crs(narea)  
     1963!!$        jpj_crs   = jpjall_crs (narea) 
     1964!!$        Njs0_crs  = njs0all_crs(narea) 
     1965!!$        njmpp_crs = njmppt_crs (narea) 
     1966!!$ 
     1967!!$        ! Calcul suivant un decoupage en i 
     1968!!$        DO jn = 1, jpni 
     1969!!$           IF( jn == 1 ) THEN           
     1970!!$              nie0all_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + jpiall(jn  ) )  / nn_factx, wp) ) 
     1971!!$           ELSE 
     1972!!$              nie0all_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + jpiall(jn  ) )  / nn_factx, wp) ) & 
     1973!!$                 &            - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) )  / nn_factx, wp) ) 
     1974!!$           ENDIF 
     1975!!$ 
     1976!!$           SELECT CASE( ibonit(jn) ) 
     1977!!$              CASE ( -1 ) 
     1978!!$                 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls            
     1979!!$                 jpiall_crs (jn) = nie0all_crs(jn) + nn_hls 
     1980!!$                 nis0all_crs(jn) = nis0all(jn)  
     1981!!$               
     1982!!$              CASE ( 0 ) 
     1983!!$                 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls 
     1984!!$                 jpiall_crs (jn) = nie0all_crs(jn) + nn_hls 
     1985!!$                 nis0all_crs(jn) = nis0all(jn)  
     1986!!$                 
     1987!!$              CASE ( 1, 2 ) 
     1988!!$                 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 )  nie0all_crs(jn) = nie0all_crs(jn) + 1 
     1989!!$                 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls 
     1990!!$                 jpiall_crs (jn) = nie0all_crs(jn) 
     1991!!$                 nis0all_crs(jn) = nis0all(jn)  
     1992!!$ 
     1993!!$              CASE DEFAULT 
     1994!!$                 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' ) 
     1995!!$           END SELECT 
     1996!!$ 
     1997!!$           nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 
     1998!!$           DO jj = jn + jpni , jpnij, jpni 
     1999!!$              nie0all_crs(jj) = nie0all_crs(jn)  
     2000!!$              jpiall_crs (jj) = jpiall_crs (jn) 
     2001!!$              nis0all_crs(jj) = nis0all_crs(jn) 
     2002!!$              nimppt_crs (jj) = nimppt_crs (jn) 
     2003!!$           ENDDO 
     2004!!$         ENDDO  
     2005!!$         
     2006!!$         Nie0_crs  = nie0all_crs(narea)  
     2007!!$         jpi_crs   = jpiall_crs (narea) 
     2008!!$         Nis0_crs  = nis0all_crs(narea) 
     2009!!$         nimpp_crs = nimppt_crs (narea) 
     2010!!$ 
     2011!!$         DO ji = 1, jpi_crs 
     2012!!$            mig_crs(ji) = ji + nimpp_crs - 1 
     2013!!$         ENDDO 
     2014!!$         DO jj = 1, jpj_crs 
     2015!!$            mjg_crs(jj) = jj + njmpp_crs - 1! 
     2016!!$         ENDDO 
     2017!!$        
     2018!!$         DO ji = 1, jpiglo_crs 
     2019!!$            mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) 
     2020!!$            mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs     ) ) 
     2021!!$         ENDDO 
     2022!!$          
     2023!!$         DO jj = 1, jpjglo_crs 
     2024!!$            mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) 
     2025!!$            mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs     ) ) 
     2026!!$         ENDDO 
     2027!!$ 
     2028!!$      ENDIF 
     2029!!$       
     2030!!$      !                         Save the parent grid information 
     2031!!$      jpi_full    = jpi 
     2032!!$      jpj_full    = jpj 
     2033!!$      jpim1_full  = jpim1 
     2034!!$      jpjm1_full  = jpjm1 
     2035!!$      nperio_full = jperio 
     2036!!$ 
     2037!!$      npolj_full  = npolj 
     2038!!$      jpiglo_full = jpiglo 
     2039!!$      jpjglo_full = jpjglo 
     2040!!$ 
     2041!!$      jpj_full   = jpj 
     2042!!$      jpi_full   = jpi 
     2043!!$      Nis0_full  = Nis0 
     2044!!$      Njs0_full  = Njs0 
     2045!!$      Nie0_full  = Nie0 
     2046!!$      Nje0_full  = Nje0 
     2047!!$      nimpp_full = nimpp      
     2048!!$      njmpp_full = njmpp 
     2049!!$       
     2050!!$      jpiall_full (:) = jpiall (:) 
     2051!!$      nis0all_full(:) = nis0all(:) 
     2052!!$      nie0all_full(:) = nie0all(:) 
     2053!!$      nimppt_full (:) = nimppt (:) 
     2054!!$      jpjall_full (:) = jpjall (:) 
     2055!!$      njs0all_full(:) = njs0all(:) 
     2056!!$      nje0all_full(:) = nje0all(:) 
     2057!!$      njmppt_full (:) = njmppt (:) 
    20582058       
    20592059      CALL dom_grid_crs  !swich de grille 
    … …  
    20682068         WRITE(numout,*) '~~~~~~~   coarse domain local  j-dimension              jpj = ', jpj 
    20692069         WRITE(numout,*) 
    2070          WRITE(numout,*) ' nproc  = '     , nproc 
     2070         WRITE(numout,*) ' narea  = '     , narea 
    20712071         WRITE(numout,*) ' jpi    = '     , jpi 
    20722072         WRITE(numout,*) ' jpj    = '     , jpj 
    … …  
    20972097      IF ( nresty == 0 ) THEN 
    20982098         mybinctr = mybinctr - 1 
    2099          IF ( jperio == 3 .OR. jperio == 4 )  nperio_crs = jperio + 2 
    2100          IF ( jperio == 5 .OR. jperio == 6 )  nperio_crs = jperio - 2  
    2101  
    2102          IF ( npolj == 3 ) npolj_crs = 5 
    2103          IF ( npolj == 5 ) npolj_crs = 3 
     2099!!$         IF ( jperio == 3 .OR. jperio == 4 )  nperio_crs = jperio + 2 
     2100!!$         IF ( jperio == 5 .OR. jperio == 6 )  nperio_crs = jperio - 2  
     2101!!$ 
     2102!!$         IF ( npolj == 3 ) npolj_crs = 5 
     2103!!$         IF ( npolj == 5 ) npolj_crs = 3 
    21042104      ENDIF      
    21052105       
    … …  
    21172117      CASE ( 0 )  
    21182118 
    2119          SELECT CASE ( jperio ) 
    2120       
    2121   
    2122         CASE ( 0, 1, 3, 4 )    !   3, 4 : T-Pivot at North Fold 
    2123          
    2124             DO ji = 2, jpiglo_crsm1 
    2125                ijie = ( ji * nn_factx ) - nn_factx   !cc 
    2126                ijis = ijie - nn_factx + 1 
    2127                mis2_crs(ji) = ijis 
    2128                mie2_crs(ji) = ijie 
    2129             ENDDO 
    2130             IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 2   
    2131  
    2132             ! Handle first the northernmost bin 
    2133             IF ( nn_facty == 2 ) THEN   ;    ijjgloT = jpjglo - 1  
    2134             ELSE                        ;    ijjgloT = jpjglo 
    2135             ENDIF 
    2136  
    2137             DO jj = 2, jpjglo_crs 
    2138                 ijje = ijjgloT - nn_facty * ( jj - 3 ) 
    2139                 ijjs = ijje - nn_facty + 1                    
    2140                 mjs2_crs(jpjglo_crs-jj+2) = ijjs 
    2141                 mje2_crs(jpjglo_crs-jj+2) = ijje 
    2142             ENDDO 
    2143  
    2144          CASE ( 2 )  
    2145             WRITE(numout,*)  'crs_init, jperio=2 not supported'  
    2146          
    2147          CASE ( 5, 6 )    ! F-pivot at North Fold 
    2148  
    2149             DO ji = 2, jpiglo_crsm1 
    2150                ijie = ( ji * nn_factx ) - nn_factx  
    2151                ijis = ijie - nn_factx + 1 
    2152                mis2_crs(ji) = ijis 
    2153                mie2_crs(ji) = ijie 
    2154             ENDDO 
    2155             IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1)  = jpiglo - 2  
    2156  
    2157             ! Treat the northernmost bin separately. 
    2158             jj = 2 
    2159             ijje = jpj - nn_facty * ( jj - 2 ) 
    2160             IF ( nn_facty == 3 ) THEN   ;  ijjs = ijje - 1  
    2161             ELSE                        ;  ijjs = ijje - nn_facty + 1 
    2162             ENDIF 
    2163             mjs2_crs(jpj_crs-jj+1) = ijjs 
    2164             mje2_crs(jpj_crs-jj+1) = ijje 
    2165  
    2166             ! Now bin the rest, any remainder at the south is lumped in the southern bin 
    2167             DO jj = 3, jpjglo_crsm1 
    2168                 ijje = jpjglo - nn_facty * ( jj - 2 ) 
    2169                 ijjs = ijje - nn_facty + 1                   
    2170                 IF ( ijjs <= nn_facty )  ijjs = 2 
    2171                 mjs2_crs(jpj_crs-jj+1)   = ijjs 
    2172                 mje2_crs(jpj_crs-jj+1)   = ijje 
    2173             ENDDO 
    2174  
    2175          CASE DEFAULT 
    2176             WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported'  
    2177   
    2178          END SELECT 
     2119!!$         SELECT CASE ( jperio ) 
     2120!!$      
     2121!!$  
     2122!!$        CASE ( 0, 1, 3, 4 )    !   3, 4 : T-Pivot at North Fold 
     2123!!$         
     2124!!$            DO ji = 2, jpiglo_crsm1 
     2125!!$               ijie = ( ji * nn_factx ) - nn_factx   !cc 
     2126!!$               ijis = ijie - nn_factx + 1 
     2127!!$               mis2_crs(ji) = ijis 
     2128!!$               mie2_crs(ji) = ijie 
     2129!!$            ENDDO 
     2130!!$            IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 2   
     2131!!$ 
     2132!!$            ! Handle first the northernmost bin 
     2133!!$            IF ( nn_facty == 2 ) THEN   ;    ijjgloT = jpjglo - 1  
     2134!!$            ELSE                        ;    ijjgloT = jpjglo 
     2135!!$            ENDIF 
     2136!!$ 
     2137!!$            DO jj = 2, jpjglo_crs 
     2138!!$                ijje = ijjgloT - nn_facty * ( jj - 3 ) 
     2139!!$                ijjs = ijje - nn_facty + 1                    
     2140!!$                mjs2_crs(jpjglo_crs-jj+2) = ijjs 
     2141!!$                mje2_crs(jpjglo_crs-jj+2) = ijje 
     2142!!$            ENDDO 
     2143!!$ 
     2144!!$         CASE ( 2 )  
     2145!!$            WRITE(numout,*)  'crs_init, jperio=2 not supported'  
     2146!!$         
     2147!!$         CASE ( 5, 6 )    ! F-pivot at North Fold 
     2148!!$ 
     2149!!$            DO ji = 2, jpiglo_crsm1 
     2150!!$               ijie = ( ji * nn_factx ) - nn_factx  
     2151!!$               ijis = ijie - nn_factx + 1 
     2152!!$               mis2_crs(ji) = ijis 
     2153!!$               mie2_crs(ji) = ijie 
     2154!!$            ENDDO 
     2155!!$            IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1)  = jpiglo - 2  
     2156!!$ 
     2157!!$            ! Treat the northernmost bin separately. 
     2158!!$            jj = 2 
     2159!!$            ijje = jpj - nn_facty * ( jj - 2 ) 
     2160!!$            IF ( nn_facty == 3 ) THEN   ;  ijjs = ijje - 1  
     2161!!$            ELSE                        ;  ijjs = ijje - nn_facty + 1 
     2162!!$            ENDIF 
     2163!!$            mjs2_crs(jpj_crs-jj+1) = ijjs 
     2164!!$            mje2_crs(jpj_crs-jj+1) = ijje 
     2165!!$ 
     2166!!$            ! Now bin the rest, any remainder at the south is lumped in the southern bin 
     2167!!$            DO jj = 3, jpjglo_crsm1 
     2168!!$                ijje = jpjglo - nn_facty * ( jj - 2 ) 
     2169!!$                ijjs = ijje - nn_facty + 1                   
     2170!!$                IF ( ijjs <= nn_facty )  ijjs = 2 
     2171!!$                mjs2_crs(jpj_crs-jj+1)   = ijjs 
     2172!!$                mje2_crs(jpj_crs-jj+1)   = ijje 
     2173!!$            ENDDO 
     2174!!$ 
     2175!!$         CASE DEFAULT 
     2176!!$            WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported'  
     2177!!$  
     2178!!$         END SELECT 
    21792179 
    21802180      CASE (1 ) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/CRS/crslbclnk.F90

    r11536 r14574  
    5050      IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    5151      ! 
    52       CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, kfillmode, pfillval ) 
     52      CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, kfillmode = kfillmode, pfillval = pfillval ) 
    5353      ! 
    5454      IF( .NOT.ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain 
    … …  
    8080      IF( .NOT.ll_grid_crs )   CALL dom_grid_crs   ! Save the parent grid information  & Switch to coarse grid domain 
    8181      ! 
    82       CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, kfillmode, pfillval ) 
     82      CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, kfillmode = kfillmode, pfillval = pfillval ) 
    8383      ! 
    8484      IF( .NOT.ll_grid_crs )   CALL dom_grid_glo   ! Return to parent grid domain 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DIA/diacfl.F90

    r13497 r14574  
    6161      IF( ln_timing )   CALL timing_start('dia_cfl') 
    6262      ! 
    63       llmsk(   1:Nis1,:,:) = .FALSE.                                              ! exclude halos from the checked region 
    64       llmsk(Nie1: jpi,:,:) = .FALSE. 
    65       llmsk(:,   1:Njs1,:) = .FALSE. 
    66       llmsk(:,Nje1: jpj,:) = .FALSE. 
     63      llmsk(     1:nn_hls,:,:) = .FALSE.   ! exclude halos from the checked region 
     64      llmsk(Nie0+1:  jpi,:,:) = .FALSE. 
     65      llmsk(:,     1:nn_hls,:) = .FALSE. 
     66      llmsk(:,Nje0+1:  jpj,:) = .FALSE. 
    6767      ! 
    6868      DO_3D( 0, 0, 0, 0, 1, jpk )      ! calculate Courant numbers 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DIA/diawri.F90

    r14239 r14574  
    251251      ENDIF 
    252252 
    253       IF( ln_zad_Aimp ) ww = ww + wi               ! Recombine explicit and implicit parts of vertical velocity for diagnostic output 
    254       CALL iom_put( "woce", ww )                   ! vertical velocity 
     253      !                                            ! vertical velocity 
     254      IF( ln_zad_Aimp ) THEN   ;   CALL iom_put( "woce", ww + wi )   ! explicit plus implicit parts 
     255      ELSE                     ;   CALL iom_put( "woce", ww ) 
     256      ENDIF 
    255257 
    256258      IF( iom_use('w_masstr') .OR. iom_use('w_masstr2') ) THEN   ! vertical mass transport & its square value 
    257          ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 
    258          z2d(:,:) = rho0 * e1e2t(:,:) 
     259         !                     ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 
    259260         DO jk = 1, jpk 
    260             z3d(:,:,jk) = ww(:,:,jk) * z2d(:,:) 
     261            IF( ln_zad_Aimp ) THEN 
     262               z3d(:,:,jk) = rho0 * e1e2t(:,:) * ( ww(:,:,jk) + wi(:,:,jk) ) 
     263            ELSE 
     264               z3d(:,:,jk) = rho0 * e1e2t(:,:) * ww(:,:,jk) 
     265            ENDIF 
    261266         END DO 
    262267         CALL iom_put( "w_masstr" , z3d )   
    263          IF( iom_use('w_masstr2') )   CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 
    264       ENDIF 
    265       ! 
    266       IF( ln_zad_Aimp ) ww = ww - wi               ! Remove implicit part of vertical velocity that was added for diagnostic output 
     268         IF( iom_use('w_masstr2') )   CALL iom_put( "w_masstr2", z3d * z3d ) 
     269      ENDIF 
    267270 
    268271      CALL iom_put( "avt" , avt )                  ! T vert. eddy diff. coef. 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DOM/dom_oce.F90

    r14537 r14574  
    6565   !! space domain parameters 
    6666   !!---------------------------------------------------------------------- 
    67    INTEGER, PUBLIC ::   jperio   !: Global domain lateral boundary type (between 0 and 7) 
    68    !                                !  = 0 closed                 ;   = 1 cyclic East-West 
    69    !                                !  = 2 cyclic North-South     ;   = 3 North fold T-point pivot 
    70    !                                !  = 4 cyclic East-West AND North fold T-point pivot 
    71    !                                !  = 5 North fold F-point pivot 
    72    !                                !  = 6 cyclic East-West AND North fold F-point pivot 
    73    !                                !  = 7 bi-cyclic East-West AND North-South 
    74    LOGICAL, PUBLIC ::   l_Iperio, l_Jperio   !   should we explicitely take care I/J periodicity 
     67   LOGICAL         , PUBLIC ::   l_Iperio, l_Jperio   ! i- j-periodicity 
     68   LOGICAL         , PUBLIC ::   l_NFold              ! North Pole folding 
     69   CHARACTER(len=1), PUBLIC ::   c_NFtype             ! type of North pole Folding: T or F point 
    7570 
    7671   ! Tiling namelist 
    … …  
    8681 
    8782   !                             !: domain MPP decomposition parameters 
    88    INTEGER             , PUBLIC ::   nimpp, njmpp     !: i- & j-indexes for mpp-subdomain left bottom 
    89    INTEGER             , PUBLIC ::   nproc            !: number for local processor 
    90    INTEGER             , PUBLIC ::   narea            !: number for local area 
    91    INTEGER             , PUBLIC ::   nbondi, nbondj   !: mark of i- and j-direction local boundaries 
    92    INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy(:)    !: mark i-direction local boundaries for BDY open boundaries 
    93    INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy(:)    !: mark j-direction local boundaries for BDY open boundaries 
    94    INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy_b(:)  !: mark i-direction of neighbours local boundaries for BDY open boundaries 
    95    INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy_b(:)  !: mark j-direction of neighbours local boundaries for BDY open boundaries 
    96  
    97    INTEGER, PUBLIC ::   npolj             !: north fold mark (0, 3 or 4) 
    98    INTEGER, PUBLIC ::   noea, nowe        !: index of the local neighboring processors in 
    99    INTEGER, PUBLIC ::   noso, nono        !: east, west, south and north directions 
    100    INTEGER, PUBLIC ::   nones, nonws        !: north-east, north-west directions for sending 
    101    INTEGER, PUBLIC ::   noses, nosws        !: south-east, south-west directions for sending 
    102    INTEGER, PUBLIC ::   noner, nonwr        !: north-east, north-west directions for receiving 
    103    INTEGER, PUBLIC ::   noser, noswr        !: south-east, south-west directions for receiving 
    104    INTEGER, PUBLIC ::   nidom             !: ??? 
     83   INTEGER              , PUBLIC ::   nimpp, njmpp     !: i- & j-indexes for mpp-subdomain left bottom 
     84   INTEGER              , PUBLIC ::   narea            !: number for local area (starting at 1) = MPI rank + 1 
     85   INTEGER,               PUBLIC ::   nidom      !: IOIPSL things... 
    10586 
    10687   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   mig        !: local ==> global domain, including halos (jpiglo), i-index 
    … …  
    11293   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   mj0, mj1   !: global, including halos (jpjglo) ==> local domain j-index 
    11394   !                                                                !:    (mj0=1 and mj1=0 if global index not in local domain) 
    114    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nimppt,  njmppt   !: i-, j-indexes for each processor 
    115    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   ibonit,  ibonjt   !: i-, j- processor neighbour existence 
    116    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   jpiall,  jpjall   !: dimensions of all subdomain 
    117    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nis0all, njs0all  !: first, last indoor index for all i-subdomain 
    118    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nie0all, nje0all  !: first, last indoor index for all j-subdomain 
    11995   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nfimpp, nfproc, nfjpi 
    12096 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DOM/domain.F90

    r14537 r14574  
    113113         WRITE(numout,*)     '              jpnj    : ', jpnj, '   nn_hls  : ', nn_hls 
    114114         WRITE(numout,*)     '              jpnij   : ', jpnij 
    115          WRITE(numout,*)     '      lateral boundary of the Global domain : jperio  = ', jperio 
    116          SELECT CASE ( jperio ) 
    117          CASE( 0 )   ;   WRITE(numout,*) '         (i.e. closed)' 
    118          CASE( 1 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west)' 
    119          CASE( 2 )   ;   WRITE(numout,*) '         (i.e. cyclic north-south)' 
    120          CASE( 3 )   ;   WRITE(numout,*) '         (i.e. north fold with T-point pivot)' 
    121          CASE( 4 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west and north fold with T-point pivot)' 
    122          CASE( 5 )   ;   WRITE(numout,*) '         (i.e. north fold with F-point pivot)' 
    123          CASE( 6 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west and north fold with F-point pivot)' 
    124          CASE( 7 )   ;   WRITE(numout,*) '         (i.e. cyclic east-west and north-south)' 
    125          CASE DEFAULT 
    126             CALL ctl_stop( 'dom_init:   jperio is out of range' ) 
    127          END SELECT 
     115         WRITE(numout,*)     '      lateral boundary of the Global domain:' 
     116         WRITE(numout,*)     '              cyclic east-west             :', l_Iperio 
     117         WRITE(numout,*)     '              cyclic north-south           :', l_Jperio 
     118         WRITE(numout,*)     '              North Pole folding           :', l_NFold 
     119         WRITE(numout,*)     '                 type of North pole Folding:', c_NFtype 
    128120         WRITE(numout,*)     '      Ocean model configuration used:' 
    129          WRITE(numout,*)     '         cn_cfg = ', TRIM( cn_cfg ), '   nn_cfg = ', nn_cfg 
     121         WRITE(numout,*)     '              cn_cfg = ', TRIM( cn_cfg ), '   nn_cfg = ', nn_cfg 
    130122      ENDIF 
    131123 
    … …  
    622614 
    623615 
    624    SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 
     616   SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 
    625617      !!---------------------------------------------------------------------- 
    626618      !!                     ***  ROUTINE domain_cfg  *** 
    … …  
    630622      !! ** Method  :   read the cn_domcfg NetCDF file 
    631623      !!---------------------------------------------------------------------- 
    632       CHARACTER(len=*)              , INTENT(out) ::   cd_cfg          ! configuration name 
    633       INTEGER                       , INTENT(out) ::   kk_cfg          ! configuration resolution 
    634       INTEGER                       , INTENT(out) ::   kpi, kpj, kpk   ! global domain sizes 
    635       INTEGER                       , INTENT(out) ::   kperio          ! lateral global domain b.c. 
    636       ! 
    637       INTEGER ::   inum   ! local integer 
     624      CHARACTER(len=*), INTENT(out) ::   cd_cfg               ! configuration name 
     625      INTEGER         , INTENT(out) ::   kk_cfg               ! configuration resolution 
     626      INTEGER         , INTENT(out) ::   kpi, kpj, kpk        ! global domain sizes 
     627      LOGICAL         , INTENT(out) ::   ldIperio, ldJperio   ! i- and j- periodicity 
     628      LOGICAL         , INTENT(out) ::   ldNFold              ! North pole folding 
     629      CHARACTER(len=1), INTENT(out) ::   cdNFtype             ! Folding type: T or F 
     630      ! 
     631      CHARACTER(len=7) ::   catt                  ! 'T', 'F', '-' or 'UNKNOWN' 
     632      INTEGER ::   inum, iperio, iatt             ! local integer 
    638633      REAL(wp) ::   zorca_res                     ! local scalars 
    639634      REAL(wp) ::   zperio                        !   -      - 
    … …  
    649644      CALL iom_open( cn_domcfg, inum ) 
    650645      ! 
    651       !                                   !- ORCA family specificity 
    652       IF(  iom_varid( inum, 'ORCA'       , ldstop = .FALSE. ) > 0  .AND.  & 
    653          & iom_varid( inum, 'ORCA_index' , ldstop = .FALSE. ) > 0    ) THEN 
    654          ! 
    655          cd_cfg = 'ORCA' 
    656          CALL iom_get( inum, 'ORCA_index', zorca_res )   ;   kk_cfg = NINT( zorca_res ) 
    657          ! 
    658          IF(lwp) THEN 
    659             WRITE(numout,*) '   .' 
    660             WRITE(numout,*) '   ==>>>   ORCA configuration ' 
    661             WRITE(numout,*) '   .' 
     646      CALL iom_getatt( inum,  'CfgName', cd_cfg )   ! returns 'UNKNOWN' if not found 
     647      CALL iom_getatt( inum, 'CfgIndex', kk_cfg )   ! returns      -999 if not found 
     648      ! 
     649      ! ------- keep compatibility with OLD VERSION... start ------- 
     650      IF( cd_cfg == 'UNKNOWN' .AND. kk_cfg == -999 ) THEN 
     651         IF(  iom_varid( inum, 'ORCA'       , ldstop = .FALSE. ) > 0  .AND.  & 
     652            & iom_varid( inum, 'ORCA_index' , ldstop = .FALSE. ) > 0    ) THEN 
     653            ! 
     654            cd_cfg = 'ORCA' 
     655            CALL iom_get( inum, 'ORCA_index', zorca_res )   ;   kk_cfg = NINT( zorca_res ) 
     656            ! 
     657         ELSE 
     658            CALL iom_getatt( inum, 'cn_cfg', cd_cfg )  ! returns 'UNKNOWN' if not found 
     659            CALL iom_getatt( inum, 'nn_cfg', kk_cfg )  ! returns      -999 if not found 
    662660         ENDIF 
    663          ! 
    664       ELSE                                !- cd_cfg & k_cfg are not used 
    665          cd_cfg = 'UNKNOWN' 
    666          kk_cfg = -9999999 
    667                                           !- or they may be present as global attributes 
    668                                           !- (netcdf only) 
    669          CALL iom_getatt( inum, 'cn_cfg', cd_cfg )  ! returns   !  if not found 
    670          CALL iom_getatt( inum, 'nn_cfg', kk_cfg )  ! returns -999 if not found 
    671          IF( TRIM(cd_cfg) == '!') cd_cfg = 'UNKNOWN' 
    672          IF( kk_cfg == -999     ) kk_cfg = -9999999 
    673          ! 
    674       ENDIF 
    675        ! 
     661      ENDIF 
     662      ! ------- keep compatibility with OLD VERSION... end ------- 
     663      ! 
    676664      idvar = iom_varid( inum, 'e3t_0', kdimsz = idimsz )   ! use e3t_0, that must exist, to get jp(ijk)glo 
    677665      kpi = idimsz(1) 
    678666      kpj = idimsz(2) 
    679667      kpk = idimsz(3) 
    680       CALL iom_get( inum, 'jperio', zperio )   ;   kperio = NINT( zperio ) 
     668      ! 
     669      CALL iom_getatt( inum, 'Iperio', iatt )   ;   ldIperio = iatt == 1   ! returns      -999 if not found -> default = .false. 
     670      CALL iom_getatt( inum, 'Jperio', iatt )   ;   ldJperio = iatt == 1   ! returns      -999 if not found -> default = .false. 
     671      CALL iom_getatt( inum,  'NFold', iatt )   ;   ldNFold  = iatt == 1   ! returns      -999 if not found -> default = .false. 
     672      CALL iom_getatt( inum, 'NFtype', catt )                              ! returns 'UNKNOWN' if not found 
     673      IF( LEN_TRIM(catt) == 1 ) THEN   ;   cdNFtype = TRIM(catt) 
     674      ELSE                             ;   cdNFtype = '-' 
     675      ENDIF 
     676      ! 
     677      ! ------- keep compatibility with OLD VERSION... start ------- 
     678      IF( iatt == -999 .AND. catt == 'UNKNOWN' .AND. iom_varid( inum, 'jperio', ldstop = .FALSE. ) > 0 ) THEN                     
     679         CALL iom_get( inum, 'jperio', zperio )   ;   iperio = NINT( zperio ) 
     680         ldIperio = iperio == 1  .OR. iperio == 4 .OR. iperio == 6 .OR. iperio == 7   ! i-periodicity 
     681         ldJperio = iperio == 2  .OR. iperio == 7                                     ! j-periodicity 
     682         ldNFold  = iperio >= 3 .AND. iperio <= 6                                     ! North pole folding 
     683         IF(     iperio == 3 .OR. iperio == 4 ) THEN   ;   cdNFtype = 'T'             !    folding at T point 
     684         ELSEIF( iperio == 5 .OR. iperio == 6 ) THEN   ;   cdNFtype = 'F'             !    folding at F point 
     685         ELSE                                          ;   cdNFtype = '-'             !    default value 
     686         ENDIF 
     687      ENDIF 
     688      ! ------- keep compatibility with OLD VERSION... end ------- 
     689      ! 
    681690      CALL iom_close( inum ) 
    682691      ! 
    683692      IF(lwp) THEN 
    684          WRITE(numout,*) '      cn_cfg = ', TRIM(cd_cfg), '   nn_cfg = ', kk_cfg 
     693         WRITE(numout,*) '   .' 
     694         WRITE(numout,*) '   ==>>>   ', TRIM(cn_cfg), ' configuration ' 
     695         WRITE(numout,*) '   .' 
     696         WRITE(numout,*) '      nn_cfg = ', kk_cfg 
    685697         WRITE(numout,*) '      Ni0glo = ', kpi 
    686698         WRITE(numout,*) '      Nj0glo = ', kpj 
    687699         WRITE(numout,*) '      jpkglo = ', kpk 
    688          WRITE(numout,*) '      type of global domain lateral boundary   jperio = ', kperio 
    689700      ENDIF 
    690701      ! 
    … …  
    724735      CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 
    725736      ! 
    726       !                             !==  ORCA family specificities  ==! 
    727       IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN 
    728          CALL iom_rstput( 0, 0, inum, 'ORCA'      , 1._wp            , ktype = jp_i4 ) 
    729          CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 ) 
    730       ENDIF 
     737      !                             !==  Configuration specificities  ==! 
     738      ! 
     739      CALL iom_putatt( inum,  'CfgName', TRIM(cn_cfg) ) 
     740      CALL iom_putatt( inum, 'CfgIndex',      nn_cfg  ) 
    731741      ! 
    732742      !                             !==  domain characteristics  ==! 
    733743      ! 
    734744      !                                   ! lateral boundary of the global domain 
    735       CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 ) 
    736       ! 
     745      CALL iom_putatt( inum, 'Iperio', COUNT( (/l_Iperio/) ) ) 
     746      CALL iom_putatt( inum, 'Jperio', COUNT( (/l_Jperio/) ) ) 
     747      CALL iom_putatt( inum,  'NFold', COUNT( (/l_NFold /) ) ) 
     748      CALL iom_putatt( inum, 'NFtype',          c_NFtype     ) 
     749 
    737750      !                                   ! type of vertical coordinate 
    738       CALL iom_rstput( 0, 0, inum, 'ln_zco', REAL(COUNT((/ln_zco/)), wp), ktype = jp_i4 ) 
    739       CALL iom_rstput( 0, 0, inum, 'ln_zps', REAL(COUNT((/ln_zps/)), wp), ktype = jp_i4 ) 
    740       CALL iom_rstput( 0, 0, inum, 'ln_sco', REAL(COUNT((/ln_sco/)), wp), ktype = jp_i4 ) 
    741       ! 
     751      IF(ln_zco)   CALL iom_putatt( inum, 'VertCoord', 'zco' ) 
     752      IF(ln_zps)   CALL iom_putatt( inum, 'VertCoord', 'zps' ) 
     753      IF(ln_sco)   CALL iom_putatt( inum, 'VertCoord', 'sco' ) 
     754       
    742755      !                                   ! ocean cavities under iceshelves 
    743       CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL(COUNT((/ln_isfcav/)), wp), ktype = jp_i4 ) 
     756      CALL iom_putatt( inum, 'IsfCav', COUNT( (/ln_isfcav/) ) ) 
    744757      ! 
    745758      !                             !==  horizontal mesh  ! 
    … …  
    794807         CALL iom_rstput( 0, 0, inum, 'ht_0'   , ht_0   , ktype = jp_r8 ) 
    795808      ENDIF 
    796       ! 
    797       ! Add some global attributes ( netcdf only ) 
    798       CALL iom_putatt( inum, 'nn_cfg', nn_cfg ) 
    799       CALL iom_putatt( inum, 'cn_cfg', TRIM(cn_cfg) ) 
    800       ! 
    801       !                                ! ============================ 
    802       !                                !        close the files 
    803       !                                ! ============================ 
     809      !                       ! ============================ ! 
     810      !                       !        close the files 
     811      !                       ! ============================ ! 
    804812      CALL iom_close( inum ) 
    805813      ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DOM/dommsk.F90

    r14215 r14574  
    162162            &            * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk) 
    163163      END_3D 
    164       CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp )      ! Lateral boundary conditions 
     164      CALL lbc_lnk( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp )      ! Lateral boundary conditions 
    165165  
    166166      ! Ocean/land mask at wu-, wv- and w points    (computed from tmask) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DOM/domqco.F90

    r14179 r14574  
    170170      ! 
    171171      IF( .NOT.PRESENT( pr3f ) ) THEN              !- lbc on ratio at u-, v-points only 
    172          CALL lbc_lnk_multi( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp ) 
     172         CALL lbc_lnk( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp ) 
    173173         ! 
    174174         ! 
    … …  
    194194#endif 
    195195         !                                                 ! lbc on ratio at u-,v-,f-points 
    196          CALL lbc_lnk_multi( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp, pr3f, 'F', 1._wp ) 
     196         CALL lbc_lnk( 'dom_qco_r3c', pr3u, 'U', 1._wp, pr3v, 'V', 1._wp, pr3f, 'F', 1._wp ) 
    197197         ! 
    198198      ENDIF 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DOM/domvvl.F90

    r14140 r14574  
    423423         !                               ! d - thickness diffusion transport: boundary conditions 
    424424         !                             (stored for tracer advction and continuity equation) 
    425          CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) 
     425         CALL lbc_lnk( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) 
    426426         ! 4 - Time stepping of baroclinic scale factors 
    427427         ! --------------------------------------------- 
    … …  
    436436         END_3D 
    437437         ! 
    438          llmsk(   1:Nis1,:,:) = .FALSE.   ! exclude halos from the checked region 
    439          llmsk(Nie1: jpi,:,:) = .FALSE. 
    440          llmsk(:,   1:Njs1,:) = .FALSE. 
    441          llmsk(:,Nje1: jpj,:) = .FALSE. 
     438         llmsk(     1:nn_hls,:,:) = .FALSE.   ! exclude halos from the checked region 
     439         llmsk(Nie0+1:  jpi,:,:) = .FALSE. 
     440         llmsk(:,     1:nn_hls,:) = .FALSE. 
     441         llmsk(:,Nje0+1:  jpj,:) = .FALSE. 
    442442         ! 
    443443         llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp                  ! define only the inner domain 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DOM/domwri.F90

    r13295 r14574  
    5858      CHARACTER(len=21) ::   clnam   ! filename (mesh and mask informations) 
    5959      INTEGER           ::   ji, jj, jk   ! dummy loop indices 
    60       INTEGER           ::   izco, izps, isco, icav 
    61       !                                
    6260      REAL(wp), DIMENSION(jpi,jpj)     ::   zprt, zprw     ! 2D workspace 
    6361      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zdepu, zdepv   ! 3D workspace 
    … …  
    7472      !                                  ! ============================ 
    7573      CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 
    76       !                                                         ! domain characteristics 
    77       CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 ) 
     74      !                                                         ! Configuration specificities 
     75      CALL iom_putatt( inum,  'CfgName', TRIM(cn_cfg) ) 
     76      CALL iom_putatt( inum, 'CfgIndex',      nn_cfg  ) 
     77      !                                                         ! lateral boundary of the global domain 
     78      CALL iom_putatt( inum,   'Iperio', COUNT( (/l_Iperio/) ) ) 
     79      CALL iom_putatt( inum,   'Jperio', COUNT( (/l_Jperio/) ) ) 
     80      CALL iom_putatt( inum,    'NFold', COUNT( (/l_NFold /) ) ) 
     81      CALL iom_putatt( inum,   'NFtype',          c_NFtype     ) 
    7882      !                                                         ! type of vertical coordinate 
    79       IF( ln_zco    ) THEN   ;   izco = 1   ;   ELSE   ;   izco = 0   ;   ENDIF 
    80       IF( ln_zps    ) THEN   ;   izps = 1   ;   ELSE   ;   izps = 0   ;   ENDIF 
    81       IF( ln_sco    ) THEN   ;   isco = 1   ;   ELSE   ;   isco = 0   ;   ENDIF 
    82       CALL iom_rstput( 0, 0, inum, 'ln_zco'   , REAL( izco, wp), ktype = jp_i4 ) 
    83       CALL iom_rstput( 0, 0, inum, 'ln_zps'   , REAL( izps, wp), ktype = jp_i4 ) 
    84       CALL iom_rstput( 0, 0, inum, 'ln_sco'   , REAL( isco, wp), ktype = jp_i4 ) 
     83      IF(ln_zco)   CALL iom_putatt( inum, 'VertCoord', 'zco' ) 
     84      IF(ln_zps)   CALL iom_putatt( inum, 'VertCoord', 'zps' ) 
     85      IF(ln_sco)   CALL iom_putatt( inum, 'VertCoord', 'sco' ) 
    8586      !                                                         ! ocean cavities under iceshelves 
    86       IF( ln_isfcav ) THEN   ;   icav = 1   ;   ELSE   ;   icav = 0   ;   ENDIF 
    87       CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 ) 
    88    
     87      CALL iom_putatt( inum,   'IsfCav', COUNT( (/ln_isfcav/) ) )   
    8988      !                                                         ! masks 
    9089      CALL iom_rstput( 0, 0, inum, 'tmask', tmask, ktype = jp_i1 )     !    ! land-sea mask 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DOM/domzgr.F90

    r13295 r14574  
    115115      ! 
    116116      zmsk(:,:) = 1._wp                                       ! default: no closed boundaries 
    117       IF( jperio == 0 .OR. jperio == 2 .OR. jperio == 3 .OR. jperio == 5 ) THEN   ! E-W closed 
     117      IF( .NOT. l_Iperio ) THEN                                    ! E-W closed: 
    118118         zmsk(  mi0(     1+nn_hls):mi1(     1+nn_hls),:) = 0._wp   ! first column of inner global domain at 0 
    119119         zmsk(  mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls),:) = 0._wp   ! last  column of inner global domain at 0  
    120120      ENDIF 
    121       IF( .NOT. ( jperio == 2 .OR. jperio == 7 ) ) THEN                           ! S closed 
     121      IF( .NOT. l_Jperio ) THEN                                    ! S closed: 
    122122         zmsk(:,mj0(     1+nn_hls):mj1(     1+nn_hls)  ) = 0._wp   ! first   line of inner global domain at 0 
    123123      ENDIF 
    124       IF( jperio == 0 .OR. jperio == 1 ) THEN                                     ! N closed 
     124      IF( .NOT. ( l_Jperio .OR. l_NFold ) ) THEN                   ! N closed: 
    125125         zmsk(:,mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls)  ) = 0._wp   ! last    line of inner global domain at 0 
    126126      ENDIF 
    … …  
    225225      ! 
    226226      INTEGER  ::   jk     ! dummy loop index 
    227       INTEGER  ::   inum   ! local logical unit 
     227      INTEGER  ::   inum, iatt 
    228228      REAL(WP) ::   z_zco, z_zps, z_sco, z_cav 
    229229      REAL(wp), DIMENSION(jpi,jpj) ::   z2d   ! 2D workspace 
     230      CHARACTER(len=7) ::   catt   ! 'zco', 'zps, 'sco' or 'UNKNOWN' 
    230231      !!---------------------------------------------------------------------- 
    231232      ! 
    … …  
    239240      ! 
    240241      !                          !* type of vertical coordinate 
    241       CALL iom_get( inum, 'ln_zco'   , z_zco ) 
    242       CALL iom_get( inum, 'ln_zps'   , z_zps ) 
    243       CALL iom_get( inum, 'ln_sco'   , z_sco ) 
    244       IF( z_zco == 0._wp ) THEN   ;   ld_zco = .false.   ;   ELSE   ;   ld_zco = .true.   ;   ENDIF 
    245       IF( z_zps == 0._wp ) THEN   ;   ld_zps = .false.   ;   ELSE   ;   ld_zps = .true.   ;   ENDIF 
    246       IF( z_sco == 0._wp ) THEN   ;   ld_sco = .false.   ;   ELSE   ;   ld_sco = .true.   ;   ENDIF 
    247       ! 
     242      CALL iom_getatt( inum, 'VertCoord', catt )   ! returns 'UNKNOWN' if not found 
     243      ld_zco = catt == 'zco'          ! default = .false. 
     244      ld_zps = catt == 'zps'          ! default = .false. 
     245      ld_sco = catt == 'sco'          ! default = .false. 
    248246      !                          !* ocean cavities under iceshelves 
    249       CALL iom_get( inum, 'ln_isfcav', z_cav ) 
    250       IF( z_cav == 0._wp ) THEN   ;   ld_isfcav = .false.   ;   ELSE   ;   ld_isfcav = .true.   ;   ENDIF 
     247      CALL iom_getatt( inum,    'IsfCav', iatt )   ! returns -999 if not found 
     248      ld_isfcav = iatt == 1           ! default = .false. 
     249      ! 
     250      ! ------- keep compatibility with OLD VERSION... start ------- 
     251      IF( catt == 'UNKNOWN' ) THEN 
     252         CALL iom_get( inum,    'ln_zco', z_zco )   ;   ld_zco = z_zco /= 0._wp 
     253         CALL iom_get( inum,    'ln_zps', z_zps )   ;   ld_zps = z_zps /= 0._wp 
     254         CALL iom_get( inum,    'ln_sco', z_sco )   ;   ld_sco = z_sco /= 0._wp 
     255      ENDIF 
     256      IF( iatt == -999 ) THEN 
     257         CALL iom_get( inum, 'ln_isfcav', z_cav )   ;   ld_isfcav = z_cav /= 0._wp 
     258      ENDIF 
     259      ! ------- keep compatibility with OLD VERSION... end ------- 
    251260      ! 
    252261      !                          !* vertical scale factors 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DYN/dynadv_ubs.F90

    r13497 r14574  
    124124         END_2D 
    125125      END DO 
    126       CALL lbc_lnk_multi( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1.0_wp , zlu_uv(:,:,:,1), 'U', 1.0_wp,  & 
    127                       &   zlu_uu(:,:,:,2), 'U', 1.0_wp , zlu_uv(:,:,:,2), 'U', 1.0_wp,  &  
    128                       &   zlv_vv(:,:,:,1), 'V', 1.0_wp , zlv_vu(:,:,:,1), 'V', 1.0_wp,  & 
    129                       &   zlv_vv(:,:,:,2), 'V', 1.0_wp , zlv_vu(:,:,:,2), 'V', 1.0_wp   ) 
     126      CALL lbc_lnk( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1.0_wp , zlu_uv(:,:,:,1), 'U', 1.0_wp,  & 
     127         &                        zlu_uu(:,:,:,2), 'U', 1.0_wp , zlu_uv(:,:,:,2), 'U', 1.0_wp,  &  
     128         &                        zlv_vv(:,:,:,1), 'V', 1.0_wp , zlv_vu(:,:,:,1), 'V', 1.0_wp,  & 
     129         &                        zlv_vv(:,:,:,2), 'V', 1.0_wp , zlv_vu(:,:,:,2), 'V', 1.0_wp   ) 
    130130      ! 
    131131      !                                      ! ====================== ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DYN/dynatf.F90

    r14224 r14574  
    169169# endif 
    170170      ! 
    171       CALL lbc_lnk_multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1.0_wp, pvv(:,:,:,Kaa), 'V', -1.0_wp )     !* local domain boundaries 
     171      CALL lbc_lnk( 'dynatf', puu(:,:,:,Kaa), 'U', -1.0_wp, pvv(:,:,:,Kaa), 'V', -1.0_wp )     !* local domain boundaries 
    172172      ! 
    173173      !                                !* BDY open boundaries 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DYN/dynatf_qco.F90

    r14224 r14574  
    4343   USE isf_oce   , ONLY: ln_isf     ! ice shelf 
    4444   USE isfdynatf , ONLY: isf_dynatf ! ice shelf volume filter correction subroutine 
     45   USE zdfdrg    , ONLY: ln_drgice_imp, rCdU_top 
    4546   ! 
    4647   USE in_out_manager ! I/O manager 
    … …  
    101102      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   zue, zve 
    102103      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) ::   zua, zva 
     104      REAL(wp), ALLOCATABLE, DIMENSION(:,:)   ::   zutau, zvtau 
    103105      !!---------------------------------------------------------------------- 
    104106      ! 
    … …  
    239241      ENDIF 
    240242      ! 
     243      IF ( iom_use("utau") ) THEN 
     244         IF ( ln_drgice_imp.OR.ln_isfcav ) THEN 
     245            ALLOCATE(zutau(jpi,jpj)) 
     246            DO_2D( 0, 0, 0, 0 ) 
     247               jk = miku(ji,jj) 
     248               zutau(ji,jj) = utau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * puu(ji,jj,jk,Kaa) 
     249            END_2D 
     250            CALL iom_put(  "utau", zutau(:,:) ) 
     251            DEALLOCATE(zutau) 
     252         ELSE 
     253            CALL iom_put(  "utau", utau(:,:) ) 
     254         ENDIF 
     255      ENDIF 
     256      ! 
     257      IF ( iom_use("vtau") ) THEN 
     258         IF ( ln_drgice_imp.OR.ln_isfcav ) THEN 
     259            ALLOCATE(zvtau(jpi,jpj)) 
     260            DO_2D( 0, 0, 0, 0 ) 
     261               jk = mikv(ji,jj) 
     262               zvtau(ji,jj) = vtau(ji,jj) + 0.5_wp * rho0 * ( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * pvv(ji,jj,jk,Kaa) 
     263            END_2D 
     264            CALL iom_put(  "vtau", zvtau(:,:) ) 
     265            DEALLOCATE(zvtau) 
     266         ELSE 
     267            CALL iom_put(  "vtau", vtau(:,:) ) 
     268         ENDIF 
     269      ENDIF 
     270      ! 
    241271      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab3d_1=puu(:,:,:,Kaa), clinfo1=' nxt  - puu(:,:,:,Kaa): ', mask1=umask,   & 
    242272         &                                  tab3d_2=pvv(:,:,:,Kaa), clinfo2=' pvv(:,:,:,Kaa): '       , mask2=vmask ) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DYN/dynhpg.F90

    r14227 r14574  
    462462          END IF 
    463463        END_2D 
    464         CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 
     464        CALL lbc_lnk( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 
    465465      END IF 
    466466      ! 
    … …  
    689689          END IF 
    690690        END_2D 
    691         CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 
     691        CALL lbc_lnk( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 
    692692      END IF 
    693693 
    … …  
    793793      END_3D 
    794794 
    795       CALL lbc_lnk_multi( 'dynhpg', zdrhox, 'U', 1., zdzx, 'U', 1., zdrhoy, 'V', 1., zdzy, 'V', 1. )  
     795      CALL lbc_lnk( 'dynhpg', zdrhox, 'U', 1., zdzx, 'U', 1., zdrhoy, 'V', 1., zdzy, 'V', 1. )  
    796796 
    797797      !------------------------------------------------------------------------- 
    … …  
    10431043            ENDIF 
    10441044         END_2D 
    1045          CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 
     1045         CALL lbc_lnk( 'dynhpg', zcpx, 'U', 1.0_wp, zcpy, 'V', 1.0_wp ) 
    10461046      ENDIF 
    10471047 
    … …  
    11131113      END_2D 
    11141114 
    1115       CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1.0_wp, zsshv_n, 'V', 1.0_wp ) 
     1115      CALL lbc_lnk ('dynhpg', zsshu_n, 'U', 1.0_wp, zsshv_n, 'V', 1.0_wp ) 
    11161116 
    11171117      DO_2D( 0, 0, 0, 0 ) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DYN/dynldf_iso.F90

    r14215 r14574  
    135135         END_3D 
    136136         ! Lateral boundary conditions on the slopes 
    137          CALL lbc_lnk_multi( 'dynldf_iso', uslp , 'U', -1.0_wp, vslp , 'V', -1.0_wp, wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) 
     137         CALL lbc_lnk( 'dynldf_iso', uslp , 'U', -1.0_wp, vslp , 'V', -1.0_wp, wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) 
    138138         ! 
    139139       ENDIF 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DYN/dynldf_lap_blp.F90

    r14053 r14574  
    185185      CALL dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 )   ! rotated laplacian applied to pt (output in zlap,Kbb) 
    186186      ! 
    187       CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1.0_wp, zvlap, 'V', -1.0_wp )             ! Lateral boundary conditions 
     187      CALL lbc_lnk( 'dynldf_lap_blp', zulap, 'U', -1.0_wp, zvlap, 'V', -1.0_wp )             ! Lateral boundary conditions 
    188188      ! 
    189189      CALL dyn_ldf_lap( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 )   ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DYN/dynspg_ts.F90

    r14225 r14574  
    524524         END_2D 
    525525         ! 
    526          CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp,  zhU, 'U', -1._wp,  zhV, 'V', -1._wp ) 
     526         CALL lbc_lnk( 'dynspg_ts', ssha_e, 'T', 1._wp,  zhU, 'U', -1._wp,  zhV, 'V', -1._wp ) 
    527527         ! 
    528528         ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) 
    … …  
    677677         ! 
    678678         IF( .NOT.ln_linssh ) THEN   !* Update ocean depth (variable volume case only) 
    679             CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp  & 
    680                  &                         , hu_e , 'U',  1._wp, hv_e , 'V',  1._wp  & 
    681                  &                         , hur_e, 'U',  1._wp, hvr_e, 'V',  1._wp  ) 
     679            CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp  & 
     680                 &                   , hu_e , 'U',  1._wp, hv_e , 'V',  1._wp  & 
     681                 &                   , hur_e, 'U',  1._wp, hvr_e, 'V',  1._wp  ) 
    682682         ELSE 
    683             CALL lbc_lnk_multi( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp  ) 
     683            CALL lbc_lnk( 'dynspg_ts', ua_e , 'U', -1._wp, va_e , 'V', -1._wp  ) 
    684684         ENDIF 
    685685         !                                                 ! open boundaries 
    … …  
    775775         END_2D 
    776776#endif    
    777          CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 
     777         CALL lbc_lnk( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 
    778778         ! 
    779779         DO jk=1,jpkm1 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DYN/dynvor.F90

    r14233 r14574  
    940940               dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji  ,jj-1) ) * 0.5_wp 
    941941            END_2D 
    942             CALL lbc_lnk_multi( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp )   ! Lateral boundary conditions 
     942            CALL lbc_lnk( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp )   ! Lateral boundary conditions 
    943943            ! 
    944944         CASE DEFAULT                        !* F-point metric term :   pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f) 
    … …  
    948948               dj_e1u_2e1e2f(ji,jj) = ( e1u(ji  ,jj+1) - e1u(ji,jj) )  * 0.5 * r1_e1e2f(ji,jj) 
    949949            END_2D 
    950             CALL lbc_lnk_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp )   ! Lateral boundary conditions 
     950            CALL lbc_lnk( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp )   ! Lateral boundary conditions 
    951951         END SELECT 
    952952         ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/DYN/wet_dry.F90

    r13558 r14574  
    241241            ENDIF 
    242242         END_2D 
    243          CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) 
     243         CALL lbc_lnk( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) 
    244244         ! 
    245245         CALL mpp_max('wet_dry', jflag)   !max over the global domain 
    … …  
    257257      ! 
    258258!!gm TO BE SUPPRESSED ?  these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere ! 
    259       CALL lbc_lnk_multi( 'wet_dry', puu(:,:,:,Kmm)  , 'U', -1.0_wp, pvv(:,:,:,Kmm)  , 'V', -1.0_wp ) 
    260       CALL lbc_lnk_multi( 'wet_dry', uu_b(:,:,Kmm), 'U', -1.0_wp, vv_b(:,:,Kmm), 'V', -1.0_wp ) 
     259      CALL lbc_lnk( 'wet_dry', puu(:,:,:,Kmm)  , 'U', -1.0_wp, pvv(:,:,:,Kmm)  , 'V', -1.0_wp ) 
     260      CALL lbc_lnk( 'wet_dry', uu_b(:,:,Kmm), 'U', -1.0_wp, vv_b(:,:,Kmm), 'V', -1.0_wp ) 
    261261!!gm 
    262262      ! 
    … …  
    366366         END_2D 
    367367         ! 
    368          CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) 
     368         CALL lbc_lnk( 'wet_dry', zwdlmtu, 'U', 1.0_wp, zwdlmtv, 'V', 1.0_wp ) 
    369369         ! 
    370370         CALL mpp_max('wet_dry', jflag)   !max over the global domain 
    … …  
    378378      ! 
    379379!!gm THIS lbc_lnk is useless since it is already done at the end of the jk1-loop 
    380       CALL lbc_lnk_multi( 'wet_dry', zflxu, 'U', -1.0_wp, zflxv, 'V', -1.0_wp ) 
     380      CALL lbc_lnk( 'wet_dry', zflxu, 'U', -1.0_wp, zflxv, 'V', -1.0_wp ) 
    381381!!gm end 
    382382      ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ICB/icbdia.F90

    r10570 r14574  
    8686   INTEGER                       ::  nbergs_start, nbergs_end, nbergs_calved 
    8787   INTEGER                       ::  nbergs_melted 
    88    INTEGER                       ::  nspeeding_tickets 
     88   INTEGER                       ::  nspeeding_tickets, nspeeding_tickets_all 
    8989   INTEGER , DIMENSION(nclasses) ::  nbergs_calved_by_class 
    9090 
    … …  
    125125      nbergs_calved_by_class(:) = 0 
    126126      nspeeding_tickets         = 0 
     127      nspeeding_tickets_all     = 0 
    127128      stored_heat_end           = 0._wp 
    128129      floating_heat_end         = 0._wp 
    … …  
    271272            CALL mpp_sum( 'icbdia', nsumbuf(1:nclasses+4), nclasses+4 ) 
    272273            ! 
    273             nbergs_end        = nsumbuf(1) 
    274             nbergs_calved     = nsumbuf(2) 
    275             nbergs_melted     = nsumbuf(3) 
    276             nspeeding_tickets = nsumbuf(4) 
     274            nbergs_end            = nsumbuf(1) 
     275            nbergs_calved         = nsumbuf(2) 
     276            nbergs_melted         = nsumbuf(3) 
     277            nspeeding_tickets_all = nsumbuf(4) 
    277278            DO ik = 1,nclasses 
    278279               nbergs_calved_by_class(ik)= nsumbuf(4+ik) 
    … …  
    329330         IF (nn_verbose_level > 0) THEN 
    330331            WRITE( numicb, '("calved by class = ",i6,20(",",i6))') (nbergs_calved_by_class(ik),ik=1,nclasses) 
    331             IF( nspeeding_tickets > 0 )   WRITE( numicb, '("speeding tickets issued = ",i6)') nspeeding_tickets 
     332            IF( nspeeding_tickets_all > 0 ) THEN 
     333                WRITE( numicb, '("speeding tickets issued (this domain)  = ",i6)') nspeeding_tickets 
     334                WRITE( numicb, '("speeding tickets issued (all domains)  = ",i6)') nspeeding_tickets_all 
     335            END IF 
    332336         ENDIF 
    333337         ! 
    … …  
    338342         nbergs_calved_by_class(:) = 0 
    339343         nspeeding_tickets         = 0 
     344         nspeeding_tickets_all     = 0 
    340345         stored_heat_start         = stored_heat_end 
    341346         floating_heat_start       = floating_heat_end 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ICB/icbdyn.F90

    r14030 r14574  
    8585 
    8686         !                                         !**   A1 = A(X1,V1) 
    87          CALL icb_accel( berg , zxi1, ze1, zuvel1, zuvel1, zax1,     & 
    88             &                   zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2 ) 
     87         CALL icb_accel( kt, berg , zxi1, ze1, zuvel1, zuvel1, zax1,     & 
     88            &                   zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2, 0.5_wp ) 
    8989         ! 
    9090         zu1 = zuvel1 / ze1                           !**   V1 in d(i,j)/dt 
    … …  
    102102 
    103103         !                                         !**   A2 = A(X2,V2) 
    104          CALL icb_accel( berg , zxi2, ze1, zuvel2, zuvel1, zax2,    & 
    105             &                   zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2 ) 
     104         CALL icb_accel( kt, berg , zxi2, ze1, zuvel2, zuvel1, zax2,    & 
     105            &                   zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2, 0.5_wp ) 
    106106         ! 
    107107         zu2 = zuvel2 / ze1                           !**   V2 in d(i,j)/dt 
    … …  
    114114         zyj3  = zyj1  + zdt_2 * zv2   ;   zvvel3 = zvvel1 + zdt_2 * zay2 
    115115         ! 
    116          CALL icb_ground( berg, zxi3, zxi1, zu3,   & 
    117             &                   zyj3, zyj1, zv3, ll_bounced ) 
     116         CALL icb_ground( berg, zxi3, zxi1, zu2,   & 
     117            &                   zyj3, zyj1, zv2, ll_bounced ) 
    118118 
    119119         !                                         !**   A3 = A(X3,V3) 
    120          CALL icb_accel( berg , zxi3, ze1, zuvel3, zuvel1, zax3,    & 
    121             &                   zyj3, ze2, zvvel3, zvvel1, zay3, zdt ) 
     120         CALL icb_accel( kt, berg , zxi3, ze1, zuvel3, zuvel1, zax3,    & 
     121            &                   zyj3, ze2, zvvel3, zvvel1, zay3, zdt, 1._wp ) 
    122122         ! 
    123123         zu3 = zuvel3 / ze1                           !**   V3 in d(i,j)/dt 
    … …  
    130130         zyj4 = zyj1 + zdt * zv3   ;   zvvel4 = zvvel1 + zdt * zay3 
    131131 
    132          CALL icb_ground( berg, zxi4, zxi1, zu4,   & 
    133             &                   zyj4, zyj1, zv4, ll_bounced ) 
     132         CALL icb_ground( berg, zxi4, zxi1, zu3,   & 
     133            &                   zyj4, zyj1, zv3, ll_bounced ) 
    134134 
    135135         !                                         !**   A4 = A(X4,V4) 
    136          CALL icb_accel( berg , zxi4, ze1, zuvel4, zuvel1, zax4,    & 
    137             &                   zyj4, ze2, zvvel4, zvvel1, zay4, zdt ) 
     136         CALL icb_accel( kt, berg , zxi4, ze1, zuvel4, zuvel1, zax4,    & 
     137            &                   zyj4, ze2, zvvel4, zvvel1, zay4, zdt, 1._wp ) 
    138138 
    139139         zu4 = zuvel4 / ze1                           !**   V4 in d(i,j)/dt 
    … …  
    255255 
    256256 
    257    SUBROUTINE icb_accel( berg , pxi, pe1, puvel, puvel0, pax,                & 
    258       &                         pyj, pe2, pvvel, pvvel0, pay, pdt ) 
     257   SUBROUTINE icb_accel( kt, berg , pxi, pe1, puvel, puvel0, pax,                 & 
     258      &                             pyj, pe2, pvvel, pvvel0, pay, pdt, pcfl_scale ) 
    259259      !!---------------------------------------------------------------------- 
    260260      !!                  ***  ROUTINE icb_accel  *** 
    … …  
    265265      !!---------------------------------------------------------------------- 
    266266      TYPE(iceberg ), POINTER, INTENT(in   ) ::   berg             ! berg 
     267      INTEGER                , INTENT(in   ) ::   kt               ! time step 
     268      REAL(wp)               , INTENT(in   ) ::   pcfl_scale 
    267269      REAL(wp)               , INTENT(in   ) ::   pxi   , pyj      ! berg position in (i,j) referential 
    268270      REAL(wp)               , INTENT(in   ) ::   puvel , pvvel    ! berg velocity [m/s] 
    … …  
    404406         zspeed = SQRT( zuveln*zuveln + zvveln*zvveln )    ! Speed of berg 
    405407         IF( zspeed > 0._wp ) THEN 
    406             zloc_dx = MIN( pe1, pe2 )                          ! minimum grid spacing 
    407             zspeed_new = zloc_dx / pdt * rn_speed_limit        ! Speed limit as a factor of dx / dt 
     408            zloc_dx = MIN( pe1, pe2 )                                ! minimum grid spacing 
     409            ! cfl scale is function of the RK4 step 
     410            zspeed_new = zloc_dx / pdt * rn_speed_limit * pcfl_scale ! Speed limit as a factor of dx / dt 
    408411            IF( zspeed_new < zspeed ) THEN 
    409                zuveln = zuveln * ( zspeed_new / zspeed )        ! Scale velocity to reduce speed 
    410                zvveln = zvveln * ( zspeed_new / zspeed )        ! without changing the direction 
     412               zuveln = zuveln * ( zspeed_new / zspeed )             ! Scale velocity to reduce speed 
     413               zvveln = zvveln * ( zspeed_new / zspeed )             ! without changing the direction 
     414               pax = (zuveln - puvel0)/pdt 
     415               pay = (zvveln - pvvel0)/pdt 
     416               ! 
     417               ! print speeding ticket 
     418               IF (nn_verbose_level > 0) THEN 
     419                  WRITE(numicb, 9200) 'icb speeding : ',kt, nknberg, zspeed, & 
     420                       &                pxi, pyj, zuo, zvo, zua, zva, zui, zvi 
     421                  9200 FORMAT(a,i9,i6,f9.2,1x,4(1x,2f9.2)) 
     422               END IF 
     423               ! 
    411424               CALL icb_dia_speed() 
    412425            ENDIF 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ICB/icbini.F90

    r14030 r14574  
    189189       
    190190      ! north fold 
    191       IF( npolj > 0 ) THEN 
     191      IF( l_IdoNFold ) THEN 
    192192         ! 
    193193         ! icebergs in row nicbej+1 get passed across fold 
    … …  
    235235         WRITE(numicb,*) "j point" 
    236236         WRITE(numicb,*) (INT(src_calving(ji,jj)), jj=1,jpj) 
    237          IF( npolj > 0 ) THEN 
     237         IF( l_IdoNFold ) THEN 
    238238            WRITE(numicb,*) 'north fold destination points ' 
    239239            WRITE(numicb,*) nicbfldpts 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ICB/icblbc.F90

    r14229 r14574  
    105105      IF( l_Jperio)      CALL ctl_stop(' north-south periodicity not implemented for icebergs') 
    106106      ! north fold 
    107       IF( npolj /= 0 )   CALL icb_lbc_nfld() 
     107      IF( l_IdoNFold )   CALL icb_lbc_nfld() 
    108108      ! 
    109109   END SUBROUTINE icb_lbc 
    … …  
    179179      ipe_W = -1 
    180180      ipe_E = -1 
    181       IF( nbondi .EQ.  0 .OR. nbondi .EQ. 1) ipe_W = nowe 
    182       IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea 
    183       IF( nbondj .EQ.  0 .OR. nbondj .EQ. 1) ipe_S = noso 
    184       IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono 
     181      IF( mpinei(jpwe) >= 0 ) ipe_W = mpinei(jpwe) 
     182      IF( mpinei(jpea) >= 0 ) ipe_E = mpinei(jpea) 
     183      IF( mpinei(jpso) >= 0 ) ipe_S = mpinei(jpso) 
     184      IF( mpinei(jpno) >= 0 ) ipe_N = mpinei(jpno) 
    185185      ! 
    186186      ! at northern line of processors with north fold handle bergs differently 
    187       IF( npolj > 0 ) ipe_N = -1 
     187      IF( l_IdoNFold )  ipe_N = -1 
    188188 
    189189      ! if there's only one processor in x direction then don't let mpp try to handle periodicity 
    … …  
    200200         WRITE(numicb,*) 'processor nimpp : ', nimpp 
    201201         WRITE(numicb,*) 'processor njmpp : ', njmpp 
    202          WRITE(numicb,*) 'processor nbondi: ', nbondi 
    203          WRITE(numicb,*) 'processor nbondj: ', nbondj 
    204202         CALL flush( numicb ) 
    205203      ENDIF 
    … …  
    271269      ! pattern here is copied from lib_mpp code 
    272270 
    273       SELECT CASE ( nbondi ) 
    274       CASE( -1 ) 
    275          zwebergs(1) = ibergs_to_send_e 
    276          CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) 
    277          CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 
    278          CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
    279          ibergs_rcvd_from_e = INT( zewbergs(2) ) 
    280       CASE(  0 ) 
    281          zewbergs(1) = ibergs_to_send_w 
    282          zwebergs(1) = ibergs_to_send_e 
    283          CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) 
    284          CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) 
    285          CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 
    286          CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 
    287          CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
    288          CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
    289          ibergs_rcvd_from_e = INT( zewbergs(2) ) 
    290          ibergs_rcvd_from_w = INT( zwebergs(2) ) 
    291       CASE(  1 ) 
    292          zewbergs(1) = ibergs_to_send_w 
    293          CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) 
    294          CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 
    295          CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
    296          ibergs_rcvd_from_w = INT( zwebergs(2) ) 
    297       END SELECT 
     271      IF( mpinei(jpwe) >= 0  )   zewbergs(1) = ibergs_to_send_w 
     272      IF( mpinei(jpea) >= 0  )   zwebergs(1) = ibergs_to_send_e 
     273      IF( mpinei(jpwe) >= 0  )   CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) 
     274      IF( mpinei(jpea) >= 0  )   CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) 
     275      IF( mpinei(jpea) >= 0  )   CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 
     276      IF( mpinei(jpwe) >= 0  )   CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 
     277      IF( mpinei(jpwe) >= 0  )   CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
     278      IF( mpinei(jpea) >= 0  )   CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
     279      IF( mpinei(jpea) >= 0  )   ibergs_rcvd_from_e = INT( zewbergs(2) ) 
     280      IF( mpinei(jpwe) >= 0  )   ibergs_rcvd_from_w = INT( zwebergs(2) ) 
     281       
    298282      IF( nn_verbose_level >= 3) THEN 
    299283         WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e 
    300284         CALL flush(numicb) 
    301285      ENDIF 
    302  
    303       SELECT CASE ( nbondi ) 
    304       CASE( -1 ) 
    305          IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 ) 
    306          IF( ibergs_rcvd_from_e > 0 ) THEN 
    307             CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) 
    308             CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) 
    309          ENDIF 
    310          IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
    311          DO i = 1, ibergs_rcvd_from_e 
    312             IF( nn_verbose_level >= 4 ) THEN 
    313                WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' 
    314                CALL flush( numicb ) 
    315             ENDIF 
    316             CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) 
    317          ENDDO 
    318       CASE(  0 ) 
    319          IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 ) 
    320          IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 ) 
    321          IF( ibergs_rcvd_from_e > 0 ) THEN 
    322             CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) 
    323             CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) 
    324          ENDIF 
    325          IF( ibergs_rcvd_from_w > 0 ) THEN 
    326             CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) 
    327             CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 
    328          ENDIF 
    329          IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
    330          IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
    331          DO i = 1, ibergs_rcvd_from_e 
    332             IF( nn_verbose_level >= 4 ) THEN 
    333                WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' 
    334                CALL flush( numicb ) 
    335             ENDIF 
    336             CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) 
    337          END DO 
    338          DO i = 1, ibergs_rcvd_from_w 
    339             IF( nn_verbose_level >= 4 ) THEN 
    340                WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' 
    341                CALL flush( numicb ) 
    342             ENDIF 
    343             CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) 
    344          ENDDO 
    345       CASE(  1 ) 
    346          IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 ) 
    347          IF( ibergs_rcvd_from_w > 0 ) THEN 
    348             CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) 
    349             CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 
    350          ENDIF 
    351          IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
    352          DO i = 1, ibergs_rcvd_from_w 
    353             IF( nn_verbose_level >= 4 ) THEN 
    354                WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' 
    355                CALL flush( numicb ) 
    356             ENDIF 
    357             CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) 
    358          END DO 
    359       END SELECT 
     286       
     287      IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 ) 
     288      IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 ) 
     289      IF( ibergs_rcvd_from_e > 0 ) THEN 
     290         CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) 
     291         CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) 
     292      ENDIF 
     293      IF( ibergs_rcvd_from_w > 0 ) THEN 
     294         CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) 
     295         CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) 
     296      ENDIF 
     297      IF( ibergs_to_send_w > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
     298      IF( ibergs_to_send_e > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
     299      DO i = 1, ibergs_rcvd_from_e 
     300         IF( nn_verbose_level >= 4 ) THEN 
     301            WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' 
     302            CALL FLUSH( numicb ) 
     303         ENDIF 
     304         CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) 
     305      END DO 
     306      DO i = 1, ibergs_rcvd_from_w 
     307         IF( nn_verbose_level >= 4 ) THEN 
     308            WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' 
     309            CALL FLUSH( numicb ) 
     310         ENDIF 
     311         CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) 
     312      END DO 
    360313 
    361314      ! Find number of bergs that headed north/south 
    … …  
    400353      ! send bergs north 
    401354      ! and receive bergs from south (ie ones sent north) 
    402  
    403       SELECT CASE ( nbondj ) 
    404       CASE( -1 ) 
    405          zsnbergs(1) = ibergs_to_send_n 
    406          CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) 
    407          CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 
    408          CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
    409          ibergs_rcvd_from_n = INT( znsbergs(2) ) 
    410       CASE(  0 ) 
    411          znsbergs(1) = ibergs_to_send_s 
    412          zsnbergs(1) = ibergs_to_send_n 
    413          CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) 
    414          CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) 
    415          CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 
    416          CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 
    417          CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
    418          CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
    419          ibergs_rcvd_from_n = INT( znsbergs(2) ) 
    420          ibergs_rcvd_from_s = INT( zsnbergs(2) ) 
    421       CASE(  1 ) 
    422          znsbergs(1) = ibergs_to_send_s 
    423          CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) 
    424          CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 
    425          CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
    426          ibergs_rcvd_from_s = INT( zsnbergs(2) ) 
    427       END SELECT 
    428       if( nn_verbose_level >= 3) then 
    429          write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n 
    430          call flush(numicb) 
    431       endif 
    432  
    433       SELECT CASE ( nbondj ) 
    434       CASE( -1 ) 
    435          IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 ) 
    436          IF( ibergs_rcvd_from_n > 0 ) THEN 
    437             CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) 
    438             CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) 
    439          ENDIF 
    440          IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 
    441          DO i = 1, ibergs_rcvd_from_n 
    442             IF( nn_verbose_level >= 4 ) THEN 
    443                WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' 
    444                CALL flush( numicb ) 
    445             ENDIF 
    446             CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) 
    447          END DO 
    448       CASE(  0 ) 
    449          IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 ) 
    450          IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 ) 
    451          IF( ibergs_rcvd_from_n > 0 ) THEN 
    452             CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) 
    453             CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) 
    454          ENDIF 
    455          IF( ibergs_rcvd_from_s > 0 ) THEN 
    456             CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) 
    457             CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 
    458          ENDIF 
    459          IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
    460          IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
    461          DO i = 1, ibergs_rcvd_from_n 
    462             IF( nn_verbose_level >= 4 ) THEN 
    463                WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' 
    464                CALL flush( numicb ) 
    465             ENDIF 
    466             CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) 
    467          END DO 
    468          DO i = 1, ibergs_rcvd_from_s 
    469             IF( nn_verbose_level >= 4 ) THEN 
    470                WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' 
    471                CALL flush( numicb ) 
    472             ENDIF 
    473             CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) 
    474          ENDDO 
    475       CASE(  1 ) 
    476          IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 ) 
    477          IF( ibergs_rcvd_from_s > 0 ) THEN 
    478             CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) 
    479             CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 
    480          ENDIF 
    481          IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 
    482          DO i = 1, ibergs_rcvd_from_s 
    483             IF( nn_verbose_level >= 4 ) THEN 
    484                WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' 
    485                CALL flush( numicb ) 
    486             ENDIF 
    487             CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) 
    488          END DO 
    489       END SELECT 
    490  
     355       
     356      IF( mpinei(jpso) >= 0  )   znsbergs(1) = ibergs_to_send_s 
     357      IF( mpinei(jpno) >= 0  )   zsnbergs(1) = ibergs_to_send_n 
     358      IF( mpinei(jpso) >= 0  )   CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) 
     359      IF( mpinei(jpno) >= 0  )   CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) 
     360      IF( mpinei(jpno) >= 0  )   CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 
     361      IF( mpinei(jpso) >= 0  )   CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 
     362      IF( mpinei(jpso) >= 0  )   CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
     363      IF( mpinei(jpno) >= 0  )   CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
     364      IF( mpinei(jpno) >= 0  )   ibergs_rcvd_from_n = INT( znsbergs(2) ) 
     365      IF( mpinei(jpso) >= 0  )   ibergs_rcvd_from_s = INT( zsnbergs(2) ) 
     366       
     367      IF( nn_verbose_level >= 3) THEN 
     368         WRITE(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n 
     369         CALL FLUSH(numicb) 
     370      ENDIF 
     371 
     372      IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 ) 
     373      IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 ) 
     374      IF( ibergs_rcvd_from_n > 0 ) THEN 
     375         CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) 
     376         CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) 
     377      ENDIF 
     378      IF( ibergs_rcvd_from_s > 0 ) THEN 
     379         CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) 
     380         CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) 
     381      ENDIF 
     382      IF( ibergs_to_send_s > 0 ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 
     383      IF( ibergs_to_send_n > 0 ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) 
     384      DO i = 1, ibergs_rcvd_from_n 
     385         IF( nn_verbose_level >= 4 ) THEN 
     386            WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' 
     387            CALL FLUSH( numicb ) 
     388         ENDIF 
     389         CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) 
     390      END DO 
     391      DO i = 1, ibergs_rcvd_from_s 
     392         IF( nn_verbose_level >= 4 ) THEN 
     393            WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' 
     394            CALL FLUSH( numicb ) 
     395         ENDIF 
     396         CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) 
     397      END DO 
     398       
    491399      IF( nn_verbose_level > 0 ) THEN 
    492400         ! compare the number of icebergs on this processor from the start to the end 
    … …  
    527435      ! deal with north fold if we necessary when there is more than one top row processor 
    528436      ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc 
    529       IF( npolj /= 0 .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( ) 
     437      IF( l_IdoNFold .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( ) 
    530438 
    531439      IF( nn_verbose_level > 0 ) THEN 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ICB/icbutl.F90

    r14118 r14574  
    320320         ! 
    321321         IF ( ierr > 0 ) THEN 
    322             WRITE(numout,*) 'bottom left corner T point out of bound' 
    323             WRITE(numout,*) pi, kii, mig( 1 ), mig(jpi) 
    324             WRITE(numout,*) pj, kij, mjg( 1 ), mjg(jpj) 
    325             WRITE(numout,*) pmsk 
    326             CALL ctl_stop('STOP','icb_utl_bilin_h: an icebergs coordinates is out of valid range (out of bound error)') 
     322            WRITE(numicb,*) 'bottom left corner T point out of bound' 
     323            WRITE(numicb,*) pi, kii, mig( 1 ), mig(jpi) 
     324            WRITE(numicb,*) pj, kij, mjg( 1 ), mjg(jpj) 
     325            WRITE(numicb,*) pmsk 
     326            CALL FLUSH(numicb) 
     327            CALL ctl_stop('STOP','icb_utl_bilin_e: an icebergs coordinates is out of valid range (out of bound error).'       , & 
     328                 &                                'This can be fixed using rn_speed_limit=0.4 in &namberg.'                   , & 
     329                 &                                'More details in the corresponding iceberg.stat file (nn_verbose_level > 0).' ) 
    327330         END IF 
    328331      END IF 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/IOM/iom_nf90.F90

    r14072 r14574  
    443443         IF(PRESENT(cdatt0d))   CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = cdatt0d), clinfo) 
    444444      ELSE 
    445          CALL ctl_warn('iom_nf90_getatt: no attribute '//TRIM(cdatt)//' found') 
    446445         IF(PRESENT( katt0d))    katt0d    = -999 
    447446         IF(PRESENT( katt1d))    katt1d(:) = -999 
    448447         IF(PRESENT( patt0d))    patt0d    = -999._wp 
    449448         IF(PRESENT( patt1d))    patt1d(:) = -999._wp 
    450          IF(PRESENT(cdatt0d))   cdatt0d    = '!' 
     449         IF(PRESENT(cdatt0d))   cdatt0d    = 'UNKNOWN' 
    451450      ENDIF 
    452451      ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ISF/isfcav.F90

    r14072 r14574  
    136136      ! 
    137137      ! lbclnk on melt 
    138       CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1.0_wp, pqfwf, 'T', 1.0_wp) 
     138      CALL lbc_lnk( 'isfmlt', zqh, 'T', 1.0_wp, pqfwf, 'T', 1.0_wp) 
    139139      ! 
    140140      ! output fluxes 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ISF/isfcpl.F90

    r14143 r14574  
    205205         zssmask0(:,:) = zssmask_b(:,:) 
    206206         ! 
    207          CALL lbc_lnk_multi( 'iscplrst', zssh, 'T', 1.0_wp, zssmask0, 'T', 1.0_wp ) 
     207         CALL lbc_lnk( 'iscplrst', zssh, 'T', 1.0_wp, zssmask0, 'T', 1.0_wp ) 
    208208         ! 
    209209      END DO 
    … …  
    363363         ztmask0(:,:,:) = ztmask1(:,:,:) 
    364364         ! 
    365          CALL lbc_lnk_multi( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1.0_wp, zts0(:,:,:,jp_sal), 'T', 1.0_wp, ztmask0, 'T', 1.0_wp) 
     365         CALL lbc_lnk( 'iscplrst', zts0(:,:,:,jp_tem), 'T', 1.0_wp, zts0(:,:,:,jp_sal), 'T', 1.0_wp, ztmask0, 'T', 1.0_wp) 
    366366         ! 
    367367      END DO  ! nn_drown 
    … …  
    691691      ! 
    692692      ! add lbclnk 
    693       CALL lbc_lnk_multi( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, & 
    694          &                            risfcpl_cons_vol(:,:,:)       , 'T', 1.0_wp) 
     693      CALL lbc_lnk( 'iscplrst', risfcpl_cons_tsc(:,:,:,jp_tem), 'T', 1.0_wp, risfcpl_cons_tsc(:,:,:,jp_sal), 'T', 1.0_wp, & 
     694         &                      risfcpl_cons_vol(:,:,:)       , 'T', 1.0_wp) 
    695695      ! 
    696696      ! ssh correction (for dynspg_ts) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ISF/isfpar.F90

    r13226 r14574  
    8282      ! 
    8383      ! lbclnk on melt and heat fluxes 
    84       CALL lbc_lnk_multi( 'isfmlt', zqh, 'T', 1.0_wp, pqfwf, 'T', 1.0_wp) 
     84      CALL lbc_lnk( 'isfmlt', zqh, 'T', 1.0_wp, pqfwf, 'T', 1.0_wp) 
    8585      ! 
    8686      ! output fluxes 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lbc_nfd_ext_generic.h90

    r13286 r14574  
    1 !                          !==  IN: ptab is an array  ==! 
    2 #define NAT_IN(k)                cd_nat 
    3 #define SGN_IN(k)                psgn 
    4 #define F_SIZE(ptab)             1 
    5 #if defined DIM_2d 
    6 #   define ARRAY_IN(i,j,k,l,f)   ptab(i,j) 
    7 #   define K_SIZE(ptab)          1 
    8 #   define L_SIZE(ptab)          1 
    9 #endif 
    10 #if defined SINGLE_PRECISION 
    11 #   define ARRAY_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
    12 #   define PRECISION sp 
    13 #else 
    14 #   define ARRAY_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
    15 #   define PRECISION dp 
    16 #endif 
    171 
    18    SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj ) 
     2   SUBROUTINE lbc_nfd_ext_/**/PRECISION( ptab, cd_nat, psgn, kextj ) 
    193      !!---------------------------------------------------------------------- 
    20       INTEGER          , INTENT(in   ) ::   kextj       ! extra halo width at north fold, declared before its use in ARRAY_TYPE 
    21       ARRAY_TYPE(:,1-kextj:,:,:,:)                      ! array or pointer of arrays on which the boundary condition is applied 
    22       CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    23       REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
     4      REAL(PRECISION), DIMENSION(:,1-kextj:),INTENT(inout) ::   ptab 
     5      CHARACTER(len=1), INTENT(in   ) ::   cd_nat      ! nature of array grid-points 
     6      REAL(PRECISION),  INTENT(in   ) ::   psgn        ! sign used across the north fold boundary 
     7      INTEGER,          INTENT(in   ) ::   kextj       ! extra halo width at north fold 
    248      ! 
    25       INTEGER  ::    ji,  jj,  jk,  jl, jh,  jf   ! dummy loop indices 
    26       INTEGER  ::   ipi, ipj, ipk, ipl,     ipf   ! dimension of the input array 
     9      INTEGER  ::    ji,  jj,  jh   ! dummy loop indices 
     10      INTEGER  ::   ipj 
    2711      INTEGER  ::   ijt, iju, ipjm1 
    2812      !!---------------------------------------------------------------------- 
    29       ! 
    30       ipk = K_SIZE(ptab)   ! 3rd dimension 
    31       ipl = L_SIZE(ptab)   ! 4th    - 
    32       ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    33       ! 
    3413      ! 
    3514      SELECT CASE ( jpni ) 
    … …  
    3918      ! 
    4019      ipjm1 = ipj-1 
     20      ! 
     21      IF( c_NFtype == 'T' ) THEN            ! *  North fold  T-point pivot 
     22         ! 
     23         SELECT CASE ( cd_nat  ) 
     24         CASE ( 'T' , 'W' )                         ! T-, W-point 
     25            DO jh = 0, kextj 
     26               DO ji = 2, jpiglo 
     27                  ijt = jpiglo-ji+2 
     28                  ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) 
     29               END DO 
     30               ptab(1,ipj+jh) = psgn * ptab(3,ipj-2-jh) 
     31            END DO 
     32            DO ji = jpiglo/2+1, jpiglo 
     33               ijt = jpiglo-ji+2 
     34               ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) 
     35            END DO 
     36         CASE ( 'U' )                               ! U-point 
     37            DO jh = 0, kextj 
     38               DO ji = 2, jpiglo-1 
     39                  iju = jpiglo-ji+1 
     40                  ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-2-jh) 
     41               END DO 
     42               ptab(   1  ,ipj+jh) = psgn * ptab(    2   ,ipj-2-jh) 
     43               ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-2-jh)  
     44            END DO 
     45            DO ji = jpiglo/2, jpiglo-1 
     46               iju = jpiglo-ji+1 
     47               ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) 
     48            END DO 
     49         CASE ( 'V' )                               ! V-point 
     50            DO jh = 0, kextj 
     51               DO ji = 2, jpiglo 
     52                  ijt = jpiglo-ji+2 
     53                  ptab(ji,ipj-1+jh) = psgn * ptab(ijt,ipj-2-jh) 
     54                  ptab(ji,ipj+jh  ) = psgn * ptab(ijt,ipj-3-jh) 
     55               END DO 
     56               ptab(1,ipj+jh) = psgn * ptab(3,ipj-3-jh)  
     57            END DO 
     58         CASE ( 'F' )                               ! F-point 
     59            DO jh = 0, kextj 
     60               DO ji = 1, jpiglo-1 
     61                  iju = jpiglo-ji+1 
     62                  ptab(ji,ipj-1+jh) = psgn * ptab(iju,ipj-2-jh) 
     63                  ptab(ji,ipj+jh  ) = psgn * ptab(iju,ipj-3-jh) 
     64               END DO 
     65            END DO 
     66            DO jh = 0, kextj 
     67               ptab(   1  ,ipj+jh) = psgn * ptab(    2   ,ipj-3-jh) 
     68               ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-1,ipj-3-jh) 
     69            END DO 
     70         END SELECT 
     71         ! 
     72      ENDIF   ! c_NFtype == 'T' 
     73      ! 
     74      IF( c_NFtype == 'F' ) THEN            ! *  North fold  F-point pivot 
     75         ! 
     76         SELECT CASE ( cd_nat  ) 
     77         CASE ( 'T' , 'W' )                         ! T-, W-point 
     78            DO jh = 0, kextj 
     79               DO ji = 1, jpiglo 
     80                  ijt = jpiglo-ji+1 
     81                  ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-1-jh) 
     82               END DO 
     83            END DO 
     84         CASE ( 'U' )                               ! U-point 
     85            DO jh = 0, kextj 
     86               DO ji = 1, jpiglo-1 
     87                  iju = jpiglo-ji 
     88                  ptab(ji,ipj+jh) = psgn * ptab(iju,ipj-1-jh) 
     89               END DO 
     90               ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-1-jh) 
     91            END DO 
     92         CASE ( 'V' )                               ! V-point 
     93            DO jh = 0, kextj 
     94               DO ji = 1, jpiglo 
     95                  ijt = jpiglo-ji+1 
     96                  ptab(ji,ipj+jh) = psgn * ptab(ijt,ipj-2-jh) 
     97               END DO 
     98            END DO 
     99            DO ji = jpiglo/2+1, jpiglo 
     100               ijt = jpiglo-ji+1 
     101               ptab(ji,ipjm1) = psgn * ptab(ijt,ipjm1) 
     102            END DO 
     103         CASE ( 'F' )                               ! F-point 
     104            DO jh = 0, kextj 
     105               DO ji = 1, jpiglo-1 
     106                  iju = jpiglo-ji 
     107                  ptab(ji,ipj+jh  ) = psgn * ptab(iju,ipj-2-jh) 
     108               END DO 
     109               ptab(jpiglo,ipj+jh) = psgn * ptab(jpiglo-2,ipj-2-jh) 
     110            END DO 
     111            DO ji = jpiglo/2+1, jpiglo-1 
     112               iju = jpiglo-ji 
     113               ptab(ji,ipjm1) = psgn * ptab(iju,ipjm1) 
     114            END DO 
     115         END SELECT 
     116         ! 
     117      ENDIF   ! c_NFtype == 'F' 
     118      ! 
     119   END SUBROUTINE lbc_nfd_ext_/**/PRECISION 
    41120 
    42       ! 
    43       DO jf = 1, ipf                      ! Loop on the number of arrays to be treated 
    44          ! 
    45          SELECT CASE ( npolj ) 
    46          ! 
    47          CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
    48             ! 
    49             SELECT CASE ( NAT_IN(jf)  ) 
    50             CASE ( 'T' , 'W' )                         ! T-, W-point 
    51                DO jh = 0, kextj 
    52                   DO ji = 2, jpiglo 
    53                      ijt = jpiglo-ji+2 
    54                      ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-2-jh,:,:,jf) 
    55                   END DO 
    56                   ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(3,ipj-2-jh,:,:,jf) 
    57                END DO 
    58                DO ji = jpiglo/2+1, jpiglo 
    59                   ijt = jpiglo-ji+2 
    60                   ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipjm1,:,:,jf) 
    61                END DO 
    62             CASE ( 'U' )                               ! U-point 
    63                DO jh = 0, kextj 
    64                   DO ji = 2, jpiglo-1 
    65                      iju = jpiglo-ji+1 
    66                      ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-2-jh,:,:,jf) 
    67                   END DO 
    68                  ARRAY_IN(   1  ,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(    2   ,ipj-2-jh,:,:,jf) 
    69                  ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(jpiglo-1,ipj-2-jh,:,:,jf)  
    70                END DO 
    71                DO ji = jpiglo/2, jpiglo-1 
    72                   iju = jpiglo-ji+1 
    73                   ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipjm1,:,:,jf) 
    74                END DO 
    75             CASE ( 'V' )                               ! V-point 
    76                DO jh = 0, kextj 
    77                   DO ji = 2, jpiglo 
    78                      ijt = jpiglo-ji+2 
    79                      ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-2-jh,:,:,jf) 
    80                      ARRAY_IN(ji,ipj+jh  ,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-3-jh,:,:,jf) 
    81                   END DO 
    82                   ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(3,ipj-3-jh,:,:,jf)  
    83                END DO 
    84             CASE ( 'F' )                               ! F-point 
    85                DO jh = 0, kextj 
    86                   DO ji = 1, jpiglo-1 
    87                      iju = jpiglo-ji+1 
    88                      ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-2-jh,:,:,jf) 
    89                      ARRAY_IN(ji,ipj+jh  ,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-3-jh,:,:,jf) 
    90                   END DO 
    91                END DO 
    92                DO jh = 0, kextj 
    93                   ARRAY_IN(   1  ,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(    2   ,ipj-3-jh,:,:,jf) 
    94                   ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(jpiglo-1,ipj-3-jh,:,:,jf) 
    95                END DO 
    96             END SELECT 
    97             ! 
    98          CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    99             ! 
    100             SELECT CASE ( NAT_IN(jf)  ) 
    101             CASE ( 'T' , 'W' )                         ! T-, W-point 
    102                DO jh = 0, kextj 
    103                   DO ji = 1, jpiglo 
    104                      ijt = jpiglo-ji+1 
    105                      ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-1-jh,:,:,jf) 
    106                   END DO 
    107                END DO 
    108             CASE ( 'U' )                               ! U-point 
    109                DO jh = 0, kextj 
    110                   DO ji = 1, jpiglo-1 
    111                      iju = jpiglo-ji 
    112                      ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-1-jh,:,:,jf) 
    113                   END DO 
    114                   ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(jpiglo-2,ipj-1-jh,:,:,jf) 
    115                END DO 
    116             CASE ( 'V' )                               ! V-point 
    117                DO jh = 0, kextj 
    118                   DO ji = 1, jpiglo 
    119                      ijt = jpiglo-ji+1 
    120                      ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipj-2-jh,:,:,jf) 
    121                   END DO 
    122                END DO 
    123                DO ji = jpiglo/2+1, jpiglo 
    124                   ijt = jpiglo-ji+1 
    125                   ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(ijt,ipjm1,:,:,jf) 
    126                END DO 
    127             CASE ( 'F' )                               ! F-point 
    128                DO jh = 0, kextj 
    129                   DO ji = 1, jpiglo-1 
    130                      iju = jpiglo-ji 
    131                      ARRAY_IN(ji,ipj+jh  ,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipj-2-jh,:,:,jf) 
    132                   END DO 
    133                   ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(jpiglo-2,ipj-2-jh,:,:,jf) 
    134                END DO 
    135                DO ji = jpiglo/2+1, jpiglo-1 
    136                   iju = jpiglo-ji 
    137                   ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf)  * ARRAY_IN(iju,ipjm1,:,:,jf) 
    138                END DO 
    139             END SELECT 
    140             ! 
    141          CASE DEFAULT                           ! *  closed : the code probably never go through 
    142             ! 
    143             SELECT CASE ( NAT_IN(jf) ) 
    144             CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    145                ARRAY_IN(:,  1:1-kextj  ,:,:,jf) = 0._wp 
    146                ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp 
    147             CASE ( 'F' )                               ! F-point 
    148                ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp 
    149             END SELECT 
    150             ! 
    151          END SELECT     !  npolj 
    152          ! 
    153       END DO 
    154       ! 
    155    END SUBROUTINE ROUTINE_NFD 
    156  
    157 #undef PRECISION 
    158 #undef ARRAY_TYPE 
    159 #undef ARRAY_IN 
    160 #undef NAT_IN 
    161 #undef SGN_IN 
    162 #undef K_SIZE 
    163 #undef L_SIZE 
    164 #undef F_SIZE 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lbc_nfd_generic.h90

    r13286 r14574  
    1 #if defined MULTI 
    2 #   define NAT_IN(k)                cd_nat(k)    
    3 #   define SGN_IN(k)                psgn(k) 
    4 #   define F_SIZE(ptab)             kfld 
    5 #   if defined DIM_2d 
    6 #      if defined SINGLE_PRECISION 
    7 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 
    8 #      else 
    9 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 
    10 #      endif 
    11 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    12 #      define J_SIZE(ptab)             SIZE(ptab(1)%pt2d,2) 
    13 #      define K_SIZE(ptab)             1 
    14 #      define L_SIZE(ptab)             1 
    15 #   endif 
    16 #   if defined DIM_3d 
    17 #      if defined SINGLE_PRECISION 
    18 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 
    19 #      else 
    20 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 
    21 #      endif 
    22 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    23 #      define J_SIZE(ptab)             SIZE(ptab(1)%pt3d,2) 
    24 #      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    25 #      define L_SIZE(ptab)             1 
    26 #   endif 
    27 #   if defined DIM_4d 
    28 #      if defined SINGLE_PRECISION 
    29 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 
    30 #      else 
    31 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 
    32 #      endif 
    33 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    34 #      define J_SIZE(ptab)             SIZE(ptab(1)%pt4d,2) 
    35 #      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    36 #      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4) 
    37 #   endif 
    38 #else 
    39 !                          !==  IN: ptab is an array  ==! 
    40 #   define NAT_IN(k)                cd_nat 
    41 #   define SGN_IN(k)                psgn 
    42 #   define F_SIZE(ptab)             1 
    43 #   if defined DIM_2d 
    44 #      define ARRAY_IN(i,j,k,l,f)   ptab(i,j) 
    45 #      define J_SIZE(ptab)          SIZE(ptab,2) 
    46 #      define K_SIZE(ptab)          1 
    47 #      define L_SIZE(ptab)          1 
    48 #   endif 
    49 #   if defined DIM_3d 
    50 #      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k) 
    51 #      define J_SIZE(ptab)          SIZE(ptab,2) 
    52 #      define K_SIZE(ptab)          SIZE(ptab,3) 
    53 #      define L_SIZE(ptab)          1 
    54 #   endif 
    55 #   if defined DIM_4d 
    56 #      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l) 
    57 #      define J_SIZE(ptab)          SIZE(ptab,2) 
    58 #      define K_SIZE(ptab)          SIZE(ptab,3) 
    59 #      define L_SIZE(ptab)          SIZE(ptab,4) 
    60 #   endif 
    61 #   if defined SINGLE_PRECISION 
    62 #      define ARRAY_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
    63 #   else 
    64 #      define ARRAY_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
    65 #   endif 
    66 #endif 
    671 
    68 #   if defined SINGLE_PRECISION 
    69 #      define PRECISION sp 
    70 #   else 
    71 #      define PRECISION dp 
    72 #   endif 
    73  
    74 #if defined MULTI 
    75    SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) 
    76       INTEGER          , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    77 #else 
    78    SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn       ) 
    79 #endif 
    80       ARRAY_TYPE(:,:,:,:,:)                             ! array or pointer of arrays on which the boundary condition is applied 
    81       CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    82       REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
     2   SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, khls, kfld ) 
     3      TYPE(PTR_4d_/**/PRECISION),  DIMENSION(:), INTENT(inout) ::   ptab        ! pointer of arrays on which apply the b.c. 
     4      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_nat      ! nature of array grid-points 
     5      REAL(PRECISION),  DIMENSION(:), INTENT(in   ) ::   psgn        ! sign used across the north fold boundary 
     6      INTEGER                       , INTENT(in   ) ::   khls        ! halo size, default = nn_hls 
     7      INTEGER                       , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    838      ! 
    849      INTEGER  ::    ji,  jj,  jk,  jl,  jf   ! dummy loop indices 
    85       INTEGER  ::       ipj, ipk, ipl, ipf   ! dimension of the input array 
     10      INTEGER  ::   ipi, ipj, ipk, ipl, ipf   ! dimension of the input array 
    8611      INTEGER  ::   ii1, ii2, ij1, ij2 
    8712      !!---------------------------------------------------------------------- 
    8813      ! 
    89       ipj = J_SIZE(ptab)   ! 2nd dimension 
    90       ipk = K_SIZE(ptab)   ! 3rd    - 
    91       ipl = L_SIZE(ptab)   ! 4th    - 
    92       ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
     14      ipi = SIZE(ptab(1)%pt4d,1) 
     15      ipj = SIZE(ptab(1)%pt4d,2) 
     16      ipk = SIZE(ptab(1)%pt4d,3) 
     17      ipl = SIZE(ptab(1)%pt4d,4) 
     18      ipf = kfld 
     19      ! 
     20      IF( ipi /= Ni0glo+2*khls ) THEN 
     21         WRITE(ctmp1,*) 'lbc_nfd input array does not match khls', ipi, khls, Ni0glo 
     22         CALL ctl_stop( 'STOP', ctmp1 ) 
     23      ENDIF 
    9324      ! 
    9425      DO jf = 1, ipf                      ! Loop on the number of arrays to be treated 
    9526         ! 
    96          SELECT CASE ( npolj ) 
     27         IF( c_NFtype == 'T' ) THEN            ! *  North fold  T-point pivot 
     28            ! 
     29            SELECT CASE ( cd_nat(jf) ) 
     30            CASE ( 'T' , 'W' )                         ! T-, W-point 
     31               DO jl = 1, ipl; DO jk = 1, ipk 
     32                  ! 
     33                  ! last khls lines (from ipj to ipj-khls+1) : full 
     34                    DO jj = 1, khls 
     35                       ij1 = ipj          - jj + 1         ! ends at: ipj - khls + 1 
     36                     ij2 = ipj - 2*khls + jj - 1         ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 
     37                     ! 
     38                     DO ji = 1, khls              ! first khls points 
     39                        ii1 =              ji            ! ends at: khls 
     40                        ii2 = 2*khls + 2 - ji            ! ends at: 2*khls + 2 - khls = khls + 2 
     41                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     42                     END DO 
     43                     DO ji = 1, 1                 ! point khls+1 
     44                        ii1 = khls + ji 
     45                        ii2 = ii1 
     46                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     47                     END DO 
     48                     DO ji = 1, Ni0glo - 1        ! points from khls+2 to ipi - khls   (note: Ni0glo = ipi - 2*khls) 
     49                        ii1 =   2 + khls + ji - 1        ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls 
     50                        ii2 = ipi - khls - ji + 1        ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 
     51                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     52                     END DO 
     53                     DO ji = 1, 1                 ! point ipi - khls + 1 
     54                        ii1 = ipi - khls + ji 
     55                        ii2 =          khls + ji 
     56                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     57                     END DO 
     58                     DO ji = 1, khls-1            ! last khls-1 points 
     59                        ii1 = ipi - khls + 1 + ji        ! ends at: ipi - khls + 1 + khls - 1 = ipi 
     60                        ii2 = ipi - khls + 1 - ji        ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 
     61                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     62                     END DO 
     63                  END DO 
     64                  ! 
     65                  ! line number ipj-khls : right half 
     66                    DO jj = 1, 1 
     67                     ij1 = ipj - khls 
     68                     ij2 = ij1   ! same line 
     69                     ! 
     70                     DO ji = 1, Ni0glo/2-1        ! points from ipi/2+2 to ipi - khls   (note: Ni0glo = ipi - 2*khls) 
     71                        ii1 = ipi/2 + ji + 1             ! ends at: ipi/2 + (ipi/2 - khls - 1) + 1 = ipi - khls 
     72                        ii2 = ipi/2 - ji + 1             ! ends at: ipi/2 - (ipi/2 - khls - 1) + 1 = khls + 2 
     73                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     74                     END DO 
     75                     DO ji = 1, khls              ! first khls points: redo them just in case (if e-w periodocity already done) 
     76                        !                         ! as we just changed points ipi-2khls+1 to ipi-khls   
     77                        ii1 =              ji            ! ends at: khls 
     78                        ii2 = 2*khls + 2 - ji            ! ends at: 2*khls + 2 - khls = khls + 2 
     79                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     80                     END DO 
     81                     !                            ! last khls-1 points: have been / will done by e-w periodicity  
     82                  END DO 
     83                  ! 
     84               END DO; END DO 
     85            CASE ( 'U' )                               ! U-point 
     86               DO jl = 1, ipl; DO jk = 1, ipk 
     87                  ! 
     88                  ! last khls lines (from ipj to ipj-khls+1) : full 
     89                    DO jj = 1, khls 
     90                       ij1 = ipj          - jj + 1         ! ends at: ipj - khls + 1 
     91                     ij2 = ipj - 2*khls + jj - 1         ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 
     92                     ! 
     93                     DO ji = 1, khls              ! first khls points 
     94                        ii1 =              ji            ! ends at: khls 
     95                        ii2 = 2*khls + 1 - ji            ! ends at: 2*khls + 1 - khls = khls + 1 
     96                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     97                     END DO 
     98                     DO ji = 1, Ni0glo            ! points from khls to ipi - khls   (note: Ni0glo = ipi - 2*khls) 
     99                        ii1 =       khls + ji            ! ends at: khls + ipi - 2*khls = ipi - khls 
     100                        ii2 = ipi - khls - ji + 1        ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 
     101                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     102                     END DO 
     103                     DO ji = 1, khls              ! last khls points 
     104                        ii1 = ipi - khls + ji            ! ends at: ipi - khls + khls = ipi 
     105                        ii2 = ipi - khls + 1 - ji        ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
     106                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     107                     END DO 
     108                  END DO 
     109                  ! 
     110                  ! line number ipj-khls : right half 
     111                    DO jj = 1, 1 
     112                     ij1 = ipj - khls 
     113                     ij2 = ij1   ! same line 
     114                     ! 
     115                     DO ji = 1, Ni0glo/2          ! points from ipi/2+1 to ipi - khls   (note: Ni0glo = ipi - 2*khls) 
     116                        ii1 = ipi/2 + ji                 ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls 
     117                        ii2 = ipi/2 - ji + 1             ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 
     118                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     119                     END DO 
     120                     DO ji = 1, khls              ! first khls points: redo them just in case (if e-w periodocity already done) 
     121                        !                         ! as we just changed points ipi-2khls+1 to ipi-khls   
     122                        ii1 =              ji            ! ends at: khls 
     123                        ii2 = 2*khls + 1 - ji            ! ends at: 2*khls + 1 - khls = khls + 1 
     124                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     125                     END DO 
     126                     !                            ! last khls-1 points: have been / will done by e-w periodicity  
     127                  END DO 
     128                  ! 
     129               END DO; END DO 
     130            CASE ( 'V' )                               ! V-point 
     131               DO jl = 1, ipl; DO jk = 1, ipk 
     132                  ! 
     133                  ! last khls+1 lines (from ipj to ipj-khls) : full 
     134                    DO jj = 1, khls+1 
     135                       ij1 = ipj          - jj + 1         ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls 
     136                     ij2 = ipj - 2*khls + jj - 2         ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 
     137                     ! 
     138                     DO ji = 1, khls              ! first khls points 
     139                        ii1 =              ji            ! ends at: khls 
     140                        ii2 = 2*khls + 2 - ji            ! ends at: 2*khls + 2 - khls = khls + 2 
     141                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     142                     END DO 
     143                     DO ji = 1, 1                 ! point khls+1 
     144                        ii1 = khls + ji 
     145                        ii2 = ii1 
     146                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     147                     END DO 
     148                     DO ji = 1, Ni0glo - 1        ! points from khls+2 to ipi - khls   (note: Ni0glo = ipi - 2*khls) 
     149                        ii1 =   2 + khls + ji - 1        ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls 
     150                        ii2 = ipi - khls - ji + 1        ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2 
     151                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     152                     END DO 
     153                     DO ji = 1, 1                 ! point ipi - khls + 1 
     154                        ii1 = ipi - khls + ji 
     155                        ii2 =          khls + ji 
     156                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     157                     END DO 
     158                     DO ji = 1, khls-1            ! last khls-1 points 
     159                        ii1 = ipi - khls + 1 + ji        ! ends at: ipi - khls + 1 + khls - 1 = ipi 
     160                        ii2 = ipi - khls + 1 - ji        ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2 
     161                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     162                     END DO 
     163                  END DO 
     164                  ! 
     165               END DO; END DO 
     166            CASE ( 'F' )                               ! F-point 
     167               DO jl = 1, ipl; DO jk = 1, ipk 
     168                  ! 
     169                  ! last khls+1 lines (from ipj to ipj-khls) : full 
     170                    DO jj = 1, khls+1 
     171                       ij1 = ipj          - jj + 1         ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls 
     172                     ij2 = ipj - 2*khls + jj - 2         ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1 
     173                     ! 
     174                     DO ji = 1, khls              ! first khls points 
     175                        ii1 =              ji            ! ends at: khls 
     176                        ii2 = 2*khls + 1 - ji            ! ends at: 2*khls + 1 - khls = khls + 1 
     177                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     178                     END DO 
     179                     DO ji = 1, Ni0glo            ! points from khls to ipi - khls   (note: Ni0glo = ipi - 2*khls) 
     180                        ii1 =       khls + ji            ! ends at: khls + ipi - 2*khls = ipi - khls 
     181                        ii2 = ipi - khls - ji + 1        ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 
     182                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     183                     END DO 
     184                     DO ji = 1, khls              ! last khls points 
     185                        ii1 = ipi - khls + ji            ! ends at: ipi - khls + khls = ipi 
     186                        ii2 = ipi - khls + 1 - ji        ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
     187                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     188                     END DO 
     189                  END DO 
     190                  ! 
     191               END DO; END DO 
     192            END SELECT   ! cd_nat(jf) 
     193            ! 
     194         ENDIF   ! c_NFtype == 'T' 
    97195         ! 
    98          CASE ( 3 , 4 )                        ! *  North fold  T-point pivot 
     196         IF( c_NFtype == 'F' ) THEN            ! *  North fold  F-point pivot 
    99197            ! 
    100             SELECT CASE ( NAT_IN(jf) ) 
     198            SELECT CASE ( cd_nat(jf) ) 
    101199            CASE ( 'T' , 'W' )                         ! T-, W-point 
    102200               DO jl = 1, ipl; DO jk = 1, ipk 
    103201                  ! 
    104                   ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 
    105                     DO jj = 1, nn_hls 
    106                        ij1 = ipj            - jj + 1       ! ends at: ipj - nn_hls + 1 
    107                      ij2 = ipj - 2*nn_hls + jj - 1       ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 
    108                      ! 
    109                      DO ji = 1, nn_hls            ! first nn_hls points 
    110                         ii1 =                ji          ! ends at: nn_hls 
    111                         ii2 = 2*nn_hls + 2 - ji          ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 
    112                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    113                      END DO 
    114                      DO ji = 1, 1                 ! point nn_hls+1 
    115                         ii1 = nn_hls + ji 
     202                  ! first: line number ipj-khls : 3 points 
     203                    DO jj = 1, 1 
     204                     ij1 = ipj - khls 
     205                     ij2 = ij1   ! same line 
     206                     ! 
     207                     DO ji = 1, 1                 ! points from ipi/2+1 
     208                        ii1 = ipi/2 + ji 
     209                        ii2 = ipi/2 - ji + 1 
     210                        ptab(jf)%pt4d(ii1,ij1,jk,jl) =            ptab(jf)%pt4d(ii2,ij2,jk,jl)   ! Warning: pb with sign... 
     211                     END DO 
     212                     DO ji = 1, 1                 ! points ipi - khls 
     213                        ii1 = ipi - khls + ji - 1 
     214                        ii2 =          khls + ji 
     215                        ptab(jf)%pt4d(ii1,ij1,jk,jl) =            ptab(jf)%pt4d(ii2,ij2,jk,jl)   ! Warning: pb with sign... 
     216                     END DO 
     217                     DO ji = 1, 1                 ! point khls: redo it just in case (if e-w periodocity already done) 
     218                        !                         ! as we just changed point ipi - khls 
     219                        ii1 = khls + ji - 1 
     220                        ii2 = khls + ji 
     221                        ptab(jf)%pt4d(ii1,ij1,jk,jl) =            ptab(jf)%pt4d(ii2,ij2,jk,jl)   ! Warning: pb with sign... 
     222                     END DO 
     223                  END DO 
     224                  ! 
     225                  ! Second: last khls lines (from ipj to ipj-khls+1) : full 
     226                    DO jj = 1, khls 
     227                       ij1 = ipj + 1      - jj             ! ends at: ipj + 1 - khls 
     228                     ij2 = ipj - 2*khls + jj             ! ends at: ipj - 2*khls + khls = ipj - khls 
     229                     ! 
     230                     DO ji = 1, khls              ! first khls points 
     231                        ii1 =              ji            ! ends at: khls 
     232                        ii2 = 2*khls + 1 - ji            ! ends at: 2*khls + 1 - khls = khls + 1 
     233                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     234                     END DO 
     235                     DO ji = 1, Ni0glo            ! points from khls to ipi - khls   (note: Ni0glo = ipi - 2*khls) 
     236                        ii1 =       khls + ji            ! ends at: khls + ipi - 2*khls = ipi - khls 
     237                        ii2 = ipi - khls - ji + 1        ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 
     238                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     239                     END DO 
     240                     DO ji = 1, khls              ! last khls points 
     241                        ii1 = ipi - khls + ji            ! ends at: ipi - khls + khls = ipi 
     242                        ii2 = ipi - khls + 1 - ji        ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
     243                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     244                     END DO 
     245                  END DO 
     246                  ! 
     247               END DO; END DO 
     248            CASE ( 'U' )                               ! U-point 
     249               DO jl = 1, ipl; DO jk = 1, ipk 
     250                  ! 
     251                  ! last khls lines (from ipj to ipj-khls+1) : full 
     252                    DO jj = 1, khls 
     253                       ij1 = ipj + 1      - jj             ! ends at: ipj + 1 - khls 
     254                     ij2 = ipj - 2*khls + jj             ! ends at: ipj - 2*khls + khls = ipj - khls 
     255                     ! 
     256                     DO ji = 1, khls-1            ! first khls-1 points 
     257                        ii1 =          ji                ! ends at: khls-1 
     258                        ii2 = 2*khls - ji                ! ends at: 2*khls - ( khls - 1 ) = khls + 1 
     259                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     260                     END DO 
     261                     DO ji = 1, 1                 ! point khls 
     262                        ii1 = khls + ji - 1 
     263                        ii2 = ipi - ii1 
     264                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     265                     END DO 
     266                     DO ji = 1, Ni0glo - 1        ! points from khls+1 to ipi - khls - 1  (note: Ni0glo = ipi - 2*khls) 
     267                        ii1 =       khls + ji            ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 
     268                        ii2 = ipi - khls - ji            ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 
     269                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     270                     END DO 
     271                     DO ji = 1, 1                 ! point ipi - khls 
     272                        ii1 = ipi - khls + ji - 1 
    116273                        ii2 = ii1 
    117                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    118                      END DO 
    119                      DO ji = 1, Ni0glo - 1        ! points from nn_hls+2 to jpiglo - nn_hls   (note: Ni0glo = jpiglo - 2*nn_hls) 
    120                         ii1 = 2 + nn_hls      + ji - 1   ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 
    121                         ii2 = jpiglo - nn_hls - ji + 1   ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 
    122                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    123                      END DO 
    124                      DO ji = 1, 1                 ! point jpiglo - nn_hls + 1 
    125                         ii1 = jpiglo - nn_hls + ji 
    126                         ii2 =          nn_hls + ji 
    127                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    128                      END DO 
    129                      DO ji = 1, nn_hls-1          ! last nn_hls-1 points 
    130                         ii1 = jpiglo - nn_hls + 1 + ji   ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 
    131                         ii2 = jpiglo - nn_hls + 1 - ji   ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 
    132                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    133                      END DO 
    134                   END DO 
    135                   ! 
    136                   ! line number ipj-nn_hls : right half 
    137                     DO jj = 1, 1 
    138                      ij1 = ipj - nn_hls 
    139                      ij2 = ij1   ! same line 
    140                      ! 
    141                      DO ji = 1, Ni0glo/2-1        ! points from jpiglo/2+2 to jpiglo - nn_hls   (note: Ni0glo = jpiglo - 2*nn_hls) 
    142                         ii1 = jpiglo/2 + ji + 1          ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls - 1) + 1 = jpiglo - nn_hls 
    143                         ii2 = jpiglo/2 - ji + 1          ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1) + 1 = nn_hls + 2 
    144                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    145                      END DO 
    146                      DO ji = 1, nn_hls            ! first nn_hls points: redo them just in case (if e-w periodocity already done) 
    147                         !                         ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls   
    148                         ii1 =                ji          ! ends at: nn_hls 
    149                         ii2 = 2*nn_hls + 2 - ji          ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 
    150                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    151                      END DO 
    152                      !                            ! last nn_hls-1 points: have been / will done by e-w periodicity  
    153                   END DO 
    154                   ! 
    155                END DO; END DO 
    156             CASE ( 'U' )                               ! U-point 
    157                DO jl = 1, ipl; DO jk = 1, ipk 
    158                   ! 
    159                   ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 
    160                     DO jj = 1, nn_hls 
    161                        ij1 = ipj            - jj + 1       ! ends at: ipj - nn_hls + 1 
    162                      ij2 = ipj - 2*nn_hls + jj - 1       ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 
    163                      ! 
    164                      DO ji = 1, nn_hls            ! first nn_hls points 
    165                         ii1 =                ji          ! ends at: nn_hls 
    166                         ii2 = 2*nn_hls + 1 - ji          ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 
    167                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    168                      END DO 
    169                      DO ji = 1, Ni0glo            ! points from nn_hls to jpiglo - nn_hls   (note: Ni0glo = jpiglo - 2*nn_hls) 
    170                         ii1 = nn_hls          + ji       ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 
    171                         ii2 = jpiglo - nn_hls - ji + 1   ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 
    172                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    173                      END DO 
    174                      DO ji = 1, nn_hls            ! last nn_hls points 
    175                         ii1 = jpiglo - nn_hls + ji       ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 
    176                         ii2 = jpiglo - nn_hls + 1 - ji   ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 
    177                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    178                      END DO 
    179                   END DO 
    180                   ! 
    181                   ! line number ipj-nn_hls : right half 
    182                     DO jj = 1, 1 
    183                      ij1 = ipj - nn_hls 
    184                      ij2 = ij1   ! same line 
    185                      ! 
    186                      DO ji = 1, Ni0glo/2          ! points from jpiglo/2+1 to jpiglo - nn_hls   (note: Ni0glo = jpiglo - 2*nn_hls) 
    187                         ii1 = jpiglo/2 + ji              ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 
    188                         ii2 = jpiglo/2 - ji + 1          ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 
    189                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    190                      END DO 
    191                      DO ji = 1, nn_hls            ! first nn_hls points: redo them just in case (if e-w periodocity already done) 
    192                         !                         ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls   
    193                         ii1 =                ji          ! ends at: nn_hls 
    194                         ii2 = 2*nn_hls + 1 - ji          ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 
    195                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    196                      END DO 
    197                      !                            ! last nn_hls-1 points: have been / will done by e-w periodicity  
     274                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     275                     END DO 
     276                     DO ji = 1, khls              ! last khls points 
     277                        ii1 = ipi - khls + ji            ! ends at: ipi - khls + khls = ipi 
     278                        ii2 = ipi - khls - ji            ! ends at: ipi - khls - khls = ipi - 2*khls 
     279                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     280                     END DO 
    198281                  END DO 
    199282                  ! 
    … …  
    202285               DO jl = 1, ipl; DO jk = 1, ipk 
    203286                  ! 
    204                   ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full 
    205                     DO jj = 1, nn_hls+1 
    206                        ij1 = ipj            - jj + 1       ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls 
    207                      ij2 = ipj - 2*nn_hls + jj - 2       ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1 
    208                      ! 
    209                      DO ji = 1, nn_hls            ! first nn_hls points 
    210                         ii1 =                ji          ! ends at: nn_hls 
    211                         ii2 = 2*nn_hls + 2 - ji          ! ends at: 2*nn_hls + 2 - nn_hls = nn_hls + 2 
    212                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    213                      END DO 
    214                      DO ji = 1, 1                 ! point nn_hls+1 
    215                         ii1 = nn_hls + ji 
     287                  ! last khls lines (from ipj to ipj-khls+1) : full 
     288                    DO jj = 1, khls 
     289                       ij1 = ipj          - jj + 1         ! ends at: ipj - khls + 1 
     290                     ij2 = ipj - 2*khls + jj - 1         ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 
     291                     ! 
     292                     DO ji = 1, khls              ! first khls points 
     293                        ii1 =              ji            ! ends at: khls 
     294                        ii2 = 2*khls + 1 - ji            ! ends at: 2*khls + 1 - khls = khls + 1 
     295                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     296                     END DO 
     297                     DO ji = 1, Ni0glo            ! points from khls to ipi - khls   (note: Ni0glo = ipi - 2*khls) 
     298                        ii1 =       khls + ji          ! ends at: khls + ipi - 2*khls = ipi - khls 
     299                        ii2 = ipi - khls - ji + 1      ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1 
     300                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     301                     END DO 
     302                     DO ji = 1, khls            ! last khls points 
     303                        ii1 = ipi - khls + ji          ! ends at: ipi - khls + khls = ipi 
     304                        ii2 = ipi - khls + 1 - ji      ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1 
     305                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     306                     END DO 
     307                  END DO    
     308                  ! 
     309                  ! line number ipj-khls : right half 
     310                    DO jj = 1, 1 
     311                     ij1 = ipj - khls 
     312                     ij2 = ij1   ! same line 
     313                     ! 
     314                     DO ji = 1, Ni0glo/2          ! points from ipi/2+1 to ipi - khls   (note: Ni0glo = ipi - 2*khls) 
     315                        ii1 = ipi/2 + ji                 ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls 
     316                        ii2 = ipi/2 - ji + 1             ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1 
     317                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     318                     END DO 
     319                     DO ji = 1, khls              ! first khls points: redo them just in case (if e-w periodocity already done) 
     320                        !                         ! as we just changed points ipi-2khls+1 to ipi-khls   
     321                        ii1 =              ji            ! ends at: khls 
     322                        ii2 = 2*khls + 1 - ji            ! ends at: 2*khls + 1 - khls = khls + 1 
     323                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     324                     END DO 
     325                     !                            ! last khls points: have been / will done by e-w periodicity  
     326                  END DO 
     327                  ! 
     328               END DO; END DO 
     329            CASE ( 'F' )                               ! F-point 
     330               DO jl = 1, ipl; DO jk = 1, ipk 
     331                  ! 
     332                  ! last khls lines (from ipj to ipj-khls+1) : full 
     333                    DO jj = 1, khls 
     334                       ij1 = ipj          - jj + 1         ! ends at: ipj - khls + 1 
     335                     ij2 = ipj - 2*khls + jj - 1         ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1 
     336                     ! 
     337                     DO ji = 1, khls-1            ! first khls-1 points 
     338                        ii1 =          ji                ! ends at: khls-1 
     339                        ii2 = 2*khls - ji                ! ends at: 2*khls - ( khls - 1 ) = khls + 1 
     340                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     341                     END DO 
     342                     DO ji = 1, 1                 ! point khls 
     343                        ii1 = khls + ji - 1 
     344                        ii2 = ipi - ii1 
     345                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     346                     END DO 
     347                     DO ji = 1, Ni0glo - 1        ! points from khls+1 to ipi - khls - 1  (note: Ni0glo = ipi - 2*khls) 
     348                        ii1 =       khls + ji            ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1 
     349                        ii2 = ipi - khls - ji            ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1 
     350                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     351                     END DO 
     352                     DO ji = 1, 1                 ! point ipi - khls 
     353                        ii1 = ipi - khls + ji - 1 
    216354                        ii2 = ii1 
    217                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    218                      END DO 
    219                      DO ji = 1, Ni0glo - 1        ! points from nn_hls+2 to jpiglo - nn_hls   (note: Ni0glo = jpiglo - 2*nn_hls) 
    220                         ii1 = 2 + nn_hls      + ji - 1   ! ends at: 2 + nn_hls + jpiglo - 2*nn_hls - 1 - 1 = jpiglo - nn_hls 
    221                         ii2 = jpiglo - nn_hls - ji + 1   ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) + 1 = nn_hls + 2 
    222                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    223                      END DO 
    224                      DO ji = 1, 1                 ! point jpiglo - nn_hls + 1 
    225                         ii1 = jpiglo - nn_hls + ji 
    226                         ii2 =          nn_hls + ji 
    227                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    228                      END DO 
    229                      DO ji = 1, nn_hls-1          ! last nn_hls-1 points 
    230                         ii1 = jpiglo - nn_hls + 1 + ji   ! ends at: jpiglo - nn_hls + 1 + nn_hls - 1 = jpiglo 
    231                         ii2 = jpiglo - nn_hls + 1 - ji   ! ends at: jpiglo - nn_hls + 1 - nn_hls + 1 = jpiglo - 2*nn_hls + 2 
    232                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    233                      END DO 
    234                   END DO 
    235                   ! 
    236                END DO; END DO 
    237             CASE ( 'F' )                               ! F-point 
    238                DO jl = 1, ipl; DO jk = 1, ipk 
    239                   ! 
    240                   ! last nn_hls+1 lines (from ipj to ipj-nn_hls) : full 
    241                     DO jj = 1, nn_hls+1 
    242                        ij1 = ipj            - jj + 1       ! ends at: ipj - ( nn_hls + 1 ) + 1 = ipj - nn_hls 
    243                      ij2 = ipj - 2*nn_hls + jj - 2       ! ends at: ipj - 2*nn_hls + nn_hls + 1 - 2 = ipj - nn_hls - 1 
    244                      ! 
    245                      DO ji = 1, nn_hls            ! first nn_hls points 
    246                         ii1 =                ji          ! ends at: nn_hls 
    247                         ii2 = 2*nn_hls + 1 - ji          ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 
    248                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    249                      END DO 
    250                      DO ji = 1, Ni0glo            ! points from nn_hls to jpiglo - nn_hls   (note: Ni0glo = jpiglo - 2*nn_hls) 
    251                         ii1 = nn_hls          + ji       ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 
    252                         ii2 = jpiglo - nn_hls - ji + 1   ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 
    253                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    254                      END DO 
    255                      DO ji = 1, nn_hls            ! last nn_hls points 
    256                         ii1 = jpiglo - nn_hls + ji       ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 
    257                         ii2 = jpiglo - nn_hls + 1 - ji   ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 
    258                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    259                      END DO 
    260                   END DO 
    261                   ! 
    262                END DO; END DO 
    263             END SELECT   ! NAT_IN(jf) 
     355                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     356                     END DO 
     357                     DO ji = 1, khls              ! last khls points 
     358                        ii1 = ipi - khls + ji            ! ends at: ipi - khls + khls = ipi 
     359                        ii2 = ipi - khls - ji            ! ends at: ipi - khls - khls = ipi - 2*khls 
     360                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     361                     END DO 
     362                  END DO    
     363                  ! 
     364                  ! line number ipj-khls : right half 
     365                    DO jj = 1, 1 
     366                     ij1 = ipj - khls 
     367                     ij2 = ij1   ! same line 
     368                     ! 
     369                     DO ji = 1, Ni0glo/2-1        ! points from ipi/2+1 to ipi - khls-1  (note: Ni0glo = ipi - 2*khls) 
     370                        ii1 = ipi/2 + ji                 ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls 
     371                        ii2 = ipi/2 - ji                 ! ends at: ipi/2 - (ipi/2 - khls - 1 ) = khls + 1 
     372                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     373                     END DO 
     374                     DO ji = 1, khls-1            ! first khls-1 points: redo them just in case (if e-w periodocity already done) 
     375                        !                         ! as we just changed points ipi-2khls+1 to ipi-nn_hl-1   
     376                        ii1 =          ji                ! ends at: khls 
     377                        ii2 = 2*khls - ji                ! ends at: 2*khls - ( khls - 1 ) = khls + 1 
     378                        ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl) 
     379                     END DO 
     380                     !                            ! last khls points: have been / will done by e-w periodicity  
     381                  END DO 
     382                  ! 
     383               END DO; END DO 
     384            END SELECT   ! cd_nat(jf) 
    264385            ! 
    265          CASE ( 5 , 6 )                        ! *  North fold  F-point pivot 
    266             ! 
    267             SELECT CASE ( NAT_IN(jf)  ) 
    268             CASE ( 'T' , 'W' )                         ! T-, W-point 
    269                DO jl = 1, ipl; DO jk = 1, ipk 
    270                   ! 
    271                   ! first: line number ipj-nn_hls : 3 points 
    272                     DO jj = 1, 1 
    273                      ij1 = ipj - nn_hls 
    274                      ij2 = ij1   ! same line 
    275                      ! 
    276                      DO ji = 1, 1            ! points from jpiglo/2+1 
    277                         ii1 = jpiglo/2 + ji 
    278                         ii2 = jpiglo/2 - ji + 1 
    279                         ARRAY_IN(ii1,ij1,jk,jl,jf) =              ARRAY_IN(ii2,ij2,jk,jl,jf)   ! Warning: pb with sign... 
    280                      END DO 
    281                      DO ji = 1, 1            ! points jpiglo - nn_hls 
    282                         ii1 = jpiglo - nn_hls + ji - 1 
    283                         ii2 =          nn_hls + ji 
    284                         ARRAY_IN(ii1,ij1,jk,jl,jf) =              ARRAY_IN(ii2,ij2,jk,jl,jf)   ! Warning: pb with sign... 
    285                      END DO 
    286                      DO ji = 1, 1            ! point nn_hls: redo it just in case (if e-w periodocity already done) 
    287                         !                    ! as we just changed point jpiglo - nn_hls 
    288                         ii1 = nn_hls + ji - 1 
    289                         ii2 = nn_hls + ji 
    290                         ARRAY_IN(ii1,ij1,jk,jl,jf) =              ARRAY_IN(ii2,ij2,jk,jl,jf)   ! Warning: pb with sign... 
    291                      END DO 
    292                   END DO 
    293                   ! 
    294                   ! Second: last nn_hls lines (from ipj to ipj-nn_hls+1) : full 
    295                     DO jj = 1, nn_hls 
    296                        ij1 = ipj + 1        - jj           ! ends at: ipj + 1 - nn_hls 
    297                      ij2 = ipj - 2*nn_hls + jj           ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls 
    298                      ! 
    299                      DO ji = 1, nn_hls            ! first nn_hls points 
    300                         ii1 =                ji          ! ends at: nn_hls 
    301                         ii2 = 2*nn_hls + 1 - ji          ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 
    302                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    303                      END DO 
    304                      DO ji = 1, Ni0glo            ! points from nn_hls to jpiglo - nn_hls   (note: Ni0glo = jpiglo - 2*nn_hls) 
    305                         ii1 = nn_hls          + ji       ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 
    306                         ii2 = jpiglo - nn_hls - ji + 1   ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 
    307                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    308                      END DO 
    309                      DO ji = 1, nn_hls            ! last nn_hls points 
    310                         ii1 = jpiglo - nn_hls + ji       ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 
    311                         ii2 = jpiglo - nn_hls + 1 - ji   ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 
    312                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    313                      END DO 
    314                   END DO 
    315                   ! 
    316                END DO; END DO 
    317             CASE ( 'U' )                               ! U-point 
    318                DO jl = 1, ipl; DO jk = 1, ipk 
    319                   ! 
    320                   ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 
    321                     DO jj = 1, nn_hls 
    322                        ij1 = ipj + 1        - jj           ! ends at: ipj + 1 - nn_hls 
    323                      ij2 = ipj - 2*nn_hls + jj           ! ends at: ipj - 2*nn_hls + nn_hls = ipj - nn_hls 
    324                      ! 
    325                      DO ji = 1, nn_hls-1          ! first nn_hls-1 points 
    326                         ii1 =            ji              ! ends at: nn_hls-1 
    327                         ii2 = 2*nn_hls - ji              ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 
    328                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    329                      END DO 
    330                      DO ji = 1, 1                 ! point nn_hls 
    331                         ii1 = nn_hls + ji - 1 
    332                         ii2 = jpiglo - ii1 
    333                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    334                      END DO 
    335                      DO ji = 1, Ni0glo - 1        ! points from nn_hls+1 to jpiglo - nn_hls - 1  (note: Ni0glo = jpiglo - 2*nn_hls) 
    336                         ii1 =          nn_hls + ji       ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 
    337                         ii2 = jpiglo - nn_hls - ji       ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 
    338                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    339                      END DO 
    340                      DO ji = 1, 1                 ! point jpiglo - nn_hls 
    341                         ii1 = jpiglo - nn_hls + ji - 1 
    342                         ii2 = ii1 
    343                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    344                      END DO 
    345                      DO ji = 1, nn_hls            ! last nn_hls points 
    346                         ii1 = jpiglo - nn_hls + ji       ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 
    347                         ii2 = jpiglo - nn_hls - ji       ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 
    348                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    349                      END DO 
    350                   END DO 
    351                   ! 
    352                END DO; END DO 
    353             CASE ( 'V' )                               ! V-point 
    354                DO jl = 1, ipl; DO jk = 1, ipk 
    355                   ! 
    356                   ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 
    357                     DO jj = 1, nn_hls 
    358                        ij1 = ipj            - jj + 1       ! ends at: ipj - nn_hls + 1 
    359                      ij2 = ipj - 2*nn_hls + jj - 1       ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 
    360                      ! 
    361                      DO ji = 1, nn_hls            ! first nn_hls points 
    362                         ii1 =                ji          ! ends at: nn_hls 
    363                         ii2 = 2*nn_hls + 1 - ji          ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 
    364                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    365                      END DO 
    366                      DO ji = 1, Ni0glo            ! points from nn_hls to jpiglo - nn_hls   (note: Ni0glo = jpiglo - 2*nn_hls) 
    367                         ii1 = nn_hls          + ji       ! ends at: nn_hls + jpiglo - 2*nn_hls = jpiglo - nn_hls 
    368                         ii2 = jpiglo - nn_hls - ji + 1   ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls ) + 1 = nn_hls + 1 
    369                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    370                      END DO 
    371                      DO ji = 1, nn_hls            ! last nn_hls points 
    372                         ii1 = jpiglo - nn_hls + ji       ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 
    373                         ii2 = jpiglo - nn_hls + 1 - ji   ! ends at: jpiglo - nn_hls + 1 - nn_hls = jpiglo - 2*nn_hls + 1 
    374                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    375                      END DO 
    376                   END DO    
    377                   ! 
    378                   ! line number ipj-nn_hls : right half 
    379                     DO jj = 1, 1 
    380                      ij1 = ipj - nn_hls 
    381                      ij2 = ij1   ! same line 
    382                      ! 
    383                      DO ji = 1, Ni0glo/2          ! points from jpiglo/2+1 to jpiglo - nn_hls   (note: Ni0glo = jpiglo - 2*nn_hls) 
    384                         ii1 = jpiglo/2 + ji              ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 
    385                         ii2 = jpiglo/2 - ji + 1          ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls) + 1 = nn_hls + 1 
    386                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    387                      END DO 
    388                      DO ji = 1, nn_hls            ! first nn_hls points: redo them just in case (if e-w periodocity already done) 
    389                         !                         ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hls   
    390                         ii1 =                ji          ! ends at: nn_hls 
    391                         ii2 = 2*nn_hls + 1 - ji          ! ends at: 2*nn_hls + 1 - nn_hls = nn_hls + 1 
    392                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    393                      END DO 
    394                      !                            ! last nn_hls points: have been / will done by e-w periodicity  
    395                   END DO 
    396                   ! 
    397                END DO; END DO 
    398             CASE ( 'F' )                               ! F-point 
    399                DO jl = 1, ipl; DO jk = 1, ipk 
    400                   ! 
    401                   ! last nn_hls lines (from ipj to ipj-nn_hls+1) : full 
    402                     DO jj = 1, nn_hls 
    403                        ij1 = ipj            - jj + 1       ! ends at: ipj - nn_hls + 1 
    404                      ij2 = ipj - 2*nn_hls + jj - 1       ! ends at: ipj - 2*nn_hls + nn_hls - 1 = ipj - nn_hls - 1 
    405                      ! 
    406                      DO ji = 1, nn_hls-1          ! first nn_hls-1 points 
    407                         ii1 =            ji              ! ends at: nn_hls-1 
    408                         ii2 = 2*nn_hls - ji              ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 
    409                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    410                      END DO 
    411                      DO ji = 1, 1                 ! point nn_hls 
    412                         ii1 = nn_hls + ji - 1 
    413                         ii2 = jpiglo - ii1 
    414                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    415                      END DO 
    416                      DO ji = 1, Ni0glo - 1        ! points from nn_hls+1 to jpiglo - nn_hls - 1  (note: Ni0glo = jpiglo - 2*nn_hls) 
    417                         ii1 =          nn_hls + ji       ! ends at: nn_hls + ( jpiglo - 2*nn_hls - 1 ) = jpiglo - nn_hls - 1 
    418                         ii2 = jpiglo - nn_hls - ji       ! ends at: jpiglo - nn_hls - ( jpiglo - 2*nn_hls - 1 ) = nn_hls + 1 
    419                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    420                      END DO 
    421                      DO ji = 1, 1                 ! point jpiglo - nn_hls 
    422                         ii1 = jpiglo - nn_hls + ji - 1 
    423                         ii2 = ii1 
    424                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    425                      END DO 
    426                      DO ji = 1, nn_hls            ! last nn_hls points 
    427                         ii1 = jpiglo - nn_hls + ji       ! ends at: jpiglo - nn_hls + nn_hls = jpiglo 
    428                         ii2 = jpiglo - nn_hls - ji       ! ends at: jpiglo - nn_hls - nn_hls = jpiglo - 2*nn_hls 
    429                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    430                      END DO 
    431                   END DO    
    432                   ! 
    433                   ! line number ipj-nn_hls : right half 
    434                     DO jj = 1, 1 
    435                      ij1 = ipj - nn_hls 
    436                      ij2 = ij1   ! same line 
    437                      ! 
    438                      DO ji = 1, Ni0glo/2-1        ! points from jpiglo/2+1 to jpiglo - nn_hls-1  (note: Ni0glo = jpiglo - 2*nn_hls) 
    439                         ii1 = jpiglo/2 + ji              ! ends at: jpiglo/2 + (jpiglo/2 - nn_hls) = jpiglo - nn_hls 
    440                         ii2 = jpiglo/2 - ji              ! ends at: jpiglo/2 - (jpiglo/2 - nn_hls - 1 ) = nn_hls + 1 
    441                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    442                      END DO 
    443                      DO ji = 1, nn_hls-1          ! first nn_hls-1 points: redo them just in case (if e-w periodocity already done) 
    444                         !                         ! as we just changed points jpiglo-2nn_hls+1 to jpiglo-nn_hl-1   
    445                         ii1 =            ji              ! ends at: nn_hls 
    446                         ii2 = 2*nn_hls - ji              ! ends at: 2*nn_hls - ( nn_hls - 1 ) = nn_hls + 1 
    447                         ARRAY_IN(ii1,ij1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii2,ij2,jk,jl,jf) 
    448                      END DO 
    449                      !                            ! last nn_hls points: have been / will done by e-w periodicity  
    450                   END DO 
    451                   ! 
    452                END DO; END DO 
    453             END SELECT   ! NAT_IN(jf) 
    454             ! 
    455          END SELECT   ! npolj 
     386         ENDIF   ! c_NFtype == 'F' 
    456387         ! 
    457388      END DO   ! ipf 
    458389      ! 
    459    END SUBROUTINE ROUTINE_NFD 
     390   END SUBROUTINE lbc_nfd_/**/PRECISION 
    460391 
    461 #undef PRECISION 
    462 #undef ARRAY_TYPE 
    463 #undef ARRAY_IN 
    464 #undef NAT_IN 
    465 #undef SGN_IN 
    466 #undef J_SIZE 
    467 #undef K_SIZE 
    468 #undef L_SIZE 
    469 #undef F_SIZE 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r13286 r14574  
    1 #if defined MULTI 
    2 #   define NAT_IN(k)                cd_nat(k)    
    3 #   define SGN_IN(k)                psgn(k) 
    4 #   define F_SIZE(ptab)             kfld 
    5 #   if defined DIM_2d 
    6 #      if defined SINGLE_PRECISION 
    7 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp),INTENT(inout)::ptab(f) 
    8 #      else 
    9 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp),INTENT(inout)::ptab(f) 
    10 #      endif  
    11 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    12 #      define K_SIZE(ptab)             1 
    13 #      define L_SIZE(ptab)             1 
    14 #   endif 
    15 #   if defined DIM_3d 
    16 #      if defined SINGLE_PRECISION 
    17 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp),INTENT(inout)::ptab(f) 
    18 #      else 
    19 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp),INTENT(inout)::ptab(f) 
    20 #      endif  
    21 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    22 #      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    23 #      define L_SIZE(ptab)             1 
    24 #   endif 
    25 #   if defined DIM_4d 
    26 #      if defined SINGLE_PRECISION 
    27 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp),INTENT(inout)::ptab(f) 
    28 #      else 
    29 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp),INTENT(inout)::ptab(f) 
    30 #      endif  
    31 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    32 #      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    33 #      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4) 
    34 #   endif 
    35 #   if defined SINGLE_PRECISION 
    36 #      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f) 
    37 #   else 
    38 #      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f) 
    39 #   endif 
    40 #   define J_SIZE(ptab2)            SIZE(ptab2(1)%pt4d,2) 
    41 #   define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt4d(i,j,k,l) 
    42 #else 
    43 !                          !==  IN: ptab is an array  ==! 
    44 #   define NAT_IN(k)                cd_nat 
    45 #   define SGN_IN(k)                psgn 
    46 #   define F_SIZE(ptab)             1 
    47 #   if defined DIM_2d 
    48 #      define ARRAY_IN(i,j,k,l,f)   ptab(i,j) 
    49 #      define K_SIZE(ptab)          1 
    50 #      define L_SIZE(ptab)          1 
    51 #   endif 
    52 #   if defined DIM_3d 
    53 #      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k) 
    54 #      define K_SIZE(ptab)          SIZE(ptab,3) 
    55 #      define L_SIZE(ptab)          1 
    56 #   endif 
    57 #   if defined DIM_4d 
    58 #      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l) 
    59 #      define K_SIZE(ptab)          SIZE(ptab,3) 
    60 #      define L_SIZE(ptab)          SIZE(ptab,4) 
    61 #   endif 
    62 #   define J_SIZE(ptab2)             SIZE(ptab2,2) 
    63 #   define ARRAY2_IN(i,j,k,l,f)   ptab2(i,j,k,l) 
    64 #   if defined SINGLE_PRECISION 
    65 #      define ARRAY_TYPE(i,j,k,l,f)     REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
    66 #      define ARRAY2_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 
    67 #   else 
    68 #      define ARRAY_TYPE(i,j,k,l,f)     REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) 
    69 #      define ARRAY2_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) 
    70 #   endif 
    71 #   endif 
    72 #   ifdef SINGLE_PRECISION 
    73 #      define PRECISION sp 
    74 #   else 
    75 #      define PRECISION dp 
    76 #   endif 
    77    SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld ) 
     1 
     2   SUBROUTINE lbc_nfd_nogather_/**/PRECISION( ptab, ptab2, cd_nat, psgn, khls ) 
    783      !!---------------------------------------------------------------------- 
    794      !! 
    … …  
    827      !! 
    838      !!---------------------------------------------------------------------- 
    84       ARRAY_TYPE(:,:,:,:,:) 
    85       ARRAY2_TYPE(:,:,:,:,:)  
    86       CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    87       REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
    88       INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    89       ! 
    90       INTEGER  ::    ji,  jj,   jk, jn, ii,   jl,   jh,  jf   ! dummy loop indices 
    91       INTEGER  ::   ipi, ipj,  ipk,    ipl,  ipf, iij, ijj   ! dimension of the input array 
     9      REAL(PRECISION),  DIMENSION(:,:,:,:), INTENT(inout) ::   ptab        !  
     10      REAL(PRECISION),  DIMENSION(:,:,:,:), INTENT(inout) ::   ptab2       !  
     11      CHARACTER(len=1)                    , INTENT(in   ) ::   cd_nat      ! nature of array grid-points 
     12      REAL(PRECISION)                     , INTENT(in   ) ::   psgn        ! sign used across the north fold boundary 
     13      INTEGER                             , INTENT(in   ) ::   khls        ! halo size, default = nn_hls 
     14      ! 
     15      INTEGER  ::    ji,  jj, jk,  jn,  jl, jh       ! dummy loop indices 
     16      INTEGER  ::   ipk, ipl, ii, iij, ijj      ! dimension of the input array 
    9217      INTEGER  ::   ijt, iju, ijta, ijua, jia, startloop, endloop 
    9318      LOGICAL  ::   l_fast_exchanges 
    9419      !!---------------------------------------------------------------------- 
    95       ipj = J_SIZE(ptab2)  ! 2nd dimension of input array 
    96       ipk = K_SIZE(ptab)   ! 3rd dimension of output array 
    97       ipl = L_SIZE(ptab)   ! 4th    - 
    98       ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
    99       ! 
    100       ! Security check for further developments 
    101       IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) 
     20      ipk = SIZE(ptab,3) 
     21      ipl = SIZE(ptab,4) 
     22      ! 
    10223      ! 2nd dimension determines exchange speed 
    103       IF (ipj == 1 ) THEN 
    104         l_fast_exchanges = .TRUE. 
    105       ELSE 
    106         l_fast_exchanges = .FALSE. 
    107       ENDIF 
    108       ! 
    109       DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
     24      l_fast_exchanges = SIZE(ptab2,2) == 1 
     25      ! 
     26      IF( c_NFtype == 'T' ) THEN          ! *  North fold  T-point pivot 
    11027         ! 
    111          SELECT CASE ( npolj ) 
    112          ! 
    113          CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    114             ! 
    115             SELECT CASE ( NAT_IN(jf) ) 
    116             ! 
    117             CASE ( 'T' , 'W' )                         ! T-, W-point 
    118                IF ( nimpp /= 1 ) THEN  ;  startloop = 1  
    119                ELSE                    ;  startloop = 1 + nn_hls 
    120                ENDIF 
    121                ! 
    122                DO jl = 1, ipl; DO jk = 1, ipk 
    123                     DO jj = 1, nn_hls 
    124                        ijj = jpj -jj +1 
     28         SELECT CASE ( cd_nat ) 
     29            ! 
     30         CASE ( 'T' , 'W' )                         ! T-, W-point 
     31            IF ( nimpp /= 1 ) THEN  ;  startloop = 1  
     32            ELSE                    ;  startloop = 1 + khls 
     33            ENDIF 
     34            ! 
     35            DO jl = 1, ipl; DO jk = 1, ipk 
     36               DO jj = 1, khls 
     37                  ijj = jpj -jj +1 
     38                  DO ji = startloop, jpi 
     39                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
     40                     ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 
     41                  END DO 
     42               END DO 
     43            END DO; END DO 
     44            IF( nimpp == 1 ) THEN 
     45               DO jl = 1, ipl; DO jk = 1, ipk 
     46                  DO jj = 1, khls 
     47                     ijj = jpj -jj +1 
     48                     DO ii = 0, khls-1 
     49                        ptab(ii+1,ijj,jk,jl) = psgn * ptab(2*khls-ii+1,jpj-2*khls+jj-1,jk,jl) 
     50                     END DO 
     51                  END DO 
     52               END DO; END DO 
     53            ENDIF 
     54            ! 
     55            IF ( .NOT. l_fast_exchanges ) THEN 
     56               IF( nimpp >= Ni0glo/2+2 ) THEN 
     57                  startloop = 1 
     58               ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 
     59                  startloop = Ni0glo/2+2 - nimpp + khls 
     60               ELSE 
     61                  startloop = jpi + 1 
     62               ENDIF 
     63               IF( startloop <= jpi ) THEN 
     64                  DO jl = 1, ipl; DO jk = 1, ipk 
    12565                     DO ji = startloop, jpi 
    126                      ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
    127                         ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
    128                      END DO 
    129                   END DO 
    130                END DO; END DO 
    131                IF( nimpp == 1 ) THEN 
    132                   DO jl = 1, ipl; DO jk = 1, ipk 
    133                      DO jj = 1, nn_hls 
    134                      ijj = jpj -jj +1 
    135                      DO ii = 0, nn_hls-1 
    136                         ARRAY_IN(ii+1,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,jk,jl,jf) 
    137                      END DO 
     66                        ijt  = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
     67                        jia  = ji + nimpp - 1 
     68                        ijta = jpiglo - jia + 2 
     69                        IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
     70                           ptab(ji,jpj-khls,jk,jl) = psgn * ptab(ijta-nimpp+khls,jpj-khls,jk,jl) 
     71                        ELSE 
     72                           ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(ijt,khls+1,jk,jl) 
     73                        ENDIF 
    13874                     END DO 
    13975                  END DO; END DO 
    140                ENDIF               
    141                ! 
    142                IF ( .NOT. l_fast_exchanges ) THEN 
    143                   IF( nimpp >= Ni0glo/2+2 ) THEN 
    144                      startloop = 1 
    145                   ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 
    146                      startloop = Ni0glo/2+2 - nimpp + nn_hls 
    147                   ELSE 
    148                      startloop = jpi + 1 
    149                   ENDIF 
    150                   IF( startloop <= jpi ) THEN 
    151                      DO jl = 1, ipl; DO jk = 1, ipk 
    152                         DO ji = startloop, jpi 
    153                            ijt  = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
    154                            jia  = ji + nimpp - 1 
    155                            ijta = jpiglo - jia + 2 
    156                            IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN 
    157                               ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl,jf) 
    158                            ELSE 
    159                               ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 
    160                            ENDIF 
    161                         END DO 
    162                      END DO; END DO 
    163                   ENDIF 
    164                ENDIF 
    165             CASE ( 'U' )                                     ! U-point 
     76               ENDIF 
     77            ENDIF 
     78         CASE ( 'U' )                                     ! U-point 
     79            IF( nimpp + jpi - 1 /= jpiglo ) THEN 
     80               endloop = jpi 
     81            ELSE 
     82               endloop = jpi - khls 
     83            ENDIF 
     84            DO jl = 1, ipl; DO jk = 1, ipk 
     85               DO jj = 1, khls 
     86                  ijj = jpj -jj +1 
     87                  DO ji = 1, endloop 
     88                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
     89                     ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 
     90                  END DO 
     91               END DO 
     92            END DO; END DO 
     93            IF (nimpp .eq. 1) THEN 
     94               DO jj = 1, khls 
     95                  ijj = jpj -jj +1 
     96                  DO ii = 0, khls-1 
     97                     ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls+jj-1,:,:) 
     98                  END DO 
     99               END DO 
     100            ENDIF 
     101            IF((nimpp + jpi - 1) .eq. jpiglo) THEN 
     102               DO jj = 1, khls 
     103                  ijj = jpj -jj +1 
     104                  DO ii = 1, khls 
     105                     ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls+jj-1,:,:) 
     106                  END DO 
     107               END DO 
     108            ENDIF 
     109            ! 
     110            IF ( .NOT. l_fast_exchanges ) THEN 
    166111               IF( nimpp + jpi - 1 /= jpiglo ) THEN 
    167112                  endloop = jpi 
    168113               ELSE 
    169                   endloop = jpi - nn_hls 
    170                ENDIF 
    171                DO jl = 1, ipl; DO jk = 1, ipk 
    172         DO jj = 1, nn_hls 
    173               ijj = jpj -jj +1 
    174                      DO ji = 1, endloop 
    175                         iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    176                         ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 
    177                      END DO 
    178                   END DO 
    179                END DO; END DO 
    180                IF (nimpp .eq. 1) THEN 
    181         DO jj = 1, nn_hls 
    182            ijj = jpj -jj +1 
    183            DO ii = 0, nn_hls-1 
    184          ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 
    185            END DO 
    186                   END DO 
    187                ENDIF 
    188                IF((nimpp + jpi - 1) .eq. jpiglo) THEN 
    189                   DO jj = 1, nn_hls 
    190                        ijj = jpj -jj +1 
    191          DO ii = 1, nn_hls 
    192                ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 
    193          END DO 
    194         END DO 
    195                ENDIF 
    196                ! 
    197                IF ( .NOT. l_fast_exchanges ) THEN 
    198                   IF( nimpp + jpi - 1 /= jpiglo ) THEN 
    199                      endloop = jpi 
    200                   ELSE 
    201                      endloop = jpi - nn_hls 
    202                   ENDIF 
    203                   IF( nimpp >= Ni0glo/2+1 ) THEN 
    204                      startloop = nn_hls 
    205                   ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN 
    206                      startloop = Ni0glo/2+1 - nimpp + nn_hls  
    207                   ELSE 
    208                      startloop = endloop + 1 
    209                   ENDIF 
    210                   IF( startloop <= endloop ) THEN 
     114                  endloop = jpi - khls 
     115               ENDIF 
     116               IF( nimpp >= Ni0glo/2+1 ) THEN 
     117                  startloop = khls 
     118               ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN 
     119                  startloop = Ni0glo/2+1 - nimpp + khls  
     120               ELSE 
     121                  startloop = endloop + 1 
     122               ENDIF 
     123               IF( startloop <= endloop ) THEN 
    211124                  DO jl = 1, ipl; DO jk = 1, ipk 
    212125                     DO ji = startloop, endloop 
    … …  
    215128                        ijua = jpiglo - jia + 1  
    216129                        IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN 
    217                            ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl,jf) 
     130                           ptab(ji,jpj-khls,jk,jl) = psgn * ptab(ijua-nimpp+1,jpj-khls,jk,jl) 
    218131                        ELSE 
    219                            ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 
     132                           ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(iju,khls+1,jk,jl) 
    220133                        ENDIF 
    221134                     END DO 
    222135                  END DO; END DO 
    223                   ENDIF 
    224                ENDIF 
    225                ! 
    226             CASE ( 'V' )                                     ! V-point 
    227                IF( nimpp /= 1 ) THEN 
    228                  startloop = 1  
    229                ELSE 
    230                  startloop = 1 + nn_hls 
    231                ENDIF 
     136               ENDIF 
     137            ENDIF 
     138            ! 
     139         CASE ( 'V' )                                     ! V-point 
     140            IF( nimpp /= 1 ) THEN 
     141               startloop = 1  
     142            ELSE 
     143               startloop = 1 + khls 
     144            ENDIF 
     145            IF ( .NOT. l_fast_exchanges ) THEN 
     146               DO jl = 1, ipl; DO jk = 1, ipk 
     147                  DO jj = 2, khls+1 
     148                     ijj = jpj -jj +1 
     149                     DO ji = startloop, jpi 
     150                        ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
     151                        ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 
     152                     END DO 
     153                  END DO 
     154               END DO; END DO 
     155            ENDIF 
     156            DO jl = 1, ipl; DO jk = 1, ipk 
     157               DO ji = startloop, jpi 
     158                  ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
     159                  ptab(ji,jpj,jk,jl) = psgn * ptab2(ijt,1,jk,jl) 
     160               END DO 
     161            END DO; END DO 
     162            IF (nimpp .eq. 1) THEN 
     163               DO jj = 1, khls 
     164                  ijj = jpj-jj+1 
     165                  DO ii = 0, khls-1 
     166                     ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii+1,jpj-2*khls+jj-1,:,:) 
     167                  END DO 
     168               END DO 
     169            ENDIF 
     170         CASE ( 'F' )                                     ! F-point 
     171            IF( nimpp + jpi - 1 /= jpiglo ) THEN 
     172               endloop = jpi 
     173            ELSE 
     174               endloop = jpi - khls 
     175            ENDIF 
     176            IF ( .NOT. l_fast_exchanges ) THEN 
     177               DO jl = 1, ipl; DO jk = 1, ipk 
     178                  DO jj = 2, khls+1 
     179                     ijj = jpj -jj +1 
     180                     DO ji = 1, endloop 
     181                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
     182                        ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 
     183                     END DO 
     184                  END DO 
     185               END DO; END DO 
     186            ENDIF 
     187            DO jl = 1, ipl; DO jk = 1, ipk 
     188               DO ji = 1, endloop 
     189                  iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
     190                  ptab(ji,jpj,jk,jl) = psgn * ptab2(iju,1,jk,jl) 
     191               END DO 
     192            END DO; END DO 
     193            IF (nimpp .eq. 1) THEN                
     194               DO ii = 1, khls 
     195                  ptab(ii,jpj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls-1,:,:) 
     196               END DO 
    232197               IF ( .NOT. l_fast_exchanges ) THEN 
     198                  DO jj = 1, khls 
     199                     ijj = jpj -jj 
     200                     DO ii = 0, khls-1 
     201                        ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls+jj-1,:,:) 
     202                     END DO 
     203                  END DO 
     204               ENDIF 
     205            ENDIF 
     206            IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 
     207               DO ii = 1, khls 
     208                  ptab(jpi-ii+1,jpj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls-1,:,:) 
     209               END DO 
     210               IF ( .NOT. l_fast_exchanges ) THEN 
     211                  DO jj = 1, khls 
     212                     ijj = jpj -jj 
     213                     DO ii = 1, khls 
     214                        ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls+jj-1,:,:) 
     215                     END DO 
     216                  END DO 
     217               ENDIF 
     218            ENDIF 
     219            ! 
     220         END SELECT 
     221         ! 
     222      ENDIF   ! c_NFtype == 'T' 
     223      ! 
     224      IF( c_NFtype == 'F' ) THEN           ! *  North fold  F-point pivot 
     225         ! 
     226         SELECT CASE ( cd_nat ) 
     227         CASE ( 'T' , 'W' )                               ! T-, W-point 
     228            DO jl = 1, ipl; DO jk = 1, ipk 
     229               DO jj = 1, khls 
     230                  ijj = jpj-jj+1 
     231                  DO ji = 1, jpi 
     232                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
     233                     ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 
     234                  END DO 
     235               END DO 
     236            END DO; END DO 
     237            ! 
     238         CASE ( 'U' )                                     ! U-point 
     239            IF( nimpp + jpi - 1 /= jpiglo ) THEN 
     240               endloop = jpi 
     241            ELSE 
     242               endloop = jpi - khls 
     243            ENDIF 
     244            DO jl = 1, ipl; DO jk = 1, ipk 
     245               DO jj = 1, khls 
     246                  ijj = jpj-jj+1 
     247                  DO ji = 1, endloop 
     248                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 
     249                     ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 
     250                  END DO 
     251               END DO 
     252            END DO; END DO 
     253            IF(nimpp + jpi - 1 .eq. jpiglo) THEN 
     254               DO jl = 1, ipl; DO jk = 1, ipk 
     255                  DO jj = 1, khls 
     256                     ijj = jpj-jj+1 
     257                     DO ii = 1, khls 
     258                        iij = jpi-ii+1 
     259                        ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*khls+ii-1,jpj-2*khls+jj,jk,jl) 
     260                     END DO 
     261                  END DO 
     262               END DO; END DO 
     263            ENDIF 
     264            ! 
     265         CASE ( 'V' )                                     ! V-point 
     266            DO jl = 1, ipl; DO jk = 1, ipk 
     267               DO jj = 1, khls 
     268                  ijj = jpj -jj +1 
     269                  DO ji = 1, jpi 
     270                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
     271                     ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl) 
     272                  END DO 
     273               END DO 
     274            END DO; END DO 
     275 
     276            IF ( .NOT. l_fast_exchanges ) THEN 
     277               IF( nimpp >= Ni0glo/2+2 ) THEN 
     278                  startloop = 1 
     279               ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 
     280                  startloop = Ni0glo/2+2 - nimpp + khls 
     281               ELSE 
     282                  startloop = jpi + 1 
     283               ENDIF 
     284               IF( startloop <= jpi ) THEN 
    233285                  DO jl = 1, ipl; DO jk = 1, ipk 
    234                        DO jj = 2, nn_hls+1 
    235                      ijj = jpj -jj +1 
    236                         DO ji = startloop, jpi 
    237                            ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
    238                            ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
    239                         END DO 
    240                     END DO 
     286                     DO ji = startloop, jpi 
     287                        ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
     288                        ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(ijt,khls+1,jk,jl) 
     289                     END DO 
    241290                  END DO; END DO 
    242291               ENDIF 
    243                DO jl = 1, ipl; DO jk = 1, ipk 
    244                   DO ji = startloop, jpi 
    245                      ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4 
    246                      ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf) 
    247                   END DO 
    248                END DO; END DO 
    249                IF (nimpp .eq. 1) THEN 
    250         DO jj = 1, nn_hls 
    251                        ijj = jpj-jj+1 
    252                        DO ii = 0, nn_hls-1 
    253                         ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:,jf) 
    254            END DO 
    255         END DO 
    256                ENDIF 
    257             CASE ( 'F' )                                     ! F-point 
     292            ENDIF 
     293            ! 
     294         CASE ( 'F' )                               ! F-point 
     295            IF( nimpp + jpi - 1 /= jpiglo ) THEN 
     296               endloop = jpi 
     297            ELSE 
     298               endloop = jpi - khls 
     299            ENDIF 
     300            DO jl = 1, ipl; DO jk = 1, ipk 
     301               DO jj = 1, khls 
     302                  ijj = jpj -jj +1 
     303                  DO ji = 1, endloop 
     304                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 
     305                     ptab(ji,ijj ,jk,jl) = psgn * ptab2(iju,jj,jk,jl) 
     306                  END DO 
     307               END DO 
     308            END DO; END DO 
     309            IF((nimpp + jpi - 1) .eq. jpiglo) THEN 
     310               DO jl = 1, ipl; DO jk = 1, ipk 
     311                  DO jj = 1, khls 
     312                     ijj = jpj -jj +1 
     313                     DO ii = 1, khls 
     314                        iij = jpi -ii+1 
     315                        ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*khls+ii-1,jpj-2*khls+jj-1,jk,jl) 
     316                     END DO 
     317                  END DO 
     318               END DO; END DO 
     319            ENDIF 
     320            ! 
     321            IF ( .NOT. l_fast_exchanges ) THEN 
    258322               IF( nimpp + jpi - 1 /= jpiglo ) THEN 
    259323                  endloop = jpi 
    260324               ELSE 
    261                   endloop = jpi - nn_hls 
    262                ENDIF 
    263                IF ( .NOT. l_fast_exchanges ) THEN 
     325                  endloop = jpi - khls 
     326               ENDIF 
     327               IF( nimpp >= Ni0glo/2+2 ) THEN 
     328                  startloop = 1  
     329               ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 
     330                  startloop = Ni0glo/2+2 - nimpp + khls 
     331               ELSE 
     332                  startloop = endloop + 1 
     333               ENDIF 
     334               IF( startloop <= endloop ) THEN 
    264335                  DO jl = 1, ipl; DO jk = 1, ipk 
    265                        DO jj = 2, nn_hls+1 
    266                      ijj = jpj -jj +1 
    267                         DO ji = 1, endloop 
    268                            iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    269                            ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 
    270                         END DO 
    271                     END DO 
     336                     DO ji = startloop, endloop 
     337                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 
     338                        ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(iju,khls+1,jk,jl) 
     339                     END DO 
    272340                  END DO; END DO 
    273341               ENDIF 
    274                DO jl = 1, ipl; DO jk = 1, ipk 
    275                   DO ji = 1, endloop 
    276                      iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    277                      ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf) 
    278                   END DO 
    279                END DO; END DO 
    280       IF (nimpp .eq. 1) THEN                
    281          DO ii = 1, nn_hls 
    282                  ARRAY_IN(ii,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:,jf) 
    283          END DO 
    284          IF ( .NOT. l_fast_exchanges ) THEN 
    285             DO jj = 1, nn_hls 
    286                       ijj = jpj -jj 
    287                       DO ii = 0, nn_hls-1 
    288                          ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 
    289                    END DO 
    290                       END DO 
    291                      ENDIF 
    292       ENDIF 
    293       IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 
    294                    DO ii = 1, nn_hls 
    295                  ARRAY_IN(jpi-ii+1,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:,jf) 
    296          END DO 
    297          IF ( .NOT. l_fast_exchanges ) THEN 
    298             DO jj = 1, nn_hls 
    299                            ijj = jpj -jj 
    300                       DO ii = 1, nn_hls 
    301                          ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 
    302                          END DO 
    303                       END DO 
    304                      ENDIF 
    305                   ENDIF 
    306                   ! 
    307        END SELECT 
    308             ! 
    309          CASE ( 5, 6 )                        ! *  North fold  F-point pivot 
    310             ! 
    311             SELECT CASE ( NAT_IN(jf) ) 
    312             CASE ( 'T' , 'W' )                               ! T-, W-point 
    313                DO jl = 1, ipl; DO jk = 1, ipk 
    314         DO jj = 1, nn_hls 
    315            ijj = jpj-jj+1 
    316            DO ji = 1, jpi 
    317                         ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    318                         ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
    319                      END DO 
    320         END DO 
    321                END DO; END DO 
    322                ! 
    323             CASE ( 'U' )                                     ! U-point 
    324                IF( nimpp + jpi - 1 /= jpiglo ) THEN 
    325                   endloop = jpi 
    326                ELSE 
    327                   endloop = jpi - nn_hls 
    328                ENDIF 
    329                DO jl = 1, ipl; DO jk = 1, ipk 
    330         DO jj = 1, nn_hls 
    331            ijj = jpj-jj+1 
    332                      DO ji = 1, endloop 
    333                         iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 
    334                         ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 
    335                      END DO 
    336                   END DO 
    337                END DO; END DO 
    338                IF(nimpp + jpi - 1 .eq. jpiglo) THEN 
    339                   DO jl = 1, ipl; DO jk = 1, ipk 
    340                      DO jj = 1, nn_hls 
    341                           ijj = jpj-jj+1 
    342                         DO ii = 1, nn_hls 
    343             iij = jpi-ii+1 
    344                            ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl,jf) 
    345                         END DO 
    346                      END DO 
    347                   END DO; END DO 
    348                ENDIF 
    349                ! 
    350             CASE ( 'V' )                                     ! V-point 
    351                DO jl = 1, ipl; DO jk = 1, ipk 
    352         DO jj = 1, nn_hls 
    353            ijj = jpj -jj +1 
    354                      DO ji = 1, jpi 
    355                         ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    356                         ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 
    357                      END DO 
    358                   END DO 
    359                END DO; END DO 
     342            ENDIF 
     343            ! 
     344         END SELECT 
     345         ! 
     346      ENDIF   ! c_NFtype == 'F' 
     347      ! 
     348   END SUBROUTINE lbc_nfd_nogather_/**/PRECISION 
    360349 
    361                IF ( .NOT. l_fast_exchanges ) THEN 
    362                   IF( nimpp >= Ni0glo/2+2 ) THEN 
    363                      startloop = 1 
    364                   ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 
    365                      startloop = Ni0glo/2+2 - nimpp + nn_hls 
    366                   ELSE 
    367                      startloop = jpi + 1 
    368                   ENDIF 
    369                   IF( startloop <= jpi ) THEN 
    370                   DO jl = 1, ipl; DO jk = 1, ipk 
    371                         DO ji = startloop, jpi 
    372                         ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 
    373                            ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf) 
    374                         END DO 
    375                   END DO; END DO 
    376                   ENDIF 
    377                ENDIF 
    378                ! 
    379             CASE ( 'F' )                               ! F-point 
    380                IF( nimpp + jpi - 1 /= jpiglo ) THEN 
    381                   endloop = jpi 
    382                ELSE 
    383                   endloop = jpi - nn_hls 
    384                ENDIF 
    385                DO jl = 1, ipl; DO jk = 1, ipk 
    386         DO jj = 1, nn_hls 
    387           ijj = jpj -jj +1 
    388                     DO ji = 1, endloop 
    389                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 
    390                        ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 
    391                      END DO 
    392                   END DO 
    393                END DO; END DO 
    394                IF((nimpp + jpi - 1) .eq. jpiglo) THEN 
    395                   DO jl = 1, ipl; DO jk = 1, ipk 
    396                      DO jj = 1, nn_hls 
    397                         ijj = jpj -jj +1 
    398                         DO ii = 1, nn_hls 
    399             iij = jpi -ii+1 
    400                            ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl,jf) 
    401                         END DO 
    402                      END DO 
    403                   END DO; END DO 
    404                ENDIF 
    405                ! 
    406                IF ( .NOT. l_fast_exchanges ) THEN 
    407                   IF( nimpp + jpi - 1 /= jpiglo ) THEN 
    408                      endloop = jpi 
    409                   ELSE 
    410                      endloop = jpi - nn_hls 
    411                   ENDIF 
    412                   IF( nimpp >= Ni0glo/2+2 ) THEN 
    413                      startloop = 1  
    414                   ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN 
    415                      startloop = Ni0glo/2+2 - nimpp + nn_hls 
    416                   ELSE 
    417                      startloop = endloop + 1 
    418                   ENDIF 
    419                   IF( startloop <= endloop ) THEN 
    420                      DO jl = 1, ipl; DO jk = 1, ipk 
    421                         DO ji = startloop, endloop 
    422                            iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 
    423                            ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf) 
    424                         END DO 
    425                      END DO; END DO 
    426                   ENDIF 
    427                ENDIF 
    428                ! 
    429             END SELECT 
    430             ! 
    431          CASE DEFAULT                           ! *  closed : the code probably never go through 
    432             ! 
    433             WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj 
    434             ! 
    435          END SELECT     !  npolj 
    436          ! 
    437       END DO            ! End jf loop 
    438    END SUBROUTINE ROUTINE_NFD 
    439 #undef PRECISION 
    440 #undef ARRAY_TYPE 
    441 #undef ARRAY_IN 
    442 #undef NAT_IN 
    443 #undef SGN_IN 
    444 #undef J_SIZE 
    445 #undef K_SIZE 
    446 #undef L_SIZE 
    447 #undef F_SIZE 
    448 #undef ARRAY2_TYPE 
    449 #undef ARRAY2_IN 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lbclnk.F90

    r14229 r14574  
    2323   USE lbcnfd         ! north fold 
    2424   USE in_out_manager ! I/O manager 
     25#if ! defined key_mpi_off 
     26   USE MPI 
     27#endif 
    2528 
    2629   IMPLICIT NONE 
    … …  
    2831 
    2932   INTERFACE lbc_lnk 
    30       MODULE PROCEDURE   mpp_lnk_2d_sp   , mpp_lnk_3d_sp   , mpp_lnk_4d_sp 
    31       MODULE PROCEDURE   mpp_lnk_2d_dp   , mpp_lnk_3d_dp   , mpp_lnk_4d_dp 
    32    END INTERFACE 
    33    INTERFACE lbc_lnk_ptr 
    34       MODULE PROCEDURE   mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp 
    35       MODULE PROCEDURE   mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp 
    36    END INTERFACE 
    37    INTERFACE lbc_lnk_multi 
    38       MODULE PROCEDURE   lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp 
    39       MODULE PROCEDURE   lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 
    40    END INTERFACE 
    41    INTERFACE lbc_lnk_nc_multi 
    42       MODULE PROCEDURE   lbc_lnk_nc_2d_sp, lbc_lnk_nc_3d_sp, lbc_lnk_nc_4d_sp 
    43       MODULE PROCEDURE   lbc_lnk_nc_2d_dp, lbc_lnk_nc_3d_dp, lbc_lnk_nc_4d_dp 
    44    END INTERFACE 
    45    INTERFACE lbc_lnk_nc 
    46       MODULE PROCEDURE   mpp_lnk_nc_2d_sp, mpp_lnk_nc_3d_sp, mpp_lnk_nc_4d_sp 
    47       MODULE PROCEDURE   mpp_lnk_nc_2d_dp, mpp_lnk_nc_3d_dp, mpp_lnk_nc_4d_dp 
     33      MODULE PROCEDURE   lbc_lnk_call_2d_sp, lbc_lnk_call_3d_sp, lbc_lnk_call_4d_sp 
     34      MODULE PROCEDURE   lbc_lnk_call_2d_dp, lbc_lnk_call_3d_dp, lbc_lnk_call_4d_dp 
     35   END INTERFACE 
     36 
     37   INTERFACE lbc_lnk_pt2pt 
     38      MODULE PROCEDURE   lbc_lnk_pt2pt_sp, lbc_lnk_pt2pt_dp 
     39   END INTERFACE 
     40 
     41   INTERFACE lbc_lnk_neicoll 
     42      MODULE PROCEDURE   lbc_lnk_neicoll_sp ,lbc_lnk_neicoll_dp 
    4843   END INTERFACE 
    4944   ! 
    … …  
    5247   END INTERFACE 
    5348 
    54    INTERFACE mpp_nfd 
    55       MODULE PROCEDURE   mpp_nfd_2d_sp    , mpp_nfd_3d_sp    , mpp_nfd_4d_sp 
    56       MODULE PROCEDURE   mpp_nfd_2d_dp    , mpp_nfd_3d_dp    , mpp_nfd_4d_dp 
    57       MODULE PROCEDURE   mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp 
    58       MODULE PROCEDURE   mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp 
    59  
    60    END INTERFACE 
    61  
    6249   PUBLIC   lbc_lnk            ! ocean/ice lateral boundary conditions 
    63    PUBLIC   lbc_lnk_multi      ! modified ocean/ice lateral boundary conditions 
    6450   PUBLIC   lbc_lnk_icb        ! iceberg lateral boundary conditions 
    65    PUBLIC   lbc_lnk_nc         ! ocean/ice lateral boundary conditions (MPI3 version) 
    66    PUBLIC   lbc_lnk_nc_multi   ! modified ocean/ice lateral boundary conditions (MPI3 version) 
    67  
    68 #if ! defined key_mpi_off 
    69 !$AGRIF_DO_NOT_TREAT 
    70    INCLUDE 'mpif.h' 
    71 !$AGRIF_END_DO_NOT_TREAT 
    72 #endif 
    73  
    74    INTEGER, PUBLIC, PARAMETER ::   jpfillnothing = 1 
    75    INTEGER, PUBLIC, PARAMETER ::   jpfillcst     = 2 
    76    INTEGER, PUBLIC, PARAMETER ::   jpfillcopy    = 3 
    77    INTEGER, PUBLIC, PARAMETER ::   jpfillperio   = 4 
    78    INTEGER, PUBLIC, PARAMETER ::   jpfillmpi     = 5 
    79  
     51 
     52   REAL(dp), DIMENSION(:), ALLOCATABLE ::   buffsnd_dp, buffrcv_dp   ! MPI send/recv buffers 
     53   REAL(sp), DIMENSION(:), ALLOCATABLE ::   buffsnd_sp, buffrcv_sp   !  
     54   INTEGER,  DIMENSION(8)              ::   nreq_p2p                 ! request id for MPI_Isend in point-2-point communication 
     55    
    8056   !! * Substitutions 
    81 #  include "do_loop_substitute.h90" 
     57   !!#  include "do_loop_substitute.h90" 
    8258   !!---------------------------------------------------------------------- 
    8359   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    8864 
    8965   !!---------------------------------------------------------------------- 
    90    !!                   ***   load_ptr_(2,3,4)d   *** 
     66   !!                   ***   lbc_lnk_call_[234]d_[sd]p   *** 
    9167   !! 
    9268   !!   * Dummy Argument : 
    93    !!       in    ==>   ptab       ! array to be loaded (2D, 3D or 4D) 
     69   !!       in    ==>   cdname     ! name of the calling subroutine (for monitoring) 
     70   !!                   ptab       ! array to be loaded (2D, 3D or 4D) 
    9471   !!                   cd_nat     ! nature of pt2d array grid-points 
    9572   !!                   psgn       ! sign used across the north fold boundary 
    … …  
    9976   !!                   kfld       ! number of elements that has been attributed 
    10077   !!---------------------------------------------------------------------- 
    101  
    102    !!---------------------------------------------------------------------- 
    103    !!                  ***   lbc_lnk_(2,3,4)d_multi   *** 
    104    !!                     ***   load_ptr_(2,3,4)d   *** 
    105    !! 
    106    !!   * Argument : dummy argument use in lbc_lnk_multi_... routines 
    107    !! 
    108    !!---------------------------------------------------------------------- 
    109  
     78   ! 
     79   !!---------------------------------------------------------------------- 
     80   !! 
     81   !!                  ***   lbc_lnk_call_[234]d_[sd]p   *** 
     82   !!                  ***     load_ptr_[234]d_[sd]p     *** 
     83   !! 
     84   !!---------------------------------------------------------------------- 
    11085   !! 
    11186   !!   ----   SINGLE PRECISION VERSIONS 
    11287   !! 
    113 #  define SINGLE_PRECISION 
    114 #  define DIM_2d 
    115 #     define ROUTINE_LOAD           load_ptr_2d_sp 
    116 #     define ROUTINE_MULTI          lbc_lnk_2d_multi_sp 
    117 #     include "lbc_lnk_multi_generic.h90" 
    118 #     undef ROUTINE_MULTI 
    119 #     undef ROUTINE_LOAD 
    120 #  undef DIM_2d 
    121  
    122 #  define DIM_3d 
    123 #     define ROUTINE_LOAD           load_ptr_3d_sp 
    124 #     define ROUTINE_MULTI          lbc_lnk_3d_multi_sp 
    125 #     include "lbc_lnk_multi_generic.h90" 
    126 #     undef ROUTINE_MULTI 
    127 #     undef ROUTINE_LOAD 
    128 #  undef DIM_3d 
    129  
    130 #  define DIM_4d 
    131 #     define ROUTINE_LOAD           load_ptr_4d_sp 
    132 #     define ROUTINE_MULTI          lbc_lnk_4d_multi_sp 
    133 #     include "lbc_lnk_multi_generic.h90" 
    134 #     undef ROUTINE_MULTI 
    135 #     undef ROUTINE_LOAD 
    136 #  undef DIM_4d 
    137 #  undef SINGLE_PRECISION 
     88#define PRECISION sp 
     89# define DIM_2d 
     90#    include "lbc_lnk_call_generic.h90" 
     91# undef  DIM_2d 
     92# define DIM_3d 
     93#    include "lbc_lnk_call_generic.h90" 
     94# undef  DIM_3d 
     95# define DIM_4d 
     96#    include "lbc_lnk_call_generic.h90" 
     97# undef  DIM_4d 
     98#undef PRECISION 
    13899   !! 
    139100   !!   ----   DOUBLE PRECISION VERSIONS 
    140101   !! 
    141  
    142 #  define DIM_2d 
    143 #     define ROUTINE_LOAD           load_ptr_2d_dp 
    144 #     define ROUTINE_MULTI          lbc_lnk_2d_multi_dp 
    145 #     include "lbc_lnk_multi_generic.h90" 
    146 #     undef ROUTINE_MULTI 
    147 #     undef ROUTINE_LOAD 
    148 #  undef DIM_2d 
    149  
    150 #  define DIM_3d 
    151 #     define ROUTINE_LOAD           load_ptr_3d_dp 
    152 #     define ROUTINE_MULTI          lbc_lnk_3d_multi_dp 
    153 #     include "lbc_lnk_multi_generic.h90" 
    154 #     undef ROUTINE_MULTI 
    155 #     undef ROUTINE_LOAD 
    156 #  undef DIM_3d 
    157  
    158 #  define DIM_4d 
    159 #     define ROUTINE_LOAD           load_ptr_4d_dp 
    160 #     define ROUTINE_MULTI          lbc_lnk_4d_multi_dp 
    161 #     include "lbc_lnk_multi_generic.h90" 
    162 #     undef ROUTINE_MULTI 
    163 #     undef ROUTINE_LOAD 
    164 #  undef DIM_4d 
    165  
    166    !!---------------------------------------------------------------------- 
    167    !!                   ***  routine mpp_lnk_(2,3,4)d  *** 
    168    !! 
    169    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    170    !!                ptab      :   array or pointer of arrays on which the boundary condition is applied 
     102#define PRECISION dp 
     103# define DIM_2d 
     104#    include "lbc_lnk_call_generic.h90" 
     105# undef  DIM_2d 
     106# define DIM_3d 
     107#    include "lbc_lnk_call_generic.h90" 
     108# undef  DIM_3d 
     109# define DIM_4d 
     110#    include "lbc_lnk_call_generic.h90" 
     111# undef  DIM_4d 
     112#undef PRECISION 
     113   ! 
     114   !!---------------------------------------------------------------------- 
     115   !!                   ***  lbc_lnk_pt2pt_[sd]p  *** 
     116   !!                  ***  lbc_lnk_neicoll_[sd]p  *** 
     117   !! 
     118   !!   * Argument : dummy argument use in lbc_lnk_... routines 
     119   !!                cdname    :   name of the calling subroutine (for monitoring) 
     120   !!                ptab      :   pointer of arrays on which the boundary condition is applied 
    171121   !!                cd_nat    :   nature of array grid-points 
    172122   !!                psgn      :   sign used across the north fold boundary 
    173    !!                kfld      :   optional, number of pt3d arrays 
     123   !!                kfld      :   number of pt3d arrays 
    174124   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
    175125   !!                pfillval  :   optional, background value (used with jpfillcopy) 
    176126   !!---------------------------------------------------------------------- 
    177    ! 
    178    !                       !==  2D array and array of 2D pointer  ==! 
    179    ! 
    180127   !! 
    181128   !!   ----   SINGLE PRECISION VERSIONS 
    182129   !! 
    183 # define SINGLE_PRECISION 
    184 #  define DIM_2d 
    185 #     define ROUTINE_LNK           mpp_lnk_2d_sp 
    186 #     include "mpp_lnk_generic.h90" 
    187 #     undef ROUTINE_LNK 
    188 #     define MULTI 
    189 #     define ROUTINE_LNK           mpp_lnk_2d_ptr_sp 
    190 #     include "mpp_lnk_generic.h90" 
    191 #     undef ROUTINE_LNK 
    192 #     undef MULTI 
    193 #  undef DIM_2d 
    194    ! 
    195    !                       !==  3D array and array of 3D pointer  ==! 
    196    ! 
    197 #  define DIM_3d 
    198 #     define ROUTINE_LNK           mpp_lnk_3d_sp 
    199 #     include "mpp_lnk_generic.h90" 
    200 #     undef ROUTINE_LNK 
    201 #     define MULTI 
    202 #     define ROUTINE_LNK           mpp_lnk_3d_ptr_sp 
    203 #     include "mpp_lnk_generic.h90" 
    204 #     undef ROUTINE_LNK 
    205 #     undef MULTI 
    206 #  undef DIM_3d 
    207    ! 
    208    !                       !==  4D array and array of 4D pointer  ==! 
    209    ! 
    210 #  define DIM_4d 
    211 #     define ROUTINE_LNK           mpp_lnk_4d_sp 
    212 #     include "mpp_lnk_generic.h90" 
    213 #     undef ROUTINE_LNK 
    214 #     define MULTI 
    215 #     define ROUTINE_LNK           mpp_lnk_4d_ptr_sp 
    216 #     include "mpp_lnk_generic.h90" 
    217 #     undef ROUTINE_LNK 
    218 #     undef MULTI 
    219 #  undef DIM_4d 
    220 # undef SINGLE_PRECISION 
    221  
     130#define PRECISION sp 
     131#  define MPI_TYPE MPI_REAL 
     132#  define BUFFSND buffsnd_sp 
     133#  define BUFFRCV buffrcv_sp 
     134#  include "lbc_lnk_pt2pt_generic.h90" 
     135#  include "lbc_lnk_neicoll_generic.h90" 
     136#  undef MPI_TYPE 
     137#  undef BUFFSND 
     138#  undef BUFFRCV 
     139#undef PRECISION 
    222140   !! 
    223141   !!   ----   DOUBLE PRECISION VERSIONS 
    224142   !! 
    225 #  define DIM_2d 
    226 #     define ROUTINE_LNK           mpp_lnk_2d_dp 
    227 #     include "mpp_lnk_generic.h90" 
    228 #     undef ROUTINE_LNK 
    229 #     define MULTI 
    230 #     define ROUTINE_LNK           mpp_lnk_2d_ptr_dp 
    231 #     include "mpp_lnk_generic.h90" 
    232 #     undef ROUTINE_LNK 
    233 #     undef MULTI 
    234 #  undef DIM_2d 
    235    ! 
    236    !                       !==  3D array and array of 3D pointer  ==! 
    237    ! 
    238 #  define DIM_3d 
    239 #     define ROUTINE_LNK           mpp_lnk_3d_dp 
    240 #     include "mpp_lnk_generic.h90" 
    241 #     undef ROUTINE_LNK 
    242 #     define MULTI 
    243 #     define ROUTINE_LNK           mpp_lnk_3d_ptr_dp 
    244 #     include "mpp_lnk_generic.h90" 
    245 #     undef ROUTINE_LNK 
    246 #     undef MULTI 
    247 #  undef DIM_3d 
    248    ! 
    249    !                       !==  4D array and array of 4D pointer  ==! 
    250    ! 
    251 #  define DIM_4d 
    252 #     define ROUTINE_LNK           mpp_lnk_4d_dp 
    253 #     include "mpp_lnk_generic.h90" 
    254 #     undef ROUTINE_LNK 
    255 #     define MULTI 
    256 #     define ROUTINE_LNK           mpp_lnk_4d_ptr_dp 
    257 #     include "mpp_lnk_generic.h90" 
    258 #     undef ROUTINE_LNK 
    259 #     undef MULTI 
    260 #  undef DIM_4d 
    261  
    262    !!---------------------------------------------------------------------- 
    263    !!                   ***   load_ptr_(2,3,4)d   *** 
    264    !! 
    265    !!   * Dummy Argument : 
    266    !!       in    ==>   ptab       ! array to be loaded (2D, 3D or 4D) 
    267    !!                   cd_nat     ! nature of pt2d array grid-points 
    268    !!                   psgn       ! sign used across the north fold boundary 
    269    !!       inout <=>   ptab_ptr   ! array of 2D, 3D or 4D pointers 
    270    !!                   cdna_ptr   ! nature of ptab array grid-points 
    271    !!                   psgn_ptr   ! sign used across the north fold boundary 
    272    !!                   kfld       ! number of elements that has been attributed 
    273    !!---------------------------------------------------------------------- 
    274  
    275    !!---------------------------------------------------------------------- 
    276    !!                  ***   lbc_lnk_nc(2,3,4)d_multi   *** 
    277    !!                     ***   load_ptr_(2,3,4)d   *** 
    278    !! 
    279    !!   * Argument : dummy argument use in lbc_lnk_nc_multi_... routines 
    280    !! 
    281    !!---------------------------------------------------------------------- 
    282  
    283    !! 
    284    !!   ----   SINGLE PRECISION VERSIONS 
    285    !! 
    286 #  define SINGLE_PRECISION 
    287 #  define DIM_2d 
    288 #     define ROUTINE_NC_LOAD           load_ptr_nc_2d_sp 
    289 #     define ROUTINE_MULTI_NC          lbc_lnk_nc_2d_sp 
    290 #     include "lbc_lnk_nc_generic.h90" 
    291 #     undef ROUTINE_MULTI_NC 
    292 #     undef ROUTINE_NC_LOAD 
    293 #  undef DIM_2d 
    294  
    295 #  define DIM_3d 
    296 #     define ROUTINE_NC_LOAD           load_ptr_nc_3d_sp 
    297 #     define ROUTINE_MULTI_NC          lbc_lnk_nc_3d_sp 
    298 #     include "lbc_lnk_nc_generic.h90" 
    299 #     undef ROUTINE_MULTI_NC 
    300 #     undef ROUTINE_NC_LOAD 
    301 #  undef DIM_3d 
    302  
    303 #  define DIM_4d 
    304 #     define ROUTINE_NC_LOAD           load_ptr_nc_4d_sp 
    305 #     define ROUTINE_MULTI_NC          lbc_lnk_nc_4d_sp 
    306 #     include "lbc_lnk_nc_generic.h90" 
    307 #     undef ROUTINE_MULTI_NC 
    308 #     undef ROUTINE_NC_LOAD 
    309 #  undef DIM_4d 
    310 #  undef SINGLE_PRECISION 
    311    !! 
    312    !!   ----   DOUBLE PRECISION VERSIONS 
    313    !! 
    314  
    315 #  define DIM_2d 
    316 #     define ROUTINE_NC_LOAD           load_ptr_nc_2d_dp 
    317 #     define ROUTINE_MULTI_NC          lbc_lnk_nc_2d_dp 
    318 #     include "lbc_lnk_nc_generic.h90" 
    319 #     undef ROUTINE_MULTI_NC 
    320 #     undef ROUTINE_NC_LOAD 
    321 #  undef DIM_2d 
    322  
    323 #  define DIM_3d 
    324 #     define ROUTINE_NC_LOAD           load_ptr_nc_3d_dp 
    325 #     define ROUTINE_MULTI_NC          lbc_lnk_nc_3d_dp 
    326 #     include "lbc_lnk_nc_generic.h90" 
    327 #     undef ROUTINE_MULTI_NC 
    328 #     undef ROUTINE_NC_LOAD 
    329 #  undef DIM_3d 
    330  
    331 #  define DIM_4d 
    332 #     define ROUTINE_NC_LOAD           load_ptr_nc_4d_dp 
    333 #     define ROUTINE_MULTI_NC          lbc_lnk_nc_4d_dp 
    334 #     include "lbc_lnk_nc_generic.h90" 
    335 #     undef ROUTINE_MULTI_NC 
    336 #     undef ROUTINE_NC_LOAD 
    337 #  undef DIM_4d 
    338  
    339    !!---------------------------------------------------------------------- 
    340    !!                   ***  routine mpp_lnk_nc_(2,3,4)d  *** 
    341    !! 
    342    !!   * Argument : dummy argument use in mpp_lnk_... routines 
    343    !!                ptab      :   array or pointer of arrays on which the boundary condition is applied 
    344    !!                cd_nat    :   nature of array grid-points 
    345    !!                psgn      :   sign used across the north fold boundary 
    346    !!                kfld      :   optional, number of pt3d arrays 
    347    !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
    348    !!                pfillval  :   optional, background value (used with jpfillcopy) 
    349    !!---------------------------------------------------------------------- 
    350    ! 
    351    !                       !==  2D array and array of 2D pointer  ==! 
    352    ! 
    353    !! 
    354    !!   ----   SINGLE PRECISION VERSIONS 
    355    !! 
    356 # define SINGLE_PRECISION 
    357 #  define DIM_2d 
    358 #     define ROUTINE_NC           mpp_lnk_nc_2d_sp 
    359 #     include "mpp_nc_generic.h90" 
    360 #     undef ROUTINE_NC 
    361 #  undef DIM_2d 
    362    ! 
    363    !                       !==  3D array and array of 3D pointer  ==! 
    364    ! 
    365 #  define DIM_3d 
    366 #     define ROUTINE_NC           mpp_lnk_nc_3d_sp 
    367 #     include "mpp_nc_generic.h90" 
    368 #     undef ROUTINE_NC 
    369 #  undef DIM_3d 
    370    ! 
    371    !                       !==  4D array and array of 4D pointer  ==! 
    372    ! 
    373 #  define DIM_4d 
    374 #     define ROUTINE_NC           mpp_lnk_nc_4d_sp 
    375 #     include "mpp_nc_generic.h90" 
    376 #     undef ROUTINE_NC 
    377 #  undef DIM_4d 
    378 # undef SINGLE_PRECISION 
    379  
    380    !! 
    381    !!   ----   DOUBLE PRECISION VERSIONS 
    382    !! 
    383 #  define DIM_2d 
    384 #     define ROUTINE_NC           mpp_lnk_nc_2d_dp 
    385 #     include "mpp_nc_generic.h90" 
    386 #     undef ROUTINE_NC 
    387 #  undef DIM_2d 
    388    ! 
    389    !                       !==  3D array and array of 3D pointer  ==! 
    390    ! 
    391 #  define DIM_3d 
    392 #     define ROUTINE_NC           mpp_lnk_nc_3d_dp 
    393 #     include "mpp_nc_generic.h90" 
    394 #     undef ROUTINE_NC 
    395 #  undef DIM_3d 
    396    ! 
    397    !                       !==  4D array and array of 4D pointer  ==! 
    398    ! 
    399 #  define DIM_4d 
    400 #     define ROUTINE_NC           mpp_lnk_nc_4d_dp 
    401 #     include "mpp_nc_generic.h90" 
    402 #     undef ROUTINE_NC 
    403 #  undef DIM_4d 
    404  
    405    !!---------------------------------------------------------------------- 
    406    !!                   ***  routine mpp_nfd_(2,3,4)d  *** 
    407    !! 
    408    !!   * Argument : dummy argument use in mpp_nfd_... routines 
    409    !!                ptab      :   array or pointer of arrays on which the boundary condition is applied 
    410    !!                cd_nat    :   nature of array grid-points 
    411    !!                psgn      :   sign used across the north fold boundary 
    412    !!                kfld      :   optional, number of pt3d arrays 
    413    !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
    414    !!                pfillval  :   optional, background value (used with jpfillcopy) 
    415    !!---------------------------------------------------------------------- 
    416    ! 
    417    !                       !==  2D array and array of 2D pointer  ==! 
    418    ! 
    419    !! 
    420    !!   ----   SINGLE PRECISION VERSIONS 
    421    !! 
    422 #  define SINGLE_PRECISION 
    423 #  define DIM_2d 
    424 #     define ROUTINE_NFD           mpp_nfd_2d_sp 
    425 #     include "mpp_nfd_generic.h90" 
    426 #     undef ROUTINE_NFD 
    427 #     define MULTI 
    428 #     define ROUTINE_NFD           mpp_nfd_2d_ptr_sp 
    429 #     include "mpp_nfd_generic.h90" 
    430 #     undef ROUTINE_NFD 
    431 #     undef MULTI 
    432 #  undef DIM_2d 
    433    ! 
    434    !                       !==  3D array and array of 3D pointer  ==! 
    435    ! 
    436 #  define DIM_3d 
    437 #     define ROUTINE_NFD           mpp_nfd_3d_sp 
    438 #     include "mpp_nfd_generic.h90" 
    439 #     undef ROUTINE_NFD 
    440 #     define MULTI 
    441 #     define ROUTINE_NFD           mpp_nfd_3d_ptr_sp 
    442 #     include "mpp_nfd_generic.h90" 
    443 #     undef ROUTINE_NFD 
    444 #     undef MULTI 
    445 #  undef DIM_3d 
    446    ! 
    447    !                       !==  4D array and array of 4D pointer  ==! 
    448    ! 
    449 #  define DIM_4d 
    450 #     define ROUTINE_NFD           mpp_nfd_4d_sp 
    451 #     include "mpp_nfd_generic.h90" 
    452 #     undef ROUTINE_NFD 
    453 #     define MULTI 
    454 #     define ROUTINE_NFD           mpp_nfd_4d_ptr_sp 
    455 #     include "mpp_nfd_generic.h90" 
    456 #     undef ROUTINE_NFD 
    457 #     undef MULTI 
    458 #  undef DIM_4d 
    459 #  undef SINGLE_PRECISION 
    460  
    461    !! 
    462    !!   ----   DOUBLE PRECISION VERSIONS 
    463    !! 
    464 #  define DIM_2d 
    465 #     define ROUTINE_NFD           mpp_nfd_2d_dp 
    466 #     include "mpp_nfd_generic.h90" 
    467 #     undef ROUTINE_NFD 
    468 #     define MULTI 
    469 #     define ROUTINE_NFD           mpp_nfd_2d_ptr_dp 
    470 #     include "mpp_nfd_generic.h90" 
    471 #     undef ROUTINE_NFD 
    472 #     undef MULTI 
    473 #  undef DIM_2d 
    474    ! 
    475    !                       !==  3D array and array of 3D pointer  ==! 
    476    ! 
    477 #  define DIM_3d 
    478 #     define ROUTINE_NFD           mpp_nfd_3d_dp 
    479 #     include "mpp_nfd_generic.h90" 
    480 #     undef ROUTINE_NFD 
    481 #     define MULTI 
    482 #     define ROUTINE_NFD           mpp_nfd_3d_ptr_dp 
    483 #     include "mpp_nfd_generic.h90" 
    484 #     undef ROUTINE_NFD 
    485 #     undef MULTI 
    486 #  undef DIM_3d 
    487    ! 
    488    !                       !==  4D array and array of 4D pointer  ==! 
    489    ! 
    490 #  define DIM_4d 
    491 #     define ROUTINE_NFD           mpp_nfd_4d_dp 
    492 #     include "mpp_nfd_generic.h90" 
    493 #     undef ROUTINE_NFD 
    494 #     define MULTI 
    495 #     define ROUTINE_NFD           mpp_nfd_4d_ptr_dp 
    496 #     include "mpp_nfd_generic.h90" 
    497 #     undef ROUTINE_NFD 
    498 #     undef MULTI 
    499 #  undef DIM_4d 
    500  
    501    !!====================================================================== 
    502  
     143#define PRECISION dp 
     144#  define MPI_TYPE MPI_DOUBLE_PRECISION 
     145#  define BUFFSND buffsnd_dp 
     146#  define BUFFRCV buffrcv_dp 
     147#  include "lbc_lnk_pt2pt_generic.h90" 
     148#  include "lbc_lnk_neicoll_generic.h90" 
     149#  undef MPI_TYPE 
     150#  undef BUFFSND 
     151#  undef BUFFRCV 
     152#undef PRECISION 
    503153 
    504154   !!====================================================================== 
    … …  
    541191      !!                    jpi    : first dimension of the local subdomain 
    542192      !!                    jpj    : second dimension of the local subdomain 
    543       !!                    kexti  : number of columns for extra outer halo 
    544       !!                    kextj  : number of rows for extra outer halo 
    545       !!                    nbondi : mark for "east-west local boundary" 
    546       !!                    nbondj : mark for "north-south local boundary" 
    547       !!                    noea   : number for local neighboring processors 
    548       !!                    nowe   : number for local neighboring processors 
    549       !!                    noso   : number for local neighboring processors 
    550       !!                    nono   : number for local neighboring processors 
     193      !!                    mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 
    551194      !!---------------------------------------------------------------------- 
    552195 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lbcnfd.F90

    r13286 r14574  
    2121   USE in_out_manager ! I/O manager 
    2222   USE lib_mpp        ! MPP library 
     23#if ! defined key_mpi_off 
     24   USE MPI 
     25#endif 
    2326 
    2427   IMPLICIT NONE 
    2528   PRIVATE 
    2629 
    27    INTERFACE lbc_nfd 
    28       MODULE PROCEDURE   lbc_nfd_2d_sp    , lbc_nfd_3d_sp    , lbc_nfd_4d_sp 
    29       MODULE PROCEDURE   lbc_nfd_2d_ptr_sp, lbc_nfd_3d_ptr_sp, lbc_nfd_4d_ptr_sp 
    30       MODULE PROCEDURE   lbc_nfd_2d_ext_sp 
    31       MODULE PROCEDURE   lbc_nfd_2d_dp    , lbc_nfd_3d_dp    , lbc_nfd_4d_dp 
    32       MODULE PROCEDURE   lbc_nfd_2d_ptr_dp, lbc_nfd_3d_ptr_dp, lbc_nfd_4d_ptr_dp 
    33       MODULE PROCEDURE   lbc_nfd_2d_ext_dp 
    34    END INTERFACE 
    35    ! 
    36    INTERFACE lbc_nfd_nogather 
    37 !                        ! Currently only 4d array version is needed 
    38      MODULE PROCEDURE   lbc_nfd_nogather_2d_sp    , lbc_nfd_nogather_3d_sp 
    39      MODULE PROCEDURE   lbc_nfd_nogather_4d_sp 
    40      MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr_sp, lbc_nfd_nogather_3d_ptr_sp 
    41      MODULE PROCEDURE   lbc_nfd_nogather_2d_dp    , lbc_nfd_nogather_3d_dp 
    42      MODULE PROCEDURE   lbc_nfd_nogather_4d_dp 
    43      MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr_dp, lbc_nfd_nogather_3d_ptr_dp 
    44 !     MODULE PROCEDURE   lbc_nfd_nogather_4d_ptr 
     30   INTERFACE lbc_nfd            ! called by mpp_nfd, lbc_lnk_pt2pt or lbc_lnk_neicoll 
     31      MODULE PROCEDURE   lbc_nfd_sp, lbc_nfd_ext_sp 
     32      MODULE PROCEDURE   lbc_nfd_dp, lbc_nfd_ext_dp 
    4533   END INTERFACE 
    4634 
    47    TYPE, PUBLIC ::   PTR_2D_dp   !: array of 2D pointers (also used in lib_mpp) 
    48       REAL(dp), DIMENSION (:,:)    , POINTER ::   pt2d 
    49    END TYPE PTR_2D_dp 
    50    TYPE, PUBLIC ::   PTR_3D_dp   !: array of 3D pointers (also used in lib_mpp) 
    51       REAL(dp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
    52    END TYPE PTR_3D_dp 
    53    TYPE, PUBLIC ::   PTR_4D_dp   !: array of 4D pointers (also used in lib_mpp) 
    54       REAL(dp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
    55    END TYPE PTR_4D_dp 
     35   INTERFACE mpp_nfd            ! called by lbc_lnk_pt2pt or lbc_lnk_neicoll 
     36      MODULE PROCEDURE   mpp_nfd_sp, mpp_nfd_dp 
     37   END INTERFACE 
    5638 
    57    TYPE, PUBLIC ::   PTR_2D_sp   !: array of 2D pointers (also used in lib_mpp) 
    58       REAL(sp), DIMENSION (:,:)    , POINTER ::   pt2d 
    59    END TYPE PTR_2D_sp 
    60    TYPE, PUBLIC ::   PTR_3D_sp   !: array of 3D pointers (also used in lib_mpp) 
    61       REAL(sp), DIMENSION (:,:,:)  , POINTER ::   pt3d 
    62    END TYPE PTR_3D_sp 
    63    TYPE, PUBLIC ::   PTR_4D_sp   !: array of 4D pointers (also used in lib_mpp) 
    64       REAL(sp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
    65    END TYPE PTR_4D_sp 
    66  
    67  
     39   INTERFACE lbc_nfd_nogather   ! called by mpp_nfd 
     40      MODULE PROCEDURE   lbc_nfd_nogather_sp, lbc_nfd_nogather_dp 
     41   END INTERFACE 
     42    
     43   PUBLIC   mpp_nfd            ! mpi north fold conditions 
    6844   PUBLIC   lbc_nfd            ! north fold conditions 
    6945   PUBLIC   lbc_nfd_nogather   ! north fold conditions (no allgather case) 
    … …  
    8258 
    8359   !!---------------------------------------------------------------------- 
    84    !!                   ***  routine lbc_nfd_(2,3,4)d  *** 
     60   !!                   ***  routine lbc_nfd_[sd]p  *** 
     61   !!               ***  routine lbc_nfd_nogather_[sd]p  *** 
     62   !!                   ***  routine lbc_nfd_ext_[sd]p  *** 
    8563   !!---------------------------------------------------------------------- 
    8664   !! 
    … …  
    9573   !                       !==  SINGLE PRECISION VERSIONS 
    9674   ! 
    97    ! 
    98    !                       !==  2D array and array of 2D pointer  ==! 
    99    ! 
    100 #  define SINGLE_PRECISION 
    101 #  define DIM_2d 
    102 #     define ROUTINE_NFD           lbc_nfd_2d_sp 
    103 #     include "lbc_nfd_generic.h90" 
    104 #     undef ROUTINE_NFD 
    105 #     define MULTI 
    106 #     define ROUTINE_NFD           lbc_nfd_2d_ptr_sp 
    107 #     include "lbc_nfd_generic.h90" 
    108 #     undef ROUTINE_NFD 
    109 #     undef MULTI 
    110 #  undef DIM_2d 
    111    ! 
    112    !                       !==  2D array with extra haloes  ==! 
    113    ! 
    114 #  define DIM_2d 
    115 #     define ROUTINE_NFD           lbc_nfd_2d_ext_sp 
    116 #     include "lbc_nfd_ext_generic.h90" 
    117 #     undef ROUTINE_NFD 
    118 #  undef DIM_2d 
    119    ! 
    120    !                       !==  3D array and array of 3D pointer  ==! 
    121    ! 
    122 #  define DIM_3d 
    123 #     define ROUTINE_NFD           lbc_nfd_3d_sp 
    124 #     include "lbc_nfd_generic.h90" 
    125 #     undef ROUTINE_NFD 
    126 #     define MULTI 
    127 #     define ROUTINE_NFD           lbc_nfd_3d_ptr_sp 
    128 #     include "lbc_nfd_generic.h90" 
    129 #     undef ROUTINE_NFD 
    130 #     undef MULTI 
    131 #  undef DIM_3d 
    132    ! 
    133    !                       !==  4D array and array of 4D pointer  ==! 
    134    ! 
    135 #  define DIM_4d 
    136 #     define ROUTINE_NFD           lbc_nfd_4d_sp 
    137 #     include "lbc_nfd_generic.h90" 
    138 #     undef ROUTINE_NFD 
    139 #     define MULTI 
    140 #     define ROUTINE_NFD           lbc_nfd_4d_ptr_sp 
    141 #     include "lbc_nfd_generic.h90" 
    142 #     undef ROUTINE_NFD 
    143 #     undef MULTI 
    144 #  undef DIM_4d 
    145    ! 
    146    !  lbc_nfd_nogather routines 
    147    ! 
    148    !                       !==  2D array and array of 2D pointer  ==! 
    149    ! 
    150 #  define DIM_2d 
    151 #     define ROUTINE_NFD           lbc_nfd_nogather_2d_sp 
    152 #     include "lbc_nfd_nogather_generic.h90" 
    153 #     undef ROUTINE_NFD 
    154 #     define MULTI 
    155 #     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr_sp 
    156 #     include "lbc_nfd_nogather_generic.h90" 
    157 #     undef ROUTINE_NFD 
    158 #     undef MULTI 
    159 #  undef DIM_2d 
    160    ! 
    161    !                       !==  3D array and array of 3D pointer  ==! 
    162    ! 
    163 #  define DIM_3d 
    164 #     define ROUTINE_NFD           lbc_nfd_nogather_3d_sp 
    165 #     include "lbc_nfd_nogather_generic.h90" 
    166 #     undef ROUTINE_NFD 
    167 #     define MULTI 
    168 #     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr_sp 
    169 #     include "lbc_nfd_nogather_generic.h90" 
    170 #     undef ROUTINE_NFD 
    171 #     undef MULTI 
    172 #  undef DIM_3d 
    173    ! 
    174    !                       !==  4D array and array of 4D pointer  ==! 
    175    ! 
    176 #  define DIM_4d 
    177 #     define ROUTINE_NFD           lbc_nfd_nogather_4d_sp 
    178 #     include "lbc_nfd_nogather_generic.h90" 
    179 #     undef ROUTINE_NFD 
    180 !#     define MULTI 
    181 !#     define ROUTINE_NFD           lbc_nfd_nogather_4d_ptr 
    182 !#     include "lbc_nfd_nogather_generic.h90" 
    183 !#     undef ROUTINE_NFD 
    184 !#     undef MULTI 
    185 #  undef DIM_4d 
    186 #  undef SINGLE_PRECISION 
    187  
    188    !!---------------------------------------------------------------------- 
     75#define PRECISION sp 
     76#  include "lbc_nfd_generic.h90" 
     77#  include "lbc_nfd_nogather_generic.h90" 
     78#  include "lbc_nfd_ext_generic.h90" 
     79#undef PRECISION 
    18980   ! 
    19081   !                       !==  DOUBLE PRECISION VERSIONS 
    19182   ! 
     83#define PRECISION dp 
     84#  include "lbc_nfd_generic.h90" 
     85#  include "lbc_nfd_nogather_generic.h90" 
     86#  include "lbc_nfd_ext_generic.h90" 
     87#undef PRECISION 
     88 
     89   !!====================================================================== 
    19290   ! 
    193    !                       !==  2D array and array of 2D pointer  ==! 
    194    ! 
    195 #  define DIM_2d 
    196 #     define ROUTINE_NFD           lbc_nfd_2d_dp 
    197 #     include "lbc_nfd_generic.h90" 
    198 #     undef ROUTINE_NFD 
    199 #     define MULTI 
    200 #     define ROUTINE_NFD           lbc_nfd_2d_ptr_dp 
    201 #     include "lbc_nfd_generic.h90" 
    202 #     undef ROUTINE_NFD 
    203 #     undef MULTI 
    204 #  undef DIM_2d 
    205    ! 
    206    !                       !==  2D array with extra haloes  ==! 
    207    ! 
    208 #  define DIM_2d 
    209 #     define ROUTINE_NFD           lbc_nfd_2d_ext_dp 
    210 #     include "lbc_nfd_ext_generic.h90" 
    211 #     undef ROUTINE_NFD 
    212 #  undef DIM_2d 
    213    ! 
    214    !                       !==  3D array and array of 3D pointer  ==! 
    215    ! 
    216 #  define DIM_3d 
    217 #     define ROUTINE_NFD           lbc_nfd_3d_dp 
    218 #     include "lbc_nfd_generic.h90" 
    219 #     undef ROUTINE_NFD 
    220 #     define MULTI 
    221 #     define ROUTINE_NFD           lbc_nfd_3d_ptr_dp 
    222 #     include "lbc_nfd_generic.h90" 
    223 #     undef ROUTINE_NFD 
    224 #     undef MULTI 
    225 #  undef DIM_3d 
    226    ! 
    227    !                       !==  4D array and array of 4D pointer  ==! 
    228    ! 
    229 #  define DIM_4d 
    230 #     define ROUTINE_NFD           lbc_nfd_4d_dp 
    231 #     include "lbc_nfd_generic.h90" 
    232 #     undef ROUTINE_NFD 
    233 #     define MULTI 
    234 #     define ROUTINE_NFD           lbc_nfd_4d_ptr_dp 
    235 #     include "lbc_nfd_generic.h90" 
    236 #     undef ROUTINE_NFD 
    237 #     undef MULTI 
    238 #  undef DIM_4d 
    239    ! 
    240    !  lbc_nfd_nogather routines 
    241    ! 
    242    !                       !==  2D array and array of 2D pointer  ==! 
    243    ! 
    244 #  define DIM_2d 
    245 #     define ROUTINE_NFD           lbc_nfd_nogather_2d_dp 
    246 #     include "lbc_nfd_nogather_generic.h90" 
    247 #     undef ROUTINE_NFD 
    248 #     define MULTI 
    249 #     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr_dp 
    250 #     include "lbc_nfd_nogather_generic.h90" 
    251 #     undef ROUTINE_NFD 
    252 #     undef MULTI 
    253 #  undef DIM_2d 
    254    ! 
    255    !                       !==  3D array and array of 3D pointer  ==! 
    256    ! 
    257 #  define DIM_3d 
    258 #     define ROUTINE_NFD           lbc_nfd_nogather_3d_dp 
    259 #     include "lbc_nfd_nogather_generic.h90" 
    260 #     undef ROUTINE_NFD 
    261 #     define MULTI 
    262 #     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr_dp 
    263 #     include "lbc_nfd_nogather_generic.h90" 
    264 #     undef ROUTINE_NFD 
    265 #     undef MULTI 
    266 #  undef DIM_3d 
    267    ! 
    268    !                       !==  4D array and array of 4D pointer  ==! 
    269    ! 
    270 #  define DIM_4d 
    271 #     define ROUTINE_NFD           lbc_nfd_nogather_4d_dp 
    272 #     include "lbc_nfd_nogather_generic.h90" 
    273 #     undef ROUTINE_NFD 
    274 !#     define MULTI 
    275 !#     define ROUTINE_NFD           lbc_nfd_nogather_4d_ptr 
    276 !#     include "lbc_nfd_nogather_generic.h90" 
    277 !#     undef ROUTINE_NFD 
    278 !#     undef MULTI 
    279 #  undef DIM_4d 
    280  
    28191   !!---------------------------------------------------------------------- 
    282  
    283  
     92   !!                   ***  routine mpp_nfd_[sd]p  *** 
     93   !! 
     94   !!   * Argument : dummy argument use in mpp_nfd_... routines 
     95   !!                ptab      :   pointer of arrays on which the boundary condition is applied 
     96   !!                cd_nat    :   nature of array grid-points 
     97   !!                psgn      :   sign used across the north fold boundary 
     98   !!                kfld      :   optional, number of pt3d arrays 
     99   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables) 
     100   !!                pfillval  :   optional, background value (used with jpfillcopy) 
     101   !!---------------------------------------------------------------------- 
     102   !! 
     103   !!   ----   SINGLE PRECISION VERSIONS 
     104   !! 
     105#define PRECISION sp 
     106#  define MPI_TYPE MPI_REAL 
     107#  include "mpp_nfd_generic.h90" 
     108#  undef MPI_TYPE 
     109#undef PRECISION 
     110   !! 
     111   !!   ----   DOUBLE PRECISION VERSIONS 
     112   !! 
     113#define PRECISION dp 
     114#  define MPI_TYPE MPI_DOUBLE_PRECISION 
     115#  include "mpp_nfd_generic.h90" 
     116#  undef MPI_TYPE 
     117#undef PRECISION 
    284118 
    285119   !!====================================================================== 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/lib_mpp.F90

    r14229 r14574  
    5555   USE dom_oce        ! ocean space and time domain 
    5656   USE in_out_manager ! I/O manager 
     57#if ! defined key_mpi_off 
     58   USE MPI 
     59#endif 
    5760 
    5861   IMPLICIT NONE 
    … …  
    107110   END INTERFACE 
    108111 
     112   TYPE, PUBLIC ::   PTR_4D_sp   !: array of 4D pointers (used in lbclnk and lbcnfd) 
     113      REAL(sp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
     114   END TYPE PTR_4D_sp 
     115 
     116   TYPE, PUBLIC ::   PTR_4D_dp   !: array of 4D pointers (used in lbclnk and lbcnfd) 
     117      REAL(dp), DIMENSION (:,:,:,:), POINTER ::   pt4d 
     118   END TYPE PTR_4D_dp 
     119 
    109120   !! ========================= !! 
    110121   !!  MPI  variable definition !! 
    111122   !! ========================= !! 
    112123#if ! defined key_mpi_off 
    113 !$AGRIF_DO_NOT_TREAT 
    114    INCLUDE 'mpif.h' 
    115 !$AGRIF_END_DO_NOT_TREAT 
    116124   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag 
    117125#else 
    … …  
    122130#endif 
    123131 
    124    INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2) 
    125  
    126132   INTEGER, PUBLIC ::   mppsize        ! number of process 
    127133   INTEGER, PUBLIC ::   mpprank        ! process number  [ 0 - size-1 ] 
    … …  
    132138   INTEGER :: MPI_SUMDD 
    133139 
     140   ! Neighbourgs informations 
     141   INTEGER,    PARAMETER, PUBLIC ::   n_hlsmax = 3 
     142   INTEGER, DIMENSION(         8), PUBLIC ::   mpinei      !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg) 
     143   INTEGER, DIMENSION(n_hlsmax,8), PUBLIC ::   mpiSnei     !: 8-neighbourg Send MPI indexes (starting at 0, -1 if no neighbourg) 
     144   INTEGER, DIMENSION(n_hlsmax,8), PUBLIC ::   mpiRnei     !: 8-neighbourg Recv MPI indexes (starting at 0, -1 if no neighbourg) 
     145   INTEGER,    PARAMETER, PUBLIC ::   jpwe = 1   !: WEst 
     146   INTEGER,    PARAMETER, PUBLIC ::   jpea = 2   !: EAst 
     147   INTEGER,    PARAMETER, PUBLIC ::   jpso = 3   !: SOuth 
     148   INTEGER,    PARAMETER, PUBLIC ::   jpno = 4   !: NOrth 
     149   INTEGER,    PARAMETER, PUBLIC ::   jpsw = 5   !: South-West 
     150   INTEGER,    PARAMETER, PUBLIC ::   jpse = 6   !: South-East 
     151   INTEGER,    PARAMETER, PUBLIC ::   jpnw = 7   !: North-West 
     152   INTEGER,    PARAMETER, PUBLIC ::   jpne = 8   !: North-East 
     153 
     154   LOGICAL, DIMENSION(8), PUBLIC ::   l_SelfPerio  !   should we explicitely take care of I/J periodicity 
     155   LOGICAL,               PUBLIC ::   l_IdoNFold 
     156 
    134157   ! variables used for zonal integration 
    135    INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average 
    136    LOGICAL, PUBLIC ::   l_znl_root      !: True on the 'left'most processor on the same row 
    137    INTEGER         ::   ngrp_znl        ! group ID for the znl processors 
    138    INTEGER         ::   ndim_rank_znl   ! number of processors on the same zonal average 
     158   INTEGER, PUBLIC ::   ncomm_znl         !: communicator made by the processors on the same zonal average 
     159   LOGICAL, PUBLIC ::   l_znl_root        !: True on the 'left'most processor on the same row 
     160   INTEGER         ::   ngrp_znl          !: group ID for the znl processors 
     161   INTEGER         ::   ndim_rank_znl     !: number of processors on the same zonal average 
    139162   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain 
    140163 
    141164   ! variables used for MPI3 neighbourhood collectives 
    142    INTEGER, PUBLIC :: mpi_nc_com                   ! MPI3 neighbourhood collectives communicator 
    143    INTEGER, PUBLIC :: mpi_nc_all_com               ! MPI3 neighbourhood collectives communicator (with diagionals) 
     165   INTEGER, DIMENSION(n_hlsmax), PUBLIC ::   mpi_nc_com4       ! MPI3 neighbourhood collectives communicator 
     166   INTEGER, DIMENSION(n_hlsmax), PUBLIC ::   mpi_nc_com8       ! MPI3 neighbourhood collectives communicator (with diagionals) 
    144167 
    145168   ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) 
    … …  
    187210 
    188211   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms 
    189    LOGICAL, PUBLIC ::   l_north_nogather = .FALSE.  !: internal control of northfold comms 
     212   INTEGER, PUBLIC ::   nn_comm                     !: namelist control of comms 
     213 
     214   INTEGER, PUBLIC, PARAMETER ::   jpfillnothing = 1 
     215   INTEGER, PUBLIC, PARAMETER ::   jpfillcst     = 2 
     216   INTEGER, PUBLIC, PARAMETER ::   jpfillcopy    = 3 
     217   INTEGER, PUBLIC, PARAMETER ::   jpfillperio   = 4 
     218   INTEGER, PUBLIC, PARAMETER ::   jpfillmpi     = 5 
    190219 
    191220   !! * Substitutions 
    … …  
    265294      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
    266295      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
    267       INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     296      INTEGER , INTENT(inout) ::   md_req     ! argument for isend 
    268297      !! 
    269298      INTEGER ::   iflag 
    … …  
    294323      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
    295324      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
    296       INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     325      INTEGER , INTENT(inout) ::   md_req     ! argument for isend 
    297326      !! 
    298327      INTEGER ::   iflag 
    … …  
    317346      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
    318347      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
    319       INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     348      INTEGER , INTENT(inout) ::   md_req     ! argument for isend 
    320349      !! 
    321350      INTEGER ::   iflag 
    … …  
    944973      LOGICAL, OPTIONAL, INTENT(in) :: ld_abort    ! source process number 
    945974      LOGICAL ::   ll_abort 
    946       INTEGER ::   info 
     975      INTEGER ::   info, ierr 
    947976      !!---------------------------------------------------------------------- 
    948977      ll_abort = .FALSE. 
    … …  
    951980#if ! defined key_mpi_off 
    952981      IF(ll_abort) THEN 
    953          CALL mpi_abort( MPI_COMM_WORLD ) 
     982         CALL mpi_abort( MPI_COMM_WORLD, 123, info ) 
    954983      ELSE 
    955984         CALL mppsync 
    … …  
    964993   SUBROUTINE mpp_comm_free( kcom ) 
    965994      !!---------------------------------------------------------------------- 
    966       INTEGER, INTENT(in) ::   kcom 
     995      INTEGER, INTENT(inout) ::   kcom 
    967996      !! 
    968997      INTEGER :: ierr 
    … …  
    10021031      !!---------------------------------------------------------------------- 
    10031032#if ! defined key_mpi_off 
    1004       !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world 
    1005       !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world 
    1006       !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_oce   : ', mpi_comm_oce 
     1033      !-$$     WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_world     : ', ngrp_world 
     1034      !-$$     WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - mpi_comm_world : ', mpi_comm_world 
     1035      !-$$     WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - mpi_comm_oce   : ', mpi_comm_oce 
    10071036      ! 
    10081037      ALLOCATE( kwork(jpnij), STAT=ierr ) 
    … …  
    10151044         ! 
    10161045         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr ) 
    1017          !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork 
     1046         !-$$        WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - kwork pour njmpp : ', kwork 
    10181047         !-$$        CALL flush(numout) 
    10191048         ! 
    … …  
    10251054            ENDIF 
    10261055         END DO 
    1027          !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl 
     1056         !-$$        WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ndim_rank_znl : ', ndim_rank_znl 
    10281057         !-$$        CALL flush(numout) 
    10291058         ! Allocate the right size to nrank_znl 
    … …  
    10381067            ENDIF 
    10391068         END DO 
    1040          !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl 
     1069         !-$$        WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - nrank_znl : ', nrank_znl 
    10411070         !-$$        CALL flush(numout) 
    10421071 
    10431072         ! Create the opa group 
    10441073         CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr) 
    1045          !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa 
     1074         !-$$        WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_opa : ', ngrp_opa 
    10461075         !-$$        CALL flush(numout) 
    10471076 
    10481077         ! Create the znl group from the opa group 
    10491078         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr ) 
    1050          !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl 
     1079         !-$$        WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_znl ', ngrp_znl 
    10511080         !-$$        CALL flush(numout) 
    10521081 
    10531082         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row 
    10541083         CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr ) 
    1055          !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl 
     1084         !-$$        WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ncomm_znl ', ncomm_znl 
    10561085         !-$$        CALL flush(numout) 
    10571086         ! 
    … …  
    10731102   END SUBROUTINE mpp_ini_znl 
    10741103 
    1075    SUBROUTINE mpp_ini_nc 
     1104    
     1105   SUBROUTINE mpp_ini_nc( khls ) 
    10761106      !!---------------------------------------------------------------------- 
    10771107      !!               ***  routine mpp_ini_nc  *** 
    … …  
    10841114      ! 
    10851115      !! ** output 
    1086       !!         mpi_nc_com = MPI3 neighbourhood collectives communicator 
    1087       !!         mpi_nc_all_com = MPI3 neighbourhood collectives communicator 
    1088       !!                          (with diagonals) 
    1089       !! 
    1090       !!---------------------------------------------------------------------- 
    1091       INTEGER, DIMENSION(:), ALLOCATABLE :: ineigh, ineighalls, ineighallr 
    1092       INTEGER :: ideg, idegalls, idegallr, icont, icont1 
    1093       INTEGER :: ierr 
    1094       LOGICAL, PARAMETER :: ireord = .FALSE. 
    1095  
    1096 #if ! defined key_mpi_off 
    1097  
    1098       ideg = 0 
    1099       idegalls = 0 
    1100       idegallr = 0 
    1101       icont = 0 
    1102       icont1 = 0 
    1103  
    1104       IF (nbondi .eq. 1) THEN 
    1105          ideg = ideg + 1 
    1106       ELSEIF (nbondi .eq. -1) THEN 
    1107          ideg = ideg + 1 
    1108       ELSEIF (nbondi .eq. 0) THEN 
    1109          ideg = ideg + 2 
    1110       ENDIF 
    1111  
    1112       IF (nbondj .eq. 1) THEN 
    1113          ideg = ideg + 1 
    1114       ELSEIF (nbondj .eq. -1) THEN 
    1115          ideg = ideg + 1 
    1116       ELSEIF (nbondj .eq. 0) THEN 
    1117          ideg = ideg + 2 
    1118       ENDIF 
    1119  
    1120       idegalls = ideg 
    1121       idegallr = ideg 
    1122  
    1123       IF (nones .ne. -1) idegalls = idegalls + 1 
    1124       IF (nonws .ne. -1) idegalls = idegalls + 1 
    1125       IF (noses .ne. -1) idegalls = idegalls + 1 
    1126       IF (nosws .ne. -1) idegalls = idegalls + 1 
    1127       IF (noner .ne. -1) idegallr = idegallr + 1 
    1128       IF (nonwr .ne. -1) idegallr = idegallr + 1 
    1129       IF (noser .ne. -1) idegallr = idegallr + 1 
    1130       IF (noswr .ne. -1) idegallr = idegallr + 1 
    1131  
    1132       ALLOCATE(ineigh(ideg)) 
    1133       ALLOCATE(ineighalls(idegalls)) 
    1134       ALLOCATE(ineighallr(idegallr)) 
    1135  
    1136       IF (nbondi .eq. 1) THEN 
    1137          icont = icont + 1 
    1138          ineigh(icont) = nowe 
    1139          ineighalls(icont) = nowe 
    1140          ineighallr(icont) = nowe 
    1141       ELSEIF (nbondi .eq. -1) THEN 
    1142          icont = icont + 1 
    1143          ineigh(icont) = noea 
    1144          ineighalls(icont) = noea 
    1145          ineighallr(icont) = noea 
    1146       ELSEIF (nbondi .eq. 0) THEN 
    1147          icont = icont + 1 
    1148          ineigh(icont) = nowe 
    1149          ineighalls(icont) = nowe 
    1150          ineighallr(icont) = nowe 
    1151          icont = icont + 1 
    1152          ineigh(icont) = noea 
    1153          ineighalls(icont) = noea 
    1154          ineighallr(icont) = noea 
    1155       ENDIF 
    1156  
    1157       IF (nbondj .eq. 1) THEN 
    1158          icont = icont + 1 
    1159          ineigh(icont) = noso 
    1160          ineighalls(icont) = noso 
    1161          ineighallr(icont) = noso 
    1162       ELSEIF (nbondj .eq. -1) THEN 
    1163          icont = icont + 1 
    1164          ineigh(icont) = nono 
    1165          ineighalls(icont) = nono 
    1166          ineighallr(icont) = nono 
    1167       ELSEIF (nbondj .eq. 0) THEN 
    1168          icont = icont + 1 
    1169          ineigh(icont) = noso 
    1170          ineighalls(icont) = noso 
    1171          ineighallr(icont) = noso 
    1172          icont = icont + 1 
    1173          ineigh(icont) = nono 
    1174          ineighalls(icont) = nono 
    1175          ineighallr(icont) = nono 
    1176       ENDIF 
    1177  
    1178       icont1 = icont 
    1179       IF (nosws .ne. -1) THEN 
    1180          icont = icont + 1 
    1181          ineighalls(icont) = nosws 
    1182       ENDIF 
    1183       IF (noses .ne. -1) THEN 
    1184          icont = icont + 1 
    1185          ineighalls(icont) = noses 
    1186       ENDIF 
    1187       IF (nonws .ne. -1) THEN 
    1188          icont = icont + 1 
    1189          ineighalls(icont) = nonws 
    1190       ENDIF 
    1191       IF (nones .ne. -1) THEN 
    1192          icont = icont + 1 
    1193          ineighalls(icont) = nones 
    1194       ENDIF 
    1195       IF (noswr .ne. -1) THEN 
    1196          icont1 = icont1 + 1 
    1197          ineighallr(icont1) = noswr 
    1198       ENDIF 
    1199       IF (noser .ne. -1) THEN 
    1200          icont1 = icont1 + 1 
    1201          ineighallr(icont1) = noser 
    1202       ENDIF 
    1203       IF (nonwr .ne. -1) THEN 
    1204          icont1 = icont1 + 1 
    1205          ineighallr(icont1) = nonwr 
    1206       ENDIF 
    1207       IF (noner .ne. -1) THEN 
    1208          icont1 = icont1 + 1 
    1209          ineighallr(icont1) = noner 
    1210       ENDIF 
    1211  
    1212       CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, ideg, ineigh, MPI_UNWEIGHTED, ideg, ineigh, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_com, ierr) 
    1213       CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, idegallr, ineighallr, MPI_UNWEIGHTED, idegalls, ineighalls, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_all_com, ierr) 
    1214  
    1215       DEALLOCATE (ineigh) 
    1216       DEALLOCATE (ineighalls) 
    1217       DEALLOCATE (ineighallr) 
     1116      !!         mpi_nc_com4 = MPI3 neighbourhood collectives communicator 
     1117      !!         mpi_nc_com8 = MPI3 neighbourhood collectives communicator (with diagonals) 
     1118      !!---------------------------------------------------------------------- 
     1119      INTEGER,             INTENT(in   ) ::   khls        ! halo size, default = nn_hls 
     1120      ! 
     1121      INTEGER, DIMENSION(:), ALLOCATABLE :: iSnei4, iRnei4, iSnei8, iRnei8 
     1122      INTEGER                            :: iScnt4, iRcnt4, iScnt8, iRcnt8 
     1123      INTEGER                            :: ierr 
     1124      LOGICAL, PARAMETER                 :: ireord = .FALSE. 
     1125      !!---------------------------------------------------------------------- 
     1126#if ! defined key_mpi_off && ! defined key_mpi2 
     1127       
     1128      iScnt4 = COUNT( mpiSnei(khls,1:4) >= 0 ) 
     1129      iRcnt4 = COUNT( mpiRnei(khls,1:4) >= 0 ) 
     1130      iScnt8 = COUNT( mpiSnei(khls,1:8) >= 0 ) 
     1131      iRcnt8 = COUNT( mpiRnei(khls,1:8) >= 0 ) 
     1132 
     1133      ALLOCATE( iSnei4(iScnt4), iRnei4(iRcnt4), iSnei8(iScnt8), iRnei8(iRcnt8) )   ! ok if icnt4 or icnt8 = 0 
     1134 
     1135      iSnei4 = PACK( mpiSnei(khls,1:4), mask = mpiSnei(khls,1:4) >= 0 ) 
     1136      iRnei4 = PACK( mpiRnei(khls,1:4), mask = mpiRnei(khls,1:4) >= 0 ) 
     1137      iSnei8 = PACK( mpiSnei(khls,1:8), mask = mpiSnei(khls,1:8) >= 0 ) 
     1138      iRnei8 = PACK( mpiRnei(khls,1:8), mask = mpiRnei(khls,1:8) >= 0 ) 
     1139 
     1140      CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt4, iSnei4, MPI_UNWEIGHTED, iRcnt4, iRnei4, MPI_UNWEIGHTED,   & 
     1141         &                                 MPI_INFO_NULL, ireord, mpi_nc_com4(khls), ierr ) 
     1142      CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt8, iSnei8, MPI_UNWEIGHTED, iRcnt8, iRnei8, MPI_UNWEIGHTED,   & 
     1143         &                                 MPI_INFO_NULL, ireord, mpi_nc_com8(khls), ierr) 
     1144 
     1145      DEALLOCATE( iSnei4, iRnei4, iSnei8, iRnei8 ) 
    12181146#endif 
    12191147   END SUBROUTINE mpp_ini_nc 
    1220  
    12211148 
    12221149 
    … …  
    12341161      !! 
    12351162      !! ** output 
    1236       !!      njmppmax = njmpp for northern procs 
    12371163      !!      ndim_rank_north = number of processors in the northern line 
    12381164      !!      nrank_north (ndim_rank_north) = number  of the northern procs. 
    … …  
    12491175      ! 
    12501176#if ! defined key_mpi_off 
    1251       njmppmax = MAXVAL( njmppt ) 
    12521177      ! 
    12531178      ! Look for how many procs on the northern boundary 
    … …  
    14001325         END DO 
    14011326         IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN 
    1402             WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max)) 
     1327            WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc)) 
    14031328         END IF 
    14041329         WRITE(numcom,*) ' ' 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/mpp_lbc_north_icb_generic.h90

    r14229 r14574  
    3131      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    3232      !                                                     !   = T ,  U , V , F or W -points 
    33       REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
     33      REAL(PRECISION)         , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    3434      !!                                                    ! north fold, =  1. otherwise 
    3535      INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/mpp_lnk_icb_generic.h90

    r13286 r14574  
    2424      !!                    jpi    : first dimension of the local subdomain 
    2525      !!                    jpj    : second dimension of the local subdomain 
     26      !!                    mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 
    2627      !!                    kexti  : number of columns for extra outer halo 
    2728      !!                    kextj  : number of rows for extra outer halo 
    28       !!                    nbondi : mark for "east-west local boundary" 
    29       !!                    nbondj : mark for "north-south local boundary" 
    30       !!                    noea   : number for local neighboring processors 
    31       !!                    nowe   : number for local neighboring processors 
    32       !!                    noso   : number for local neighboring processors 
    33       !!                    nono   : number for local neighboring processors 
    3429      !!---------------------------------------------------------------------- 
    3530      CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine 
    3631      REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    3732      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points 
    38       REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold 
     33      REAL(PRECISION)                                         , INTENT(in   ) ::   psgn     ! sign used across the north fold 
    3934      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width 
    4035      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width 
    … …  
    9085      ! north fold treatment 
    9186      ! ----------------------- 
    92       IF( npolj /= 0 ) THEN 
     87      IF( l_IdoNFold ) THEN 
    9388         ! 
    9489         SELECT CASE ( jpni ) 
    … …  
    10398      ! we play with the neigbours AND the row number because of the periodicity 
    10499      ! 
    105       SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions 
    106       CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case) 
     100      IF( mpinei(jpwe) >= 0 .OR. mpinei(jpea) >= 0 ) THEN   ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) 
    107101         iihom = jpi - (2 * nn_hls) -kexti 
    108102         DO jl = 1, ipreci 
    … …  
    110104            r2dwe(:,jl,1) = pt2d(iihom +jl,:) 
    111105         END DO 
    112       END SELECT 
     106      ENDIF 
    113107      ! 
    114108      !                           ! Migrations 
    … …  
    120114      IF( ln_timing ) CALL tic_tac(.TRUE.) 
    121115      ! 
    122       SELECT CASE ( nbondi ) 
    123       CASE ( -1 ) 
    124          CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 
    125          CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    126          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    127       CASE ( 0 ) 
    128          CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    129          CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 
    130          CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea ) 
    131          CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    132          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    133          CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    134       CASE ( 1 ) 
    135          CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 
    136          CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 
    137          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    138       END SELECT 
     116      IF( mpinei(jpwe) >= 0  )   CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, mpinei(jpwe), ml_req1 ) 
     117      IF( mpinei(jpea) >= 0  )   CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, mpinei(jpea), ml_req2 ) 
     118      IF( mpinei(jpwe) >= 0  )   CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, mpinei(jpwe) ) 
     119      IF( mpinei(jpea) >= 0  )   CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, mpinei(jpea) ) 
     120      IF( mpinei(jpwe) >= 0  )   CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     121      IF( mpinei(jpea) >= 0  )   CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    139122      ! 
    140123      IF( ln_timing ) CALL tic_tac(.FALSE.) 
    … …  
    142125      !                           ! Write Dirichlet lateral conditions 
    143126      iihom = jpi - nn_hls 
    144       ! 
    145       SELECT CASE ( nbondi ) 
    146       CASE ( -1 ) 
     127      IF( mpinei(jpwe) >= 0  ) THEN 
     128         DO jl = 1, ipreci 
     129            pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
     130         END DO 
     131      ENDIF 
     132      IF( mpinei(jpea) >= 0  ) THEN 
    147133         DO jl = 1, ipreci 
    148134            pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    149135         END DO 
    150       CASE ( 0 ) 
    151          DO jl = 1, ipreci 
    152             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    153             pt2d(iihom+jl,:) = r2dew(:,jl,2) 
    154          END DO 
    155       CASE ( 1 ) 
    156          DO jl = 1, ipreci 
    157             pt2d(jl-kexti,:) = r2dwe(:,jl,2) 
    158          END DO 
    159       END SELECT 
    160  
     136      ENDIF 
    161137 
    162138      ! 3. North and south directions 
    … …  
    164140      ! always closed : we play only with the neigbours 
    165141      ! 
    166       IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions 
     142      IF( mpinei(jpso) >= 0 .OR. mpinei(jpno) >= 0 ) THEN   ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) 
    167143         ijhom = jpj - (2 * nn_hls) - kextj 
    168144         DO jl = 1, iprecj 
    … …  
    177153      IF( ln_timing ) CALL tic_tac(.TRUE.) 
    178154      ! 
    179       SELECT CASE ( nbondj ) 
    180       CASE ( -1 ) 
    181          CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 
    182          CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    183          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    184       CASE ( 0 ) 
    185          CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    186          CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 
    187          CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono ) 
    188          CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    189          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    190          CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    191       CASE ( 1 ) 
    192          CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 
    193          CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso ) 
    194          CALL mpi_wait(ml_req1,ml_stat,ml_err) 
    195       END SELECT 
     155      IF( mpinei(jpso) >= 0  )   CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, mpinei(jpso), ml_req1 ) 
     156      IF( mpinei(jpno) >= 0  )   CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, mpinei(jpno), ml_req2 ) 
     157      IF( mpinei(jpso) >= 0  )   CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, mpinei(jpso) ) 
     158      IF( mpinei(jpno) >= 0  )   CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, mpinei(jpno) ) 
     159      IF( mpinei(jpso) >= 0  )   CALL mpi_wait(ml_req1,ml_stat,ml_err) 
     160      IF( mpinei(jpno) >= 0  )   CALL mpi_wait(ml_req2,ml_stat,ml_err) 
    196161      ! 
    197162      IF( ln_timing ) CALL tic_tac(.FALSE.) 
    … …  
    200165      ijhom = jpj - nn_hls 
    201166      ! 
    202       SELECT CASE ( nbondj ) 
    203       CASE ( -1 ) 
    204          DO jl = 1, iprecj 
    205             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    206          END DO 
    207       CASE ( 0 ) 
    208          DO jl = 1, iprecj 
    209             pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    210             pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
    211          END DO 
    212       CASE ( 1 ) 
     167      IF( mpinei(jpso) >= 0  ) THEN 
    213168         DO jl = 1, iprecj 
    214169            pt2d(:,jl-kextj) = r2dsn(:,jl,2) 
    215170         END DO 
    216       END SELECT 
     171      ENDIF 
     172       IF( mpinei(jpno) >= 0  ) THEN 
     173        DO jl = 1, iprecj 
     174            pt2d(:,ijhom+jl) = r2dns(:,jl,2) 
     175         END DO 
     176      ENDIF 
    217177      ! 
    218178   END SUBROUTINE ROUTINE_LNK 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/mpp_nfd_generic.h90

    r14229 r14574  
    1 #if defined MULTI 
    2 #   define NAT_IN(k)                cd_nat(k)    
    3 #   define SGN_IN(k)                psgn(k) 
    4 #   define F_SIZE(ptab)             kfld 
    5 #   define LBC_ARG                  (jf) 
    6 #   if defined DIM_2d 
    7 #      if defined SINGLE_PRECISION 
    8 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp)     , INTENT(inout) ::   ptab(f) 
    9 #      else 
    10 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp)     , INTENT(inout) ::   ptab(f) 
    11 #      endif 
    12 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j) 
    13 #      define K_SIZE(ptab)             1 
    14 #      define L_SIZE(ptab)             1 
    15 #   endif 
    16 #   if defined DIM_3d 
    17 #      if defined SINGLE_PRECISION 
    18 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp)     , INTENT(inout) ::   ptab(f) 
    19 #      else 
    20 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp)     , INTENT(inout) ::   ptab(f) 
    21 #      endif 
    22 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k) 
    23 #      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3) 
    24 #      define L_SIZE(ptab)             1 
    25 #   endif 
    26 #   if defined DIM_4d 
    27 #      if defined SINGLE_PRECISION 
    28 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp)     , INTENT(inout) ::   ptab(f) 
    29 #      else 
    30 #         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp)     , INTENT(inout) ::   ptab(f) 
    31 #      endif 
    32 #      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l) 
    33 #      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3) 
    34 #      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4) 
    35 #   endif 
    36 #else 
    37 !                          !==  IN: ptab is an array  ==! 
    38 #   if defined SINGLE_PRECISION 
    39 #      define ARRAY_TYPE(i,j,k,l,f)    REAL(sp)         , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
    40 #   else 
    41 #      define ARRAY_TYPE(i,j,k,l,f)    REAL(dp)         , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f) 
    42 #   endif 
    43 #   define NAT_IN(k)                cd_nat 
    44 #   define SGN_IN(k)                psgn 
    45 #   define F_SIZE(ptab)             1 
    46 #   define LBC_ARG 
    47 #   if defined DIM_2d 
    48 #      define ARRAY_IN(i,j,k,l,f)   ptab(i,j) 
    49 #      define K_SIZE(ptab)          1 
    50 #      define L_SIZE(ptab)          1 
    51 #   endif 
    52 #   if defined DIM_3d 
    53 #      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k) 
    54 #      define K_SIZE(ptab)          SIZE(ptab,3) 
    55 #      define L_SIZE(ptab)          1 
    56 #   endif 
    57 #   if defined DIM_4d 
    58 #      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l) 
    59 #      define K_SIZE(ptab)          SIZE(ptab,3) 
    60 #      define L_SIZE(ptab)          SIZE(ptab,4) 
    61 #   endif 
    62 #endif 
    631 
    64 # if defined SINGLE_PRECISION 
    65 #    define PRECISION sp 
    66 #    define SENDROUTINE mppsend_sp 
    67 #    define RECVROUTINE mpprecv_sp 
    68 #    define MPI_TYPE MPI_REAL 
    69 #    define HUGEVAL(x)   HUGE(x/**/_sp) 
    70 # else 
    71 #    define PRECISION dp 
    72 #    define SENDROUTINE mppsend_dp 
    73 #    define RECVROUTINE mpprecv_dp 
    74 #    define MPI_TYPE MPI_DOUBLE_PRECISION 
    75 #    define HUGEVAL(x)   HUGE(x/**/_dp) 
    76 # endif 
    77  
    78    SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 
    79       !!---------------------------------------------------------------------- 
    80       ARRAY_TYPE(:,:,:,:,:)   ! array or pointer of arrays on which the boundary condition is applied 
    81       CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points 
    82       REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary 
    83       INTEGER          , INTENT(in   ) ::   kfillmode   ! filling method for halo over land  
    84       REAL(wp)         , INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
    85       INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays 
     2   SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld ) 
     3      TYPE(PTR_4d_/**/PRECISION),  DIMENSION(:), INTENT(inout) ::   ptab        ! pointer of arrays on which apply the b.c. 
     4      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_nat      ! nature of array grid-points 
     5      REAL(PRECISION),  DIMENSION(:), INTENT(in   ) ::   psgn        ! sign used across the north fold boundary 
     6      INTEGER                       , INTENT(in   ) ::   kfillmode   ! filling method for halo over land  
     7      REAL(PRECISION)               , INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries) 
     8      INTEGER                       , INTENT(in   ) ::   khls        ! halo size, default = nn_hls 
     9      INTEGER                       , INTENT(in   ) ::   kfld        ! number of pt3d arrays 
    8610      ! 
    8711      LOGICAL  ::   ll_add_line 
    … …  
    9519      INTEGER, DIMENSION (jpmaxngh)       ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather 
    9620      INTEGER                             ::   ml_err      ! for mpi_isend when avoiding mpi_allgather 
    97       INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat     ! for mpi_isend when avoiding mpi_allgather 
    9821      !                                                    ! Workspace for message transfers avoiding mpi_allgather 
    9922      INTEGER                             ::   ipj_b       ! sum of lines for all multi fields 
    … …  
    10326      INTEGER , DIMENSION(:)          , ALLOCATABLE ::   ipj_s ! number of sent lines 
    10427      REAL(PRECISION), DIMENSION(:,:,:,:)    , ALLOCATABLE ::   ztabb, ztabr, ztabw  ! buffer, receive and work arrays 
    105       REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztabglo, znorthloc 
     28      REAL(PRECISION), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc 
    10629      REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthglo 
     30      TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE ::   ztabglo        ! array or pointer of arrays on which apply the b.c. 
    10731      !!---------------------------------------------------------------------- 
    10832      ! 
    109       ipk = K_SIZE(ptab)   ! 3rd dimension 
    110       ipl = L_SIZE(ptab)   ! 4th    - 
    111       ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers) 
     33      ipk = SIZE(ptab(1)%pt4d,3) 
     34      ipl = SIZE(ptab(1)%pt4d,4) 
     35      ipf = kfld 
    11236      ! 
    113       IF( l_north_nogather ) THEN      !==  no allgather exchanges  ==! 
     37      IF( ln_nnogather ) THEN      !==  no allgather exchanges  ==! 
    11438 
    11539         !   ---   define number of exchanged lines   --- 
    … …  
    11842         ! 
    11943         ! However, some other points are duplicated in the north pole folding: 
    120          !  - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 
    121          !  - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 
    122          !  - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 
    123          !  - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 
    124          !  - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 
    125          !  - jperio=[56], grid=U : no points are duplicated 
    126          !  - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 
    127          !  - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 
     44         !  - c_NFtype='T', grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 
     45         !  - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 
     46         !  - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 
     47         !  - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 
     48         !  - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 
     49         !  - c_NFtype='F', grid=U : no points are duplicated 
     50         !  - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 
     51         !  - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 
    12852         ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 
    12953         ! This explain why these duplicated points may have different values even if they are at the exact same location. 
    … …  
    14165         IF( ll_add_line ) THEN 
    14266            DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
    143                ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) )  
     67               ipj_s(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )  
    14468            END DO 
    14569         ELSE 
    146             ipj_s(:) = nn_hls 
     70            ipj_s(:) = khls 
    14771         ENDIF 
    14872          
    … …  
    15579         DO jf = 1, ipf                      ! Loop over the number of arrays to be processed 
    15680            ! 
    157             SELECT CASE ( npolj ) 
    158             CASE ( 3, 4 )                       ! *  North fold  T-point pivot 
    159                SELECT CASE ( NAT_IN(jf) ) 
     81            IF( c_NFtype == 'T' ) THEN          ! *  North fold  T-point pivot 
     82               SELECT CASE ( cd_nat(jf) ) 
    16083               CASE ( 'T', 'W', 'U' )   ;   i012 = 1   ! T-, U-, W-point 
    16184               CASE ( 'V', 'F'      )   ;   i012 = 2   ! V-, F-point 
    16285               END SELECT 
    163             CASE ( 5, 6 )                       ! *  North fold  F-point pivot 
    164                SELECT CASE ( NAT_IN(jf) ) 
     86            ENDIF 
     87            IF( c_NFtype == 'F' ) THEN          ! *  North fold  F-point pivot 
     88               SELECT CASE ( cd_nat(jf) ) 
    16589               CASE ( 'T', 'W', 'U' )   ;   i012 = 0   ! T-, U-, W-point 
    16690               CASE ( 'V', 'F'      )   ;   i012 = 1   ! V-, F-point 
    16791               END SELECT 
    168             END SELECT 
     92            ENDIF 
    16993               ! 
    17094            DO jj = 1, ipj_s(jf) 
    17195               ij1 = ij1 + 1 
    17296               jj_b(jj,jf) = ij1 
    173                jj_s(jj,jf) = jpj - 2*nn_hls + jj - i012 
     97               jj_s(jj,jf) = jpj - 2*khls + jj - i012 
    17498            END DO 
    17599            ! 
    … …  
    184108               ij2 = jj_s(jj,jf) 
    185109               DO ji = 1, jpi 
    186                   ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 
     110                  ztabb(ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 
    187111               END DO 
    188112               DO ji = jpi+1, jpimax 
    189                   ztabb(ji,ij1,jk,jl) = HUGEVAL(0.)   ! avoid sending uninitialized values (make sure we don't use it) 
     113                  ztabb(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION)   ! avoid sending uninitialized values (make sure we don't use it) 
    190114               END DO 
    191115            END DO 
    … …  
    199123            iproc = nfproc(isendto(jr)) 
    200124            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    201                CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 
     125#if ! defined key_mpi_off 
     126               CALL MPI_ISEND( ztabb, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ml_req_nf(jr), ierr ) 
     127#endif 
    202128            ENDIF 
    203129         END DO 
    … …  
    212138            ipi   = nfjpi (ipni) 
    213139            ! 
    214             IF( ipni ==   1  ) THEN   ;   iis0 =   1            ! domain  left side: as e-w comm already done -> from 1st column 
    215             ELSE                      ;   iis0 =   1 + nn_hls   ! default: -> from inner domain  
    216             ENDIF 
    217             IF( ipni == jpni ) THEN   ;   iie0 = ipi            ! domain right side: as e-w comm already done -> until last column 
    218             ELSE                      ;   iie0 = ipi - nn_hls   ! default: -> until inner domain  
     140            IF( ipni ==   1  ) THEN   ;   iis0 =   1          ! domain  left side: as e-w comm already done -> from 1st column 
     141            ELSE                      ;   iis0 =   1 + khls   ! default: -> from inner domain  
     142            ENDIF 
     143            IF( ipni == jpni ) THEN   ;   iie0 = ipi          ! domain right side: as e-w comm already done -> until last column 
     144            ELSE                      ;   iie0 = ipi - khls   ! default: -> until inner domain  
    219145            ENDIF 
    220146            impp = nfimpp(ipni) - nfimpp(isendto(1)) 
    … …  
    230156                        ij2 = jj_s(jj,jf) 
    231157                        DO ji = iis0, iie0 
    232                            ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf)   ! chose to take the 1st iner domain point 
     158                           ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl)   ! chose to take the 1st iner domain point 
    233159                        END DO 
    234160                     END DO 
    … …  
    251177                     ij2 = jj_s(jj,jf) 
    252178                     DO ji = iis0, iie0 
    253                         ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf) 
     179                        ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 
    254180                     END DO 
    255181                  END DO 
    … …  
    258184            ELSE                               ! get data from a neighbour trough communication 
    259185               !   
    260                CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 
     186#if ! defined key_mpi_off 
     187               CALL MPI_RECV( ztabw, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, MPI_STATUS_IGNORE, ierr ) 
     188#endif 
    261189               DO jl = 1, ipl   ;   DO jk = 1, ipk 
    262190                  DO jj = 1, ipj_b 
    … …  
    278206            ij1 = jj_b(       1 ,jf) 
    279207            ij2 = jj_b(ipj_s(jf),jf) 
    280             CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat LBC_ARG, psgn LBC_ARG ) 
     208            CALL lbc_nfd_nogather( ptab(jf)%pt4d(:,:,:,:), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf), khls ) 
    281209         END DO 
    282210         ! 
    … …  
    286214            iproc = nfproc(isendto(jr)) 
    287215            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 
    288                CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )   ! put the wait at the very end just before the deallocate 
     216               CALL mpi_wait( ml_req_nf(jr), MPI_STATUS_IGNORE, ml_err )   ! put the wait at the very end just before the deallocate 
    289217            ENDIF 
    290218         END DO 
    … …  
    294222         ! 
    295223         ! how many lines do we exchange at max? -> ipj    (no further optimizations in this case...) 
    296          ipj =      nn_hls + 2 
     224         ipj =      khls + 2 
    297225         ! how many lines do we     need at max? -> ipj2   (no further optimizations in this case...) 
    298          ipj2 = 2 * nn_hls + 2 
    299          ! 
    300          i0max = jpimax - 2 * nn_hls 
     226         ipj2 = 2 * khls + 2 
     227         ! 
     228         i0max = jpimax - 2 * khls 
    301229         ibuffsize = i0max * ipj * ipk * ipl * ipf 
    302230         ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) 
    … …  
    307235               DO ji = 1, Ni_0 
    308236                  ii2 = Nis0 - 1 + ji                       ! inner domain: Nis0 to Nie0 
    309                   znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf) 
     237                  znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl) 
    310238               END DO 
    311239               DO ji = Ni_0+1, i0max 
    312                   znorthloc(ji,jj,jk,jl,jf) = HUGEVAL(0.)   ! avoid sending uninitialized values (make sure we don't use it) 
     240                  znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION)   ! avoid sending uninitialized values (make sure we don't use it) 
    313241               END DO 
    314242            END DO 
    … …  
    323251         IF( ln_timing ) CALL tic_tac(.FALSE.) 
    324252         DEALLOCATE( znorthloc ) 
    325          ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) ) 
    326          ! 
    327          ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines 
     253         ALLOCATE( ztabglo(ipf) ) 
     254         DO jf = 1, ipf 
     255            ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) ) 
     256         END DO 
     257         ! 
     258         ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines 
    328259         ijnr = 0 
    329260         DO jr = 1, jpni                                                        ! recover the global north array 
    330261            iproc = nfproc(jr) 
    331262            impp  = nfimpp(jr) 
    332             ipi   = nfjpi( jr) - 2 * nn_hls                       ! corresponds to Ni_0 but for subdomain iproc 
     263            ipi   = nfjpi( jr) - 2 * khls                       ! corresponds to Ni_0 but for subdomain iproc 
    333264            IF( iproc == -1 ) THEN   ! No neighbour (land proc that was suppressed) 
    334265              ! 
    … …  
    340271                        ij2 = jpj - ipj2 + jj                    ! the first ipj lines of the last ipj2 lines 
    341272                        DO ji = 1, ipi 
    342                            ii1 = impp + nn_hls + ji - 1          ! corresponds to mig(nn_hls + ji) but for subdomain iproc 
    343                            ztabglo(ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf)   ! chose to take the 1st iner domain point 
     273                           ii1 = impp + khls + ji - 1            ! corresponds to mig(khls + ji) but for subdomain iproc 
     274                           ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point 
    344275                        END DO 
    345276                     END DO 
    … …  
    349280                     DO jj = 1, ipj 
    350281                        DO ji = 1, ipi 
    351                            ii1 = impp + nn_hls + ji - 1          ! corresponds to mig(nn_hls + ji) but for subdomain iproc 
    352                            ztabglo(ii1,jj,jk,jl,jf) = pfillval 
     282                           ii1 = impp + khls + ji - 1            ! corresponds to mig(khls + ji) but for subdomain iproc 
     283                           ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval 
    353284                        END DO 
    354285                     END DO 
    … …  
    361292                  DO jj = 1, ipj 
    362293                     DO ji = 1, ipi 
    363                         ii1 = impp + nn_hls + ji - 1             ! corresponds to mig(nn_hls + ji) but for subdomain iproc 
    364                         ztabglo(ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr) 
     294                        ii1 = impp + khls + ji - 1               ! corresponds to mig(khls + ji) but for subdomain iproc 
     295                        ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr) 
    365296                     END DO 
    366297                  END DO 
    … …  
    372303         ! 
    373304         DO jf = 1, ipf 
    374             CALL lbc_nfd( ztabglo(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition 
     305            CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 )   ! North fold boundary condition 
    375306            DO jl = 1, ipl   ;   DO jk = 1, ipk                  ! e-w periodicity 
    376                DO jj = 1, nn_hls + 1 
    377                   ij1 = ipj2 - (nn_hls + 1) + jj                 ! need only the last nn_hls + 1 lines until ipj2 
    378                   ztabglo(              1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf) 
    379                   ztabglo(jpiglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo(         nn_hls+1:     2*nn_hls,ij1,jk,jl,jf) 
     307               DO jj = 1, khls + 1 
     308                  ij1 = ipj2 - (khls + 1) + jj                   ! need only the last khls + 1 lines until ipj2 
     309                  ztabglo(jf)%pt4d(            1:  khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl) 
     310                  ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d(         khls+1:     2*khls,ij1,jk,jl) 
    380311               END DO 
    381312            END DO   ;   END DO 
    … …  
    383314         ! 
    384315         DO jf = 1, ipf   ;   DO jl = 1, ipl   ;   DO jk = 1, ipk               ! Scatter back to ARRAY_IN 
    385             DO jj = 1, nn_hls + 1 
    386                ij1 = jpj  - (nn_hls + 1) + jj   ! last nn_hls + 1 lines until jpj 
    387                ij2 = ipj2 - (nn_hls + 1) + jj   ! last nn_hls + 1 lines until ipj2 
     316            DO jj = 1, khls + 1 
     317               ij1 = jpj  - (khls + 1) + jj   ! last khls + 1 lines until jpj 
     318               ij2 = ipj2 - (khls + 1) + jj   ! last khls + 1 lines until ipj2 
    388319               DO ji= 1, jpi 
    389320                  ii2 = mig(ji) 
    390                   ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf) 
     321                  ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl) 
    391322               END DO 
    392323            END DO 
    393324         END DO   ;   END DO   ;   END DO 
    394325         ! 
     326         DO jf = 1, ipf 
     327            DEALLOCATE( ztabglo(jf)%pt4d ) 
     328         END DO 
    395329         DEALLOCATE( ztabglo ) 
    396330         ! 
    397331      ENDIF   ! l_north_nogather 
    398332      ! 
    399    END SUBROUTINE ROUTINE_NFD 
     333   END SUBROUTINE mpp_nfd_/**/PRECISION 
    400334 
    401 #undef PRECISION 
    402 #undef MPI_TYPE 
    403 #undef SENDROUTINE 
    404 #undef RECVROUTINE 
    405 #undef ARRAY_TYPE 
    406 #undef NAT_IN 
    407 #undef SGN_IN 
    408 #undef ARRAY_IN 
    409 #undef K_SIZE 
    410 #undef L_SIZE 
    411 #undef F_SIZE 
    412 #undef LBC_ARG 
    413 #undef HUGEVAL 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LBC/mppini.F90

    r14229 r14574  
    6969      jpi    = jpiglo 
    7070      jpj    = jpjglo 
    71       jpk    = jpkglo 
    72       jpim1  = jpi-1                         ! inner domain indices 
    73       jpjm1  = jpj-1                         !   "           " 
    74       jpkm1  = MAX( 1, jpk-1 )               !   "           " 
     71      jpk    = MAX( 2, jpkglo ) 
    7572      jpij   = jpi*jpj 
    7673      jpni   = 1 
    … …  
    7976      nimpp  = 1 
    8077      njmpp  = 1 
    81       nbondi = 2 
    82       nbondj = 2 
    8378      nidom  = FLIO_DOM_NONE 
    84       npolj = 0 
    85       IF( jperio == 3 .OR. jperio == 4 )   npolj = 3 
    86       IF( jperio == 5 .OR. jperio == 6 )   npolj = 5 
    87       l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 
    88       l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 
    8979      ! 
    9080      CALL init_doloop                       ! set start/end indices or do-loop depending on the halo width value (nn_hls) 
    … …  
    9585         WRITE(numout,*) '~~~~~~~~ ' 
    9686         WRITE(numout,*) '   l_Iperio = ', l_Iperio, '    l_Jperio = ', l_Jperio 
    97          WRITE(numout,*) '     npolj  = ',   npolj , '      njmpp  = ', njmpp 
     87         WRITE(numout,*) '     njmpp  = ', njmpp 
    9888      ENDIF 
    9989      ! 
    … …  
    123113      !! ** Method  :   Global domain is distributed in smaller local domains. 
    124114      !!      Periodic condition is a function of the local domain position 
    125       !!      (global boundary or neighbouring domain) and of the global 
    126       !!      periodic 
    127       !!      Type :         jperio global periodic condition 
     115      !!      (global boundary or neighbouring domain) and of the global periodic 
    128116      !! 
    129117      !! ** Action : - set domain parameters 
    … …  
    131119      !!                    njmpp     : latitudinal  index 
    132120      !!                    narea     : number for local area 
    133       !!                    nbondi    : mark for "east-west local boundary" 
    134       !!                    nbondj    : mark for "north-south local boundary" 
    135       !!                    nproc     : number for local processor 
    136       !!                    noea      : number for local neighboring processor 
    137       !!                    nowe      : number for local neighboring processor 
    138       !!                    noso      : number for local neighboring processor 
    139       !!                    nono      : number for local neighboring processor 
    140       !!---------------------------------------------------------------------- 
    141       INTEGER ::   ji, jj, jn, jproc, jarea   ! dummy loop indices 
    142       INTEGER ::   inijmin 
    143       INTEGER ::   inum                       ! local logical unit 
    144       INTEGER ::   idir, ifreq                ! local integers 
    145       INTEGER ::   ii, il1, ili, imil         !   -       - 
    146       INTEGER ::   ij, il2, ilj, ijm1         !   -       - 
    147       INTEGER ::   iino, ijno, iiso, ijso     !   -       - 
    148       INTEGER ::   iiea, ijea, iiwe, ijwe     !   -       - 
    149       INTEGER ::   iarea0                     !   -       - 
    150       INTEGER ::   ierr, ios                  ! 
    151       INTEGER ::   inbi, inbj, iimax,  ijmax, icnt1, icnt2 
     121      !!                    mpinei    : number of neighboring domains (starting at 0, -1 if no neighbourg) 
     122      !!---------------------------------------------------------------------- 
     123      INTEGER ::   ji, jj, jn, jp, jh 
     124      INTEGER ::   ii, ij, ii2, ij2 
     125      INTEGER ::   inijmin   ! number of oce subdomains 
     126      INTEGER ::   inum, inum0 
     127      INTEGER ::   ifreq, il1, imil, il2, ijm1 
     128      INTEGER ::   ierr, ios 
     129      INTEGER ::   inbi, inbj, iimax, ijmax, icnt1, icnt2 
     130      INTEGER, DIMENSION(16*n_hlsmax) :: ichanged 
     131      INTEGER, ALLOCATABLE, DIMENSION(:    ) ::   iin, ijn 
     132      INTEGER, ALLOCATABLE, DIMENSION(:,:  ) ::   iimppt, ijpi, ipproc 
     133      INTEGER, ALLOCATABLE, DIMENSION(:,:  ) ::   ijmppt, ijpj 
     134      INTEGER, ALLOCATABLE, DIMENSION(:,:  ) ::   impi 
     135      INTEGER, ALLOCATABLE, DIMENSION(:,:,:) ::   inei 
    152136      LOGICAL ::   llbest, llauto 
    153137      LOGICAL ::   llwrtlay 
     138      LOGICAL ::   llmpi_Iperio, llmpi_Jperio, llmpiNFold 
    154139      LOGICAL ::   ln_listonly 
    155       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   iin, ii_nono, ii_noea          ! 1D workspace 
    156       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ijn, ii_noso, ii_nowe          !  -     - 
    157       INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iimppt, ijpi, ibondi, ipproc   ! 2D workspace 
    158       INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   ijmppt, ijpj, ibondj, ipolj    !  -     - 
    159       INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iie0, iis0, iono, ioea         !  -     - 
    160       INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   ije0, ijs0, ioso, iowe         !  -     - 
    161       LOGICAL, ALLOCATABLE, DIMENSION(:,:) ::   llisoce                        !  -     - 
     140      LOGICAL, ALLOCATABLE, DIMENSION(:,:  ) ::   llisOce  ! is not land-domain only? 
     141      LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) ::   llnei    ! are neighbourgs existing? 
    162142      NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file,           & 
    163143           &             ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta,     & 
    … …  
    166146           &             cn_ice, nn_ice_dta,                                     & 
    167147           &             ln_vol, nn_volctl, nn_rimwidth 
    168       NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 
     148      NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly, nn_comm 
    169149      !!---------------------------------------------------------------------- 
    170150      ! 
    … …  
    194174      IF(lwm)   WRITE( numond, nammpp ) 
    195175      ! 
    196 !!!------------------------------------ 
    197 !!!  nn_hls shloud be read in nammpp 
    198 !!!------------------------------------ 
    199176      jpiglo = Ni0glo + 2 * nn_hls 
    200177      jpjglo = Nj0glo + 2 * nn_hls 
    … …  
    214191      ! ----------------------------------- 
    215192      ! 
    216       ! If dimensions of processors grid weren't specified in the namelist file 
     193      ! If dimensions of MPI processes grid weren't specified in the namelist file 
    217194      ! then we calculate them here now that we have our communicator size 
    218195      IF(lwp) THEN 
    … …  
    261238 
    262239      ! look for land mpi subdomains... 
    263       ALLOCATE( llisoce(jpni,jpnj) ) 
    264       CALL mpp_is_ocean( llisoce ) 
    265       inijmin = COUNT( llisoce )   ! number of oce subdomains 
     240      ALLOCATE( llisOce(jpni,jpnj) ) 
     241      CALL mpp_is_ocean( llisOce ) 
     242      inijmin = COUNT( llisOce )   ! number of oce subdomains 
    266243 
    267244      IF( mppsize < inijmin ) THEN   ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... 
    … …  
    3202979003  FORMAT (a, i5) 
    321298 
    322       ALLOCATE(  nfimpp(jpni ) , nfproc(jpni ) ,   nfjpi(jpni ) ,                     & 
    323          &       nimppt(jpnij) , ibonit(jpnij) ,  jpiall(jpnij) ,  jpjall(jpnij) ,    & 
    324          &       njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) ,    & 
    325          &                                       nie0all(jpnij) , nje0all(jpnij) ,    & 
    326          &       iin(jpnij), ii_nono(jpnij), ii_noea(jpnij),   & 
    327          &       ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij),   & 
    328          &       iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj),   & 
    329          &       ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj),  ipolj(jpni,jpnj),   & 
    330          &         iie0(jpni,jpnj), iis0(jpni,jpnj),   iono(jpni,jpnj),   ioea(jpni,jpnj),   & 
    331          &         ije0(jpni,jpnj), ijs0(jpni,jpnj),   ioso(jpni,jpnj),   iowe(jpni,jpnj),   & 
    332          &       STAT=ierr ) 
     299      ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni),   & 
     300         &      iin(jpnij), ijn(jpnij),   & 
     301         &      iimppt(jpni,jpnj), ijmppt(jpni,jpnj), ijpi(jpni,jpnj), ijpj(jpni,jpnj), ipproc(jpni,jpnj),   & 
     302         &      inei(8,jpni,jpnj), llnei(8,jpni,jpnj),   & 
     303         &      impi(8,jpnij),   & 
     304         &      STAT=ierr ) 
    333305      CALL mpp_sum( 'mppini', ierr ) 
    334306      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' ) 
    … …  
    344316      ! 
    345317      CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 
    346       CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 
    347       ! 
    348       !DO jn = 1, jpni 
    349       !   jproc = ipproc(jn,jpnj) 
    350       !   ii = iin(jproc+1) 
    351       !   ij = ijn(jproc+1) 
    352       !   nfproc(jn) = jproc 
    353       !   nfimpp(jn) = iimppt(ii,ij) 
    354       !   nfjpi (jn) =   ijpi(ii,ij) 
    355       !END DO 
    356       nfproc(:) = ipproc(:,jpnj) 
    357       nfimpp(:) = iimppt(:,jpnj) 
    358       nfjpi (:) =   ijpi(:,jpnj) 
     318      CALL mpp_getnum( llisOce, ipproc, iin, ijn ) 
     319      ! 
     320      ii = iin(narea) 
     321      ij = ijn(narea) 
     322      jpi   = ijpi(ii,ij) 
     323      jpj   = ijpj(ii,ij) 
     324      jpk   = MAX( 2, jpkglo ) 
     325      jpij  = jpi*jpj 
     326      nimpp = iimppt(ii,ij) 
     327      njmpp = ijmppt(ii,ij) 
     328      ! 
     329      CALL init_doloop                          ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 
    359330      ! 
    360331      IF(lwp) THEN 
    … …  
    366337         WRITE(numout,*) '      jpnj = ', jpnj 
    367338         WRITE(numout,*) '     jpnij = ', jpnij 
     339         WRITE(numout,*) '     nimpp = ', nimpp 
     340         WRITE(numout,*) '     njmpp = ', njmpp 
    368341         WRITE(numout,*) 
    369342         WRITE(numout,*) '      sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 
    370          WRITE(numout,*) '      sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 
    371       ENDIF 
    372  
    373       ! 3. Subdomain description in the Regular Case 
    374       ! -------------------------------------------- 
    375       ! specific cases where there is no communication -> must do the periodicity by itself 
    376       ! Warning: because of potential land-area suppression, do not use nbond[ij] == 2 
    377       l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 
    378       l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 
    379  
    380       DO jarea = 1, jpni*jpnj 
    381          ! 
    382          iarea0 = jarea - 1 
    383          ii = 1 + MOD(iarea0,jpni) 
    384          ij = 1 +     iarea0/jpni 
    385          ili = ijpi(ii,ij) 
    386          ilj = ijpj(ii,ij) 
    387          ibondi(ii,ij) = 0                         ! default: has e-w neighbours 
    388          IF( ii   ==    1 )   ibondi(ii,ij) = -1   ! first column, has only e neighbour 
    389          IF( ii   == jpni )   ibondi(ii,ij) =  1   ! last column,  has only w neighbour 
    390          IF( jpni ==    1 )   ibondi(ii,ij) =  2   ! has no e-w neighbour 
    391          ibondj(ii,ij) = 0                         ! default: has n-s neighbours 
    392          IF( ij   ==    1 )   ibondj(ii,ij) = -1   ! first row, has only n neighbour 
    393          IF( ij   == jpnj )   ibondj(ii,ij) =  1   ! last row,  has only s neighbour 
    394          IF( jpnj ==    1 )   ibondj(ii,ij) =  2   ! has no n-s neighbour 
    395  
    396          ! Subdomain neighbors (get their zone number): default definition 
    397          ioso(ii,ij) = iarea0 - jpni 
    398          iowe(ii,ij) = iarea0 - 1 
    399          ioea(ii,ij) = iarea0 + 1 
    400          iono(ii,ij) = iarea0 + jpni 
    401          iis0(ii,ij) =  1  + nn_hls 
    402          iie0(ii,ij) = ili - nn_hls 
    403          ijs0(ii,ij) =  1  + nn_hls 
    404          ije0(ii,ij) = ilj - nn_hls 
    405  
    406          ! East-West periodicity: change ibondi, ioea, iowe 
    407          IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 
    408             IF( jpni  /= 1 )   ibondi(ii,ij) = 0                        ! redefine: all have e-w neighbours 
    409             IF( ii ==    1 )   iowe(ii,ij) = iarea0 +        (jpni-1)   ! redefine: first column, address of w neighbour 
    410             IF( ii == jpni )   ioea(ii,ij) = iarea0 -        (jpni-1)   ! redefine: last column,  address of e neighbour 
    411          ENDIF 
    412  
    413          ! Simple North-South periodicity: change ibondj, ioso, iono 
    414          IF( jperio == 2 .OR. jperio == 7 ) THEN 
    415             IF( jpnj  /= 1 )   ibondj(ii,ij) = 0                        ! redefine: all have n-s neighbours 
    416             IF( ij ==    1 )   ioso(ii,ij) = iarea0 + jpni * (jpnj-1)   ! redefine: first row, address of s neighbour 
    417             IF( ij == jpnj )   iono(ii,ij) = iarea0 - jpni * (jpnj-1)   ! redefine: last row,  address of n neighbour 
    418          ENDIF 
    419  
    420          ! North fold: define ipolj, change iono. Warning: we do not change ibondj... 
    421          ipolj(ii,ij) = 0 
    422          IF( jperio == 3 .OR. jperio == 4 ) THEN 
    423             ijm1 = jpni*(jpnj-1) 
    424             imil = ijm1+(jpni+1)/2 
    425             IF( jarea > ijm1 ) ipolj(ii,ij) = 3 
    426             IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4 
    427             IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1   ! MPI rank of northern neighbour 
    428          ENDIF 
    429          IF( jperio == 5 .OR. jperio == 6 ) THEN 
    430             ijm1 = jpni*(jpnj-1) 
    431             imil = ijm1+(jpni+1)/2 
    432             IF( jarea > ijm1) ipolj(ii,ij) = 5 
    433             IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6 
    434             IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1    ! MPI rank of northern neighbour 
    435          ENDIF 
    436          ! 
    437       END DO 
    438  
    439       ! 4. deal with land subdomains 
    440       ! ---------------------------- 
    441       ! 
    442       ! neighbour treatment: change ibondi, ibondj if next to a land zone 
    443       DO jarea = 1, jpni*jpnj 
    444          ii = 1 + MOD( jarea-1  , jpni ) 
    445          ij = 1 +     (jarea-1) / jpni 
    446          ! land-only area with an active n neigbour 
    447          IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN 
    448             iino = 1 + MOD( iono(ii,ij) , jpni )                    ! ii index of this n neigbour 
    449             ijno = 1 +      iono(ii,ij) / jpni                      ! ij index of this n neigbour 
    450             ! In case of north fold exchange: I am the n neigbour of my n neigbour!! (#1057) 
    451             ! --> for northern neighbours of northern row processors (in case of north-fold) 
    452             !     need to reverse the LOGICAL direction of communication 
    453             idir = 1                                           ! we are indeed the s neigbour of this n neigbour 
    454             IF( ij == jpnj .AND. ijno == jpnj )   idir = -1    ! both are on the last row, we are in fact the n neigbour 
    455             IF( ibondj(iino,ijno) == idir     )   ibondj(iino,ijno) =   2     ! this n neigbour had only a s/n neigbour -> no more 
    456             IF( ibondj(iino,ijno) == 0        )   ibondj(iino,ijno) = -idir   ! this n neigbour had both, n-s neighbours -> keep 1 
    457          ENDIF 
    458          ! land-only area with an active s neigbour 
    459          IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN 
    460             iiso = 1 + MOD( ioso(ii,ij) , jpni )                    ! ii index of this s neigbour 
    461             ijso = 1 +      ioso(ii,ij) / jpni                      ! ij index of this s neigbour 
    462             IF( ibondj(iiso,ijso) == -1 )   ibondj(iiso,ijso) = 2   ! this s neigbour had only a n neigbour    -> no more neigbour 
    463             IF( ibondj(iiso,ijso) ==  0 )   ibondj(iiso,ijso) = 1   ! this s neigbour had both, n-s neighbours -> keep s neigbour 
    464          ENDIF 
    465          ! land-only area with an active e neigbour 
    466          IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN 
    467             iiea = 1 + MOD( ioea(ii,ij) , jpni )                    ! ii index of this e neigbour 
    468             ijea = 1 +      ioea(ii,ij) / jpni                      ! ij index of this e neigbour 
    469             IF( ibondi(iiea,ijea) == 1 )   ibondi(iiea,ijea) =  2   ! this e neigbour had only a w neigbour    -> no more neigbour 
    470             IF( ibondi(iiea,ijea) == 0 )   ibondi(iiea,ijea) = -1   ! this e neigbour had both, e-w neighbours -> keep e neigbour 
    471          ENDIF 
    472          ! land-only area with an active w neigbour 
    473          IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN 
    474             iiwe = 1 + MOD( iowe(ii,ij) , jpni )                    ! ii index of this w neigbour 
    475             ijwe = 1 +      iowe(ii,ij) / jpni                      ! ij index of this w neigbour 
    476             IF( ibondi(iiwe,ijwe) == -1 )   ibondi(iiwe,ijwe) = 2   ! this w neigbour had only a e neigbour    -> no more neigbour 
    477             IF( ibondi(iiwe,ijwe) ==  0 )   ibondi(iiwe,ijwe) = 1   ! this w neigbour had both, e-w neighbours -> keep w neigbour 
    478          ENDIF 
    479       END DO 
    480  
    481       ! 5. Subdomain print 
    482       ! ------------------ 
    483       IF(lwp) THEN 
     343         WRITE(numout,*) '      sum ijpj(1,j) = ', SUM(ijpj(1,:)), ' jpjglo = ', jpjglo 
     344          
     345         ! Subdomain grid print 
    484346         ifreq = 4 
    485347         il1 = 1 
    … …  
    504366 9404    FORMAT('           *  '   ,20('     ' ,i4,'   *   ') ) 
    505367      ENDIF 
    506  
    507       ! just to save nono etc for all proc 
    508       ! warning ii*ij (zone) /= nproc (processors)! 
    509       ! ioso = zone number, ii_noso = proc number 
    510       ii_noso(:) = -1 
    511       ii_nono(:) = -1 
    512       ii_noea(:) = -1 
    513       ii_nowe(:) = -1 
    514       DO jproc = 1, jpnij 
    515          ii = iin(jproc) 
    516          ij = ijn(jproc) 
    517          IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 
    518             iiso = 1 + MOD( ioso(ii,ij) , jpni ) 
    519             ijso = 1 +      ioso(ii,ij) / jpni 
    520             ii_noso(jproc) = ipproc(iiso,ijso) 
    521          ENDIF 
    522          IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN 
    523           iiwe = 1 + MOD( iowe(ii,ij) , jpni ) 
    524           ijwe = 1 +      iowe(ii,ij) / jpni 
    525           ii_nowe(jproc) = ipproc(iiwe,ijwe) 
    526          ENDIF 
    527          IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN 
    528             iiea = 1 + MOD( ioea(ii,ij) , jpni ) 
    529             ijea = 1 +      ioea(ii,ij) / jpni 
    530             ii_noea(jproc)= ipproc(iiea,ijea) 
    531          ENDIF 
    532          IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN 
    533             iino = 1 + MOD( iono(ii,ij) , jpni ) 
    534             ijno = 1 +      iono(ii,ij) / jpni 
    535             ii_nono(jproc)= ipproc(iino,ijno) 
    536          ENDIF 
    537       END DO 
    538  
    539       ! 6. Change processor name 
    540       ! ------------------------ 
    541       ii = iin(narea) 
    542       ij = ijn(narea) 
    543       ! 
    544       jpi    = ijpi(ii,ij) 
    545 !!$      Nis0  = iis0(ii,ij) 
    546 !!$      Nie0  = iie0(ii,ij) 
    547       jpj    = ijpj(ii,ij) 
    548 !!$      Njs0  = ijs0(ii,ij) 
    549 !!$      Nje0  = ije0(ii,ij) 
    550       nbondi = ibondi(ii,ij) 
    551       nbondj = ibondj(ii,ij) 
    552       nimpp = iimppt(ii,ij) 
    553       njmpp = ijmppt(ii,ij) 
    554       jpk = jpkglo                              ! third dim 
    555  
    556       ! set default neighbours 
    557       noso = ii_noso(narea) 
    558       nowe = ii_nowe(narea) 
    559       noea = ii_noea(narea) 
    560       nono = ii_nono(narea) 
    561  
    562       nones = -1 
    563       nonws = -1 
    564       noses = -1 
    565       nosws = -1 
    566  
    567       noner = -1 
    568       nonwr = -1 
    569       noser = -1 
    570       noswr = -1 
    571  
    572       IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists 
    573          IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN 
    574             nones = ii_nono(noea+1)                  ! east neighbour has north and south neighbours 
    575             noses = ii_noso(noea+1) 
    576          ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN 
    577             nones = ii_nono(noea+1)                  ! east neighbour has north neighbour 
    578          ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN 
    579             noses = ii_noso(noea+1)                  ! east neighbour has south neighbour 
    580          END IF 
    581       END IF 
    582       IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN  ! west neighbour exists 
    583          IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN 
    584             nonws = ii_nono(nowe+1)                  ! west neighbour has north and south neighbours 
    585             nosws = ii_noso(nowe+1) 
    586          ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN 
    587             nonws = ii_nono(nowe+1)                  ! west neighbour has north neighbour 
    588          ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1)  THEN 
    589             nosws = ii_noso(nowe+1)                  ! west neighbour has north neighbour 
    590          END IF 
    591       END IF 
    592  
    593       IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists 
    594          IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN 
    595             noner = ii_noea(nono+1)                  ! north neighbour has east and west neighbours 
    596             nonwr = ii_nowe(nono+1) 
    597          ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN 
    598             noner = ii_noea(nono+1)                  ! north neighbour has east neighbour 
    599          ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN 
    600             nonwr = ii_nowe(nono+1)                  ! north neighbour has west neighbour 
    601          END IF 
    602       END IF 
    603       IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN  ! south neighbour exists 
    604          IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN 
    605             noser = ii_noea(noso+1)                  ! south neighbour has east and west neighbours 
    606             noswr = ii_nowe(noso+1) 
    607          ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN 
    608             noser = ii_noea(noso+1)                  ! south neighbour has east neighbour 
    609          ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN 
    610             noswr = ii_nowe(noso+1)                  ! south neighbour has west neighbour 
    611          END IF 
    612       END IF 
    613  
    614       ! 
    615       CALL init_doloop                          ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 
    616       ! 
    617       jpim1 = jpi-1                             ! inner domain indices 
    618       jpjm1 = jpj-1                             !   "           " 
    619       jpkm1 = MAX( 1, jpk-1 )                   !   "           " 
    620       jpij  = jpi*jpj                           !  jpi x j 
    621       DO jproc = 1, jpnij 
    622          ii = iin(jproc) 
    623          ij = ijn(jproc) 
    624          jpiall (jproc) = ijpi(ii,ij) 
    625          nis0all(jproc) = iis0(ii,ij) 
    626          nie0all(jproc) = iie0(ii,ij) 
    627          jpjall (jproc) = ijpj(ii,ij) 
    628          njs0all(jproc) = ijs0(ii,ij) 
    629          nje0all(jproc) = ije0(ii,ij) 
    630          ibonit(jproc) = ibondi(ii,ij) 
    631          ibonjt(jproc) = ibondj(ii,ij) 
    632          nimppt(jproc) = iimppt(ii,ij) 
    633          njmppt(jproc) = ijmppt(ii,ij) 
    634       END DO 
    635  
     368      ! 
     369      ! Store informations for the north pole folding communications 
     370      nfproc(:) = ipproc(:,jpnj) 
     371      nfimpp(:) = iimppt(:,jpnj) 
     372      nfjpi (:) =   ijpi(:,jpnj) 
     373      ! 
     374      ! 3. Define Western, Eastern, Southern and Northern neighbors + corners in the subdomain grid reference 
     375      ! ------------------------------------------------------------------------------------------------------ 
     376      ! 
     377      ! note that North fold is has specific treatment for its MPI communications. 
     378      ! This must not be treated as a "usual" communication with a northern neighbor. 
     379      !    -> North fold processes have no Northern neighbor in the definition done bellow 
     380      ! 
     381      llmpi_Iperio = jpni > 1 .AND. l_Iperio                         ! do i-periodicity with an MPI communication? 
     382      llmpi_Jperio = jpnj > 1 .AND. l_Jperio                         ! do j-periodicity with an MPI communication? 
     383      ! 
     384      l_SelfPerio(1:2) = l_Iperio .AND. jpni == 1                    !  west,  east periodicity by itself 
     385      l_SelfPerio(3:4) = l_Jperio .AND. jpnj == 1                    ! south, north periodicity by itself 
     386      l_SelfPerio(5:8) = l_SelfPerio(jpwe) .AND. l_SelfPerio(jpso)   ! corners bi-periodicity by itself 
     387      ! 
     388      ! define neighbors mapping (1/2): default definition: ignore if neighbours are land-only subdomains or not 
     389      DO jj = 1, jpnj 
     390         DO ji = 1, jpni 
     391            ! 
     392            IF ( llisOce(ji,jj) ) THEN                     ! this subdomain has some ocean: it has neighbours 
     393               ! 
     394               inum0 = ji - 1 + ( jj - 1 ) * jpni             ! index in the subdomains grid. start at 0 
     395               ! 
     396               ! Is there a neighbor? 
     397               llnei(jpwe,ji,jj) = ji >   1  .OR. llmpi_Iperio           ! West  nei exists if not the first column or llmpi_Iperio 
     398               llnei(jpea,ji,jj) = ji < jpni .OR. llmpi_Iperio           ! East  nei exists if not the last  column or llmpi_Iperio 
     399               llnei(jpso,ji,jj) = jj >   1  .OR. llmpi_Jperio           ! South nei exists if not the first line   or llmpi_Jperio 
     400               llnei(jpno,ji,jj) = jj < jpnj .OR. llmpi_Jperio           ! North nei exists if not the last  line   or llmpi_Jperio 
     401               llnei(jpsw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpso,ji,jj)   ! So-We nei exists if both South and West nei exist 
     402               llnei(jpse,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpso,ji,jj)   ! So-Ea nei exists if both South and East nei exist 
     403               llnei(jpnw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpno,ji,jj)   ! No-We nei exists if both North and West nei exist 
     404               llnei(jpne,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpno,ji,jj)   ! No-Ea nei exists if both North and East nei exist 
     405               ! 
     406               ! Which index (starting at 0) have neighbors in the subdomains grid? 
     407               IF( llnei(jpwe,ji,jj) )   inei(jpwe,ji,jj) =            inum0 -    1 + jpni        * COUNT( (/ ji ==    1 /) ) 
     408               IF( llnei(jpea,ji,jj) )   inei(jpea,ji,jj) =            inum0 +    1 - jpni        * COUNT( (/ ji == jpni /) ) 
     409               IF( llnei(jpso,ji,jj) )   inei(jpso,ji,jj) =            inum0 - jpni + jpni * jpnj * COUNT( (/ jj ==    1 /) ) 
     410               IF( llnei(jpno,ji,jj) )   inei(jpno,ji,jj) =            inum0 + jpni - jpni * jpnj * COUNT( (/ jj == jpnj /) ) 
     411               IF( llnei(jpsw,ji,jj) )   inei(jpsw,ji,jj) = inei(jpso,ji,jj) -    1 + jpni        * COUNT( (/ ji ==    1 /) ) 
     412               IF( llnei(jpse,ji,jj) )   inei(jpse,ji,jj) = inei(jpso,ji,jj) +    1 - jpni        * COUNT( (/ ji == jpni /) ) 
     413               IF( llnei(jpnw,ji,jj) )   inei(jpnw,ji,jj) = inei(jpno,ji,jj) -    1 + jpni        * COUNT( (/ ji ==    1 /) ) 
     414               IF( llnei(jpne,ji,jj) )   inei(jpne,ji,jj) = inei(jpno,ji,jj) +    1 - jpni        * COUNT( (/ ji == jpni /) ) 
     415               ! 
     416            ELSE                                           ! land-only domain has no neighbour 
     417               llnei(:,ji,jj) = .FALSE. 
     418            ENDIF 
     419            ! 
     420         END DO 
     421      END DO 
     422      ! 
     423      ! define neighbors mapping (2/2): check if neighbours are not land-only subdomains 
     424      DO jj = 1, jpnj 
     425         DO ji = 1, jpni 
     426            DO jn = 1, 8 
     427               IF( llnei(jn,ji,jj) ) THEN   ! if a neighbour is existing -> this should not be a land-only domain 
     428                  ii = 1 + MOD( inei(jn,ji,jj) , jpni ) 
     429                  ij = 1 +      inei(jn,ji,jj) / jpni 
     430                  llnei(jn,ji,jj) = llisOce( ii, ij ) 
     431               ENDIF 
     432            END DO 
     433         END DO 
     434      END DO 
     435      ! 
     436      ! update index of the neighbours in the subdomains grid 
     437      WHERE( .NOT. llnei )   inei = -1 
     438      ! 
    636439      ! Save processor layout in ascii file 
    637440      IF (llwrtlay) THEN 
    638441         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
    639          WRITE(inum,'(a)') '   jpnij   jpimax  jpjmax    jpk  jpiglo  jpjglo'//& 
    640    &           ' ( local:    narea     jpi     jpj )' 
    641          WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 
    642    &           ' ( local: ',narea,jpi,jpj,' )' 
    643          WRITE(inum,'(a)') 'nproc   jpi  jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 
    644  
    645          DO jproc = 1, jpnij 
    646             WRITE(inum,'(13i5,2i7)')   jproc-1,  jpiall(jproc),  jpjall(jproc),   & 
    647                &                                nis0all(jproc), njs0all(jproc),   & 
    648                &                                nie0all(jproc), nje0all(jproc),   & 
    649                &                                nimppt (jproc), njmppt (jproc),   & 
    650                &                                ii_nono(jproc), ii_noso(jproc),   & 
    651                &                                ii_nowe(jproc), ii_noea(jproc),   & 
    652                &                                ibonit (jproc), ibonjt (jproc) 
     442         WRITE(inum,'(a)') '  jpnij jpimax jpjmax    jpk jpiglo jpjglo ( local:   narea    jpi    jpj )' 
     443         WRITE(inum,'(6i7,a,3i7,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,' ( local: ',narea,jpi,jpj,' )' 
     444         WRITE(inum,*)  
     445         WRITE(inum,       *) '------------------------------------' 
     446         WRITE(inum,'(a,i2)') ' Mapping of the default neighnourgs ' 
     447         WRITE(inum,       *) '------------------------------------' 
     448         WRITE(inum,*)  
     449         WRITE(inum,'(a)') '  rank    ii    ij   jpi   jpj nimpp njmpp mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 
     450         DO jp = 1, jpnij 
     451            ii = iin(jp) 
     452            ij = ijn(jp) 
     453            WRITE(inum,'(15i6)')  jp-1, ii, ij, ijpi(ii,ij), ijpj(ii,ij), iimppt(ii,ij), ijmppt(ii,ij), inei(:,ii,ij) 
    653454         END DO 
    654       END IF 
    655  
    656       !                          ! north fold parameter 
    657       ! Defined npolj, either 0, 3 , 4 , 5 , 6 
    658       ! In this case the important thing is that npolj /= 0 
    659       ! Because if we go through these line it is because jpni >1 and thus 
    660       ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0 
    661       npolj = 0 
    662       ij = ijn(narea) 
    663       IF( jperio == 3 .OR. jperio == 4 ) THEN 
    664          IF( ij == jpnj )   npolj = 3 
    665       ENDIF 
    666       IF( jperio == 5 .OR. jperio == 6 ) THEN 
    667          IF( ij == jpnj )   npolj = 5 
    668       ENDIF 
    669       ! 
    670       nproc = narea-1 
     455      ENDIF 
     456 
     457      ! 
     458      ! 4. Define Western, Eastern, Southern and Northern neighbors + corners for each mpi process 
     459      ! ------------------------------------------------------------------------------------------ 
     460      !  
     461      ! rewrite information from "subdomain grid" to mpi process list 
     462      ! Warning, for example: 
     463      !    position of the northern neighbor in the "subdomain grid" 
     464      !    position of the northern neighbor in the "mpi process list" 
     465       
     466      ! default definition: no neighbors 
     467      impi(:,:) = -1   ! (starting at 0, -1 if no neighbourg) 
     468       
     469      DO jp = 1, jpnij 
     470         ii = iin(jp) 
     471         ij = ijn(jp) 
     472         DO jn = 1, 8 
     473            IF( llnei(jn,ii,ij) ) THEN   ! must be tested as some land-domain can be kept to fit mppsize 
     474               ii2 = 1 + MOD( inei(jn,ii,ij) , jpni ) 
     475               ij2 = 1 +      inei(jn,ii,ij) / jpni 
     476               impi(jn,jp) = ipproc( ii2, ij2 ) 
     477            ENDIF 
     478         END DO 
     479      END DO 
     480 
     481      ! 
     482      ! 4. keep information for the local process 
     483      ! ----------------------------------------- 
     484      ! 
     485      ! set default neighbours 
     486      mpinei(:) = impi(:,narea) 
     487      DO jh = 1, n_hlsmax 
     488         mpiSnei(jh,:) = impi(:,narea)   ! default definition 
     489         mpiRnei(jh,:) = impi(:,narea) 
     490      END DO 
     491      ! 
    671492      IF(lwp) THEN 
    672493         WRITE(numout,*) 
    673494         WRITE(numout,*) '   resulting internal parameters : ' 
    674          WRITE(numout,*) '      nproc  = ', nproc 
    675          WRITE(numout,*) '      nowe   = ', nowe  , '   noea  =  ', noea 
    676          WRITE(numout,*) '      nono   = ', nono  , '   noso  =  ', noso 
    677          WRITE(numout,*) '      nbondi = ', nbondi 
    678          WRITE(numout,*) '      nbondj = ', nbondj 
    679          WRITE(numout,*) '      npolj  = ', npolj 
    680          WRITE(numout,*) '    l_Iperio = ', l_Iperio 
    681          WRITE(numout,*) '    l_Jperio = ', l_Jperio 
    682          WRITE(numout,*) '      nimpp  = ', nimpp 
    683          WRITE(numout,*) '      njmpp  = ', njmpp 
    684       ENDIF 
    685  
     495         WRITE(numout,*) '      narea = ', narea 
     496         WRITE(numout,*) '      mpi nei  west = ', mpinei(jpwe)  , '   mpi nei  east = ', mpinei(jpea) 
     497         WRITE(numout,*) '      mpi nei south = ', mpinei(jpso)  , '   mpi nei north = ', mpinei(jpno) 
     498         WRITE(numout,*) '      mpi nei so-we = ', mpinei(jpsw)  , '   mpi nei so-ea = ', mpinei(jpse) 
     499         WRITE(numout,*) '      mpi nei no-we = ', mpinei(jpnw)  , '   mpi nei no-ea = ', mpinei(jpne) 
     500      ENDIF 
    686501      !                          ! Prepare mpp north fold 
    687       IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     502      ! 
     503      llmpiNFold =          jpni  > 1 .AND. l_NFold   ! is the North fold done with an MPI communication? 
     504      l_IdoNFold = ijn(narea) == jpnj .AND. l_NFold   ! is this process doing North fold? 
     505      ! 
     506      IF( llmpiNFold ) THEN 
    688507         CALL mpp_ini_north 
    689508         IF (lwp) THEN 
    690509            WRITE(numout,*) 
    691510            WRITE(numout,*) '   ==>>>   North fold boundary prepared for jpni >1' 
    692             ! additional prints in layout.dat 
    693          ENDIF 
    694          IF (llwrtlay) THEN 
     511         ENDIF 
     512         IF (llwrtlay) THEN      ! additional prints in layout.dat 
    695513            WRITE(inum,*) 
    696514            WRITE(inum,*) 
    697             WRITE(inum,*) 'number of subdomains located along the north fold : ', ndim_rank_north 
     515            WRITE(inum,*) 'Number of subdomains located along the north fold : ', ndim_rank_north 
    698516            WRITE(inum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north 
    699             DO jproc = 1, ndim_rank_north, 5 
    700                WRITE(inum,*) nrank_north( jproc:MINVAL( (/jproc+4,ndim_rank_north/) ) ) 
     517            DO jp = 1, ndim_rank_north, 5 
     518               WRITE(inum,*) nrank_north( jp:MINVAL( (/jp+4,ndim_rank_north/) ) ) 
    701519            END DO 
    702520         ENDIF 
    703       ENDIF 
    704  
    705       ! 
    706       CALL mpp_ini_nc        ! Initialize communicator for neighbourhood collective communications 
    707       ! 
    708       CALL init_ioipsl       ! Prepare NetCDF output file (if necessary) 
    709       ! 
    710       IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 
    711          CALL init_nfdcom     ! northfold neighbour lists 
    712          IF (llwrtlay) THEN 
    713             WRITE(inum,*) 
    714             WRITE(inum,*) 
    715             WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 
    716             WRITE(inum,*) 'nsndto : ', nsndto 
    717             WRITE(inum,*) 'isendto : ', isendto 
    718          ENDIF 
    719       ENDIF 
     521         IF ( l_IdoNFold .AND. ln_nnogather ) THEN 
     522            CALL init_nfdcom     ! northfold neighbour lists 
     523            IF (llwrtlay) THEN 
     524               WRITE(inum,*) 
     525               WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 
     526               WRITE(inum,*) '   nsndto  : ', nsndto 
     527               WRITE(inum,*) '   isendto : ', isendto(1:nsndto) 
     528            ENDIF 
     529         ENDIF 
     530      ENDIF 
     531      ! 
     532      CALL mpp_ini_nc(nn_hls)    ! Initialize communicator for neighbourhood collective communications 
     533      DO jh = 1, n_hlsmax 
     534         mpi_nc_com4(jh) = mpi_nc_com4(nn_hls)   ! default definition 
     535         mpi_nc_com8(jh) = mpi_nc_com8(nn_hls) 
     536      END DO 
     537      ! 
     538      CALL init_excl_landpt      ! exclude exchanges which contain only land points 
     539      ! 
     540      ! Save processor layout changes in ascii file 
     541      DO jh = 1, n_hlsmax    ! different halo size 
     542         DO ji = 1, 8 
     543            ichanged(16*(jh-1)  +ji) = COUNT( mpinei(ji:ji) /= mpiSnei(jh,ji:ji) ) 
     544            ichanged(16*(jh-1)+8+ji) = COUNT( mpinei(ji:ji) /= mpiRnei(jh,ji:ji) ) 
     545         END DO 
     546      END DO 
     547      CALL mpp_sum( "mpp_init", ichanged )   ! must be called by all processes 
     548      IF (llwrtlay) THEN 
     549         WRITE(inum,*)  
     550         WRITE(inum,       *) '----------------------------------------------------------------------' 
     551         WRITE(inum,'(a,i2)') ' Mapping of the neighnourgs once excluding comm with only land points ' 
     552         WRITE(inum,       *) '----------------------------------------------------------------------' 
     553         DO jh = 1, n_hlsmax    ! different halo size 
     554            WRITE(inum,*)  
     555            WRITE(inum,'(a,i2)') 'halo size: ', jh 
     556            WRITE(inum,       *) '---------' 
     557            WRITE(inum,'(a)') '  rank    ii    ij mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 
     558            WRITE(inum,   '(11i6,a)')  narea-1, iin(narea), ijn(narea),   mpinei(:), ' <- Org' 
     559            WRITE(inum,'(18x,8i6,a,i1,a)')   mpiSnei(jh,:), ' <- Send ', COUNT( mpinei(:) /= mpiSnei(jh,:) ), ' modif' 
     560            WRITE(inum,'(18x,8i6,a,i1,a)')   mpiRnei(jh,:), ' <- Recv ', COUNT( mpinei(:) /= mpiRnei(jh,:) ), ' modif' 
     561            WRITE(inum,*) ' total changes among all mpi tasks:' 
     562            WRITE(inum,*) '       mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 
     563            WRITE(inum,'(a,8i6)') ' Send: ', ichanged(jh*16-15:jh*16-8) 
     564            WRITE(inum,'(a,8i6)') ' Recv: ', ichanged(jh*16 -7:jh*16  ) 
     565         END DO 
     566      ENDIF 
     567      ! 
     568      CALL init_ioipsl           ! Prepare NetCDF output file (if necessary) 
    720569      ! 
    721570      IF (llwrtlay) CLOSE(inum) 
    722571      ! 
    723       DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe,    & 
    724          &       iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj,   & 
    725          &       ijpi, ijpj, iie0, ije0, iis0, ijs0,              & 
    726          &       iono, ioea, ioso, iowe, llisoce) 
     572      DEALLOCATE(iin, ijn, iimppt, ijmppt, ijpi, ijpj, ipproc, inei, llnei, impi, llisOce) 
    727573      ! 
    728574    END SUBROUTINE mpp_init 
    … …  
    791637        CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 
    792638      ENDIF 
    793       IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN 
     639      IF( l_NFold ) THEN 
    794640         ! minimize the size of the last row to compensate for the north pole folding coast 
    795          IF( jperio == 3 .OR. jperio == 4 )   ijpjmin = 2+3*khls   ! V and F folding must be outside of southern halos 
    796          IF( jperio == 5 .OR. jperio == 6 )   ijpjmin = 1+3*khls   ! V and F folding must be outside of southern halos 
    797          irm = knbj - irestj                                       ! total number of lines to be removed 
    798          klcj(:,knbj) = MAX( ijpjmin, kjmax-irm )                  ! we must have jpj >= ijpjmin in the last row 
    799          irm = irm - ( kjmax - klcj(1,knbj) )                      ! remaining number of lines to remove 
     641         IF( c_NFtype == 'T' )   ijpjmin = 2+3*khls   ! V and F folding must be outside of southern halos 
     642         IF( c_NFtype == 'F' )   ijpjmin = 1+3*khls   ! V and F folding must be outside of southern halos 
     643         irm = knbj - irestj                          ! total number of lines to be removed 
     644         klcj(:,knbj) = MAX( ijpjmin, kjmax-irm )     ! we must have jpj >= ijpjmin in the last row 
     645         irm = irm - ( kjmax - klcj(1,knbj) )         ! remaining number of lines to remove 
    800646         irestj = knbj - 1 - irm 
    801647         klcj(:, irestj+1:knbj-1) = kjmax-1 
    … …  
    862708      LOGICAL :: llist 
    863709      LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d                 ! max size of the subdomains along i,j 
    864       LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisoce              !  -     - 
     710      LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisOce              !  -     - 
    865711      REAL(wp)::   zpropland 
    866712      !!---------------------------------------------------------------------- 
    … …  
    885731      iszimin = 4*nn_hls          ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 
    886732      iszjmin = 4*nn_hls 
    887       IF( jperio == 3 .OR. jperio == 4 )   iszjmin = MAX(iszjmin, 2+3*nn_hls)   ! V and F folding must be outside of southern halos 
    888       IF( jperio == 5 .OR. jperio == 6 )   iszjmin = MAX(iszjmin, 1+3*nn_hls)   ! V and F folding must be outside of southern halos 
     733      IF( c_NFtype == 'T' )   iszjmin = MAX(iszjmin, 2+3*nn_hls)   ! V and F folding must be outside of southern halos 
     734      IF( c_NFtype == 'F' )   iszjmin = MAX(iszjmin, 1+3*nn_hls)   ! V and F folding must be outside of southern halos 
    889735      ! 
    890736      ! get the list of knbi that gives a smaller jpimax than knbi-1 
    … …  
    935781               iszi1(ii) = iszi0(ji) 
    936782               iszj1(ii) = iszj0(jj) 
    937             END IF 
     783            ENDIF 
    938784         END DO 
    939785      END DO 
    … …  
    991837            WRITE(numout,*) '  -----------------------------------------------------' 
    992838            WRITE(numout,*) 
    993          END IF 
     839         ENDIF 
    994840         ji = isz0   ! initialization with the largest value 
    995          ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 
    996          CALL mpp_is_ocean( llisoce )   ! Warning: must be call by all cores (call mpp_sum) 
    997          inbijold = COUNT(llisoce) 
    998          DEALLOCATE( llisoce ) 
     841         ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) 
     842         CALL mpp_is_ocean( llisOce )   ! Warning: must be call by all cores (call mpp_sum) 
     843         inbijold = COUNT(llisOce) 
     844         DEALLOCATE( llisOce ) 
    999845         DO ji =isz0-1,1,-1 
    1000             ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 
    1001             CALL mpp_is_ocean( llisoce )   ! Warning: must be call by all cores (call mpp_sum) 
    1002             inbij = COUNT(llisoce) 
    1003             DEALLOCATE( llisoce ) 
     846            ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) 
     847            CALL mpp_is_ocean( llisOce )   ! Warning: must be call by all cores (call mpp_sum) 
     848            inbij = COUNT(llisOce) 
     849            DEALLOCATE( llisOce ) 
    1004850            IF(lwp .AND. inbij < inbijold) THEN 
    1005851               WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)')                                 & 
    … …  
    1008854                  &   '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 
    1009855               inbijold = inbij 
    1010             END IF 
     856            ENDIF 
    1011857         END DO 
    1012858         DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) 
    … …  
    1024870      DO WHILE( inbij > knbij )   ! while the number of ocean subdomains exceed the number of procs 
    1025871         ii = ii -1 
    1026          ALLOCATE( llisoce(inbi0(ii), inbj0(ii)) ) 
    1027          CALL mpp_is_ocean( llisoce )            ! must be done by all core 
    1028          inbij = COUNT(llisoce) 
    1029          DEALLOCATE( llisoce ) 
     872         ALLOCATE( llisOce(inbi0(ii), inbj0(ii)) ) 
     873         CALL mpp_is_ocean( llisOce )            ! must be done by all core 
     874         inbij = COUNT(llisOce) 
     875         DEALLOCATE( llisOce ) 
    1030876      END DO 
    1031877      knbi = inbi0(ii) 
    … …  
    1075921         ! 
    1076922         ALLOCATE( lloce(Ni0glo, ijsz) )                                     ! allocate the strip 
    1077          CALL readbot_strip( ijstr, ijsz, lloce ) 
     923         CALL read_mask( 1, ijstr, Ni0glo, ijsz, lloce ) 
    1078924         inboce = COUNT(lloce)                                               ! number of ocean point in the stripe 
    1079925         DEALLOCATE(lloce) 
    … …  
    1089935 
    1090936 
    1091    SUBROUTINE mpp_is_ocean( ldisoce ) 
     937   SUBROUTINE mpp_is_ocean( ldIsOce ) 
    1092938      !!---------------------------------------------------------------------- 
    1093939      !!                  ***  ROUTINE mpp_is_ocean  *** 
    … …  
    1097943      !!              at least 1 ocean point. 
    1098944      !!              We must indeed ensure that each subdomain that is a neighbour 
    1099       !!              of a land subdomain as only land points on its boundary 
     945      !!              of a land subdomain, has only land points on its boundary 
    1100946      !!              (inside the inner subdomain) with the land subdomain. 
    1101947      !!              This is needed to get the proper bondary conditions on 
    … …  
    1104950      !! ** Method  : read inbj strips (of length Ni0glo) of the land-sea mask 
    1105951      !!---------------------------------------------------------------------- 
    1106       LOGICAL, DIMENSION(:,:), INTENT(  out) ::   ldisoce        ! .true. if a sub domain constains 1 ocean point 
     952      LOGICAL, DIMENSION(:,:), INTENT(  out) ::   ldIsOce        ! .true. if a sub domain constains 1 ocean point 
    1107953      ! 
    1108954      INTEGER :: idiv, iimax, ijmax, iarea 
    … …  
    1117963      ! do nothing if there is no land-sea mask 
    1118964      IF( numbot == -1 .AND. numbdy == -1 ) THEN 
    1119          ldisoce(:,:) = .TRUE. 
     965         ldIsOce(:,:) = .TRUE. 
    1120966         RETURN 
    1121967      ENDIF 
    1122968      ! 
    1123       inbi = SIZE( ldisoce, dim = 1 ) 
    1124       inbj = SIZE( ldisoce, dim = 2 ) 
     969      inbi = SIZE( ldIsOce, dim = 1 ) 
     970      inbj = SIZE( ldIsOce, dim = 2 ) 
    1125971      ! 
    1126972      ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 
    … …  
    1145991            inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) )      ! number of point to read in y-direction 
    1146992            isty = 1 + COUNT( (/ iarea == 1 /) )                       ! read from the first or the second line? 
    1147             CALL readbot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) )   ! read the strip 
     993            CALL read_mask( 1, ijmppt(1,iarea) - 2 + isty, Ni0glo, inry, lloce(2:inx-1, isty:inry+isty-1) )   ! read the strip 
    1148994            ! 
    1149995            IF( iarea == 1    ) THEN                                   ! the first line was not read 
    1150                IF( jperio == 2 .OR. jperio == 7 ) THEN                 !   north-south periodocity 
    1151                   CALL readbot_strip( Nj0glo, 1, lloce(2:inx-1, 1) )   !   read the last line -> first line of lloce 
     996               IF( l_Jperio ) THEN                                     !   north-south periodocity 
     997                  CALL read_mask( 1, Nj0glo, Ni0glo, 1, lloce(2:inx-1, 1) )   !   read the last line -> first line of lloce 
    1152998               ELSE 
    1153999                  lloce(2:inx-1,  1) = .FALSE.                         !   closed boundary 
    … …  
    11551001            ENDIF 
    11561002            IF( iarea == inbj ) THEN                                   ! the last line was not read 
    1157                IF( jperio == 2 .OR. jperio == 7 ) THEN                 !   north-south periodocity 
    1158                   CALL readbot_strip( 1, 1, lloce(2:inx-1,iny) )       !      read the first line -> last line of lloce 
    1159                ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN             !   north-pole folding T-pivot, T-point 
     1003               IF( l_Jperio ) THEN                                     !   north-south periodocity 
     1004                  CALL read_mask( 1, 1, Ni0glo, 1, lloce(2:inx-1,iny) )   !      read the first line -> last line of lloce 
     1005               ELSEIF( c_NFtype == 'T' ) THEN                          !   north-pole folding T-pivot, T-point 
    11601006                  lloce(2,iny) = lloce(2,iny-2)                        !      here we have 1 halo (even if nn_hls>1) 
    11611007                  DO ji = 3,inx-1 
    … …  
    11651011                     lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 
    11661012                  END DO 
    1167                ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN             !   north-pole folding F-pivot, T-point, 1 halo 
     1013               ELSEIF( c_NFtype == 'F' ) THEN                          !   north-pole folding F-pivot, T-point, 1 halo 
    11681014                  lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1)            !      here we have 1 halo (even if nn_hls>1) 
    11691015                  lloce(inx  -1,iny-1) = lloce(2    ,iny-1) 
    … …  
    11761022            ENDIF 
    11771023            !                                                          ! first and last column were not read 
    1178             IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 
     1024            IF( l_Iperio ) THEN 
    11791025               lloce(1,:) = lloce(inx-1,:)   ;   lloce(inx,:) = lloce(2,:)   ! east-west periodocity 
    11801026            ELSE 
    … …  
    11951041      CALL mpp_sum( 'mppini', inboce_1d ) 
    11961042      inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 
    1197       ldisoce(:,:) = inboce(:,:) /= 0 
     1043      ldIsOce(:,:) = inboce(:,:) /= 0 
    11981044      DEALLOCATE(inboce, inboce_1d) 
    11991045      ! 
    … …  
    12011047 
    12021048 
    1203    SUBROUTINE readbot_strip( kjstr, kjcnt, ldoce ) 
    1204       !!---------------------------------------------------------------------- 
    1205       !!                  ***  ROUTINE readbot_strip  *** 
     1049   SUBROUTINE read_mask( kistr, kjstr, kicnt, kjcnt, ldoce ) 
     1050      !!---------------------------------------------------------------------- 
     1051      !!                  ***  ROUTINE read_mask  *** 
    12061052      !! 
    12071053      !! ** Purpose : Read relevant bathymetric information in order to 
    … …  
    12111057      !! ** Method  : read stipe of size (Ni0glo,...) 
    12121058      !!---------------------------------------------------------------------- 
    1213       INTEGER                         , INTENT(in   ) ::   kjstr       ! starting j position of the reading 
    1214       INTEGER                         , INTENT(in   ) ::   kjcnt       ! number of lines to read 
    1215       LOGICAL, DIMENSION(Ni0glo,kjcnt), INTENT(  out) ::   ldoce       ! ldoce(i,j) = .true. if the point (i,j) is ocean 
    1216       ! 
    1217       INTEGER                           ::   inumsave                ! local logical unit 
    1218       REAL(wp), DIMENSION(Ni0glo,kjcnt) ::   zbot, zbdy 
     1059      INTEGER                        , INTENT(in   ) ::   kistr, kjstr   ! starting i and j position of the reading 
     1060      INTEGER                        , INTENT(in   ) ::   kicnt, kjcnt   ! number of points to read in i and j directions 
     1061      LOGICAL, DIMENSION(kicnt,kjcnt), INTENT(  out) ::   ldoce          ! ldoce(i,j) = .true. if the point (i,j) is ocean 
     1062      ! 
     1063      INTEGER                          ::   inumsave                     ! local logical unit 
     1064      REAL(wp), DIMENSION(kicnt,kjcnt) ::   zbot, zbdy 
    12191065      !!---------------------------------------------------------------------- 
    12201066      ! 
    … …  
    12221068      ! 
    12231069      IF( numbot /= -1 ) THEN 
    1224          CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 
     1070         CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) 
    12251071      ELSE 
    12261072         zbot(:,:) = 1._wp                      ! put a non-null value 
    … …  
    12281074      ! 
    12291075      IF( numbdy /= -1 ) THEN                   ! Adjust with bdy_msk if it exists 
    1230          CALL iom_get ( numbdy, jpdom_unknown,     'bdy_msk', zbdy, kstart = (/1,kjstr/), kcount = (/Ni0glo, kjcnt/) ) 
     1076         CALL iom_get ( numbdy, jpdom_unknown,     'bdy_msk', zbdy, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) 
    12311077         zbot(:,:) = zbot(:,:) * zbdy(:,:) 
    12321078      ENDIF 
    12331079      ! 
    1234       ldoce(:,:) = zbot(:,:) > 0._wp 
     1080      ldoce(:,:) = NINT(zbot(:,:)) > 0 
    12351081      numout = inumsave 
    12361082      ! 
    1237    END SUBROUTINE readbot_strip 
    1238  
    1239  
    1240    SUBROUTINE mpp_getnum( ldisoce, kproc, kipos, kjpos ) 
     1083   END SUBROUTINE read_mask 
     1084 
     1085 
     1086   SUBROUTINE mpp_getnum( ldIsOce, kproc, kipos, kjpos ) 
    12411087      !!---------------------------------------------------------------------- 
    12421088      !!                  ***  ROUTINE mpp_getnum  *** 
    … …  
    12461092      !! ** Method  : start from bottom left. First skip land subdomain, and finally use them if needed 
    12471093      !!---------------------------------------------------------------------- 
    1248       LOGICAL, DIMENSION(:,:), INTENT(in   ) ::   ldisoce     ! F if land process 
    1249       INTEGER, DIMENSION(:,:), INTENT(  out) ::   kproc       ! subdomain number (-1 if supressed, starting at 0) 
     1094      LOGICAL, DIMENSION(:,:), INTENT(in   ) ::   ldIsOce     ! F if land process 
     1095      INTEGER, DIMENSION(:,:), INTENT(  out) ::   kproc       ! subdomain number (-1 if not existing, starting at 0) 
    12501096      INTEGER, DIMENSION(  :), INTENT(  out) ::   kipos       ! i-position of the subdomain (from 1 to jpni) 
    12511097      INTEGER, DIMENSION(  :), INTENT(  out) ::   kjpos       ! j-position of the subdomain (from 1 to jpnj) 
    … …  
    12551101      !!---------------------------------------------------------------------- 
    12561102      ! 
    1257       ini = SIZE(ldisoce, dim = 1) 
    1258       inj = SIZE(ldisoce, dim = 2) 
     1103      ini = SIZE(ldIsOce, dim = 1) 
     1104      inj = SIZE(ldIsOce, dim = 2) 
    12591105      inij = SIZE(kipos) 
    12601106      ! 
    … …  
    12661112         ii = 1 + MOD(iarea0,ini) 
    12671113         ij = 1 +     iarea0/ini 
    1268          IF( ldisoce(ii,ij) ) THEN 
     1114         IF( ldIsOce(ii,ij) ) THEN 
    12691115            icont = icont + 1 
    12701116            kproc(ii,ij) = icont 
    … …  
    12741120      END DO 
    12751121      ! if needed add some land subdomains to reach inij active subdomains 
    1276       i2add = inij - COUNT( ldisoce ) 
     1122      i2add = inij - COUNT( ldIsOce ) 
    12771123      DO jarea = 1, ini*inj 
    12781124         iarea0 = jarea - 1 
    12791125         ii = 1 + MOD(iarea0,ini) 
    12801126         ij = 1 +     iarea0/ini 
    1281          IF( .NOT. ldisoce(ii,ij) .AND. i2add > 0 ) THEN 
     1127         IF( .NOT. ldIsOce(ii,ij) .AND. i2add > 0 ) THEN 
    12821128            icont = icont + 1 
    12831129            kproc(ii,ij) = icont 
    … …  
    12891135      ! 
    12901136   END SUBROUTINE mpp_getnum 
     1137 
     1138 
     1139   SUBROUTINE init_excl_landpt 
     1140      !!---------------------------------------------------------------------- 
     1141      !!                  ***  ROUTINE   *** 
     1142      !! 
     1143      !! ** Purpose : exclude exchanges which contain only land points 
     1144      !! 
     1145      !! ** Method  : if a send or receive buffer constains only land point we 
     1146      !!              flag off the corresponding communication 
     1147      !!              Warning: this selection depend on the halo size -> loop on halo size 
     1148      !! 
     1149      !!---------------------------------------------------------------------- 
     1150      INTEGER ::   inumsave 
     1151      INTEGER ::   jh 
     1152      INTEGER ::   ipi, ipj 
     1153      INTEGER ::   iiwe, iiea, iist, iisz  
     1154      INTEGER ::   ijso, ijno, ijst, ijsz  
     1155      LOGICAL ::   llsave 
     1156      REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   zmsk 
     1157      LOGICAL , DIMENSION(Ni_0,Nj_0,1)      ::   lloce 
     1158      !!---------------------------------------------------------------------- 
     1159      ! 
     1160      ! read the land-sea mask on the inner domain 
     1161      CALL read_mask( nimpp, njmpp, Ni_0, Nj_0, lloce(:,:,1) ) 
     1162      ! 
     1163      ! Here we look only at communications excluding the NP folding. 
     1164      ! As lbcnfd not validated if halo size /= nn_hls, we switch if off temporary... 
     1165      llsave = l_IdoNFold 
     1166      l_IdoNFold = .FALSE. 
     1167      ! 
     1168      DO jh = 1, n_hlsmax    ! different halo size 
     1169         ! 
     1170         ipi = Ni_0 + 2*jh   ! local domain size 
     1171         ipj = Nj_0 + 2*jh 
     1172         ! 
     1173         ALLOCATE( zmsk(ipi,ipj) ) 
     1174         zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3), wp)   ! define inner domain -> need REAL to use lbclnk 
     1175         CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh)                 ! fill halos 
     1176         !         
     1177         iiwe = jh   ;   iiea = Ni_0   ! bottom-left corfer - 1 of the sent data 
     1178         ijso = jh   ;   ijno = Nj_0 
     1179         IF( nn_comm == 1 ) THEN  
     1180            iist =  0   ;   iisz = ipi 
     1181            ijst =  0   ;   ijsz = ipj 
     1182         ELSE 
     1183            iist = jh   ;   iisz = Ni_0 
     1184            ijst = jh   ;   ijsz = Nj_0 
     1185         ENDIF 
     1186IF( nn_comm == 1 ) THEN       ! SM: NOT WORKING FOR NEIGHBOURHOOD COLLECTIVE COMMUNICATIONS, I DON'T KNOW WHY...  
     1187         ! do not send if we send only land points 
     1188         IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh  ,ijst+1:ijst+ijsz) )) == 0 )   mpiSnei(jh,jpwe) = -1 
     1189         IF( NINT(SUM( zmsk(iiea+1:iiea+jh  ,ijst+1:ijst+ijsz) )) == 0 )   mpiSnei(jh,jpea) = -1 
     1190         IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh  ) )) == 0 )   mpiSnei(jh,jpso) = -1 
     1191         IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh  ) )) == 0 )   mpiSnei(jh,jpno) = -1 
     1192         IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh  ,ijso+1:ijso+jh  ) )) == 0 )   mpiSnei(jh,jpsw) = -1 
     1193         IF( NINT(SUM( zmsk(iiea+1:iiea+jh  ,ijso+1:ijso+jh  ) )) == 0 )   mpiSnei(jh,jpse) = -1 
     1194         IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh  ,ijno+1:ijno+jh  ) )) == 0 )   mpiSnei(jh,jpnw) = -1 
     1195         IF( NINT(SUM( zmsk(iiea+1:iiea+jh  ,ijno+1:ijno+jh  ) )) == 0 )   mpiSnei(jh,jpne) = -1 
     1196         ! 
     1197         iiwe = iiwe-jh   ;   iiea = iiea+jh   ! bottom-left corfer - 1 of the received data 
     1198         ijso = ijso-jh   ;   ijno = ijno+jh 
     1199         ! do not send if we send only land points 
     1200         IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh  ,ijst+1:ijst+ijsz) )) == 0 )   mpiRnei(jh,jpwe) = -1 
     1201         IF( NINT(SUM( zmsk(iiea+1:iiea+jh  ,ijst+1:ijst+ijsz) )) == 0 )   mpiRnei(jh,jpea) = -1 
     1202         IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh  ) )) == 0 )   mpiRnei(jh,jpso) = -1 
     1203         IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh  ) )) == 0 )   mpiRnei(jh,jpno) = -1 
     1204         IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh  ,ijso+1:ijso+jh  ) )) == 0 )   mpiRnei(jh,jpsw) = -1 
     1205         IF( NINT(SUM( zmsk(iiea+1:iiea+jh  ,ijso+1:ijso+jh  ) )) == 0 )   mpiRnei(jh,jpse) = -1 
     1206         IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh  ,ijno+1:ijno+jh  ) )) == 0 )   mpiRnei(jh,jpnw) = -1 
     1207         IF( NINT(SUM( zmsk(iiea+1:iiea+jh  ,ijno+1:ijno+jh  ) )) == 0 )   mpiRnei(jh,jpne) = -1 
     1208ENDIF 
     1209         ! 
     1210         ! Specific (and rare) problem in corner treatment because we do 1st West-East comm, next South-North comm 
     1211         IF( nn_comm == 1 ) THEN 
     1212            IF( mpiSnei(jh,jpwe) > -1 )   mpiSnei(jh, (/jpsw,jpnw/) ) = -1   ! SW and NW corners already sent through West nei 
     1213            IF( mpiSnei(jh,jpea) > -1 )   mpiSnei(jh, (/jpse,jpne/) ) = -1   ! SE and NE corners already sent through East nei 
     1214            IF( mpiRnei(jh,jpso) > -1 )   mpiRnei(jh, (/jpsw,jpse/) ) = -1   ! SW and SE corners will be received through South nei 
     1215            IF( mpiRnei(jh,jpno) > -1 )   mpiRnei(jh, (/jpnw,jpne/) ) = -1   ! NW and NE corners will be received through North nei 
     1216        ENDIF 
     1217         ! 
     1218         DEALLOCATE( zmsk ) 
     1219         ! 
     1220         CALL mpp_ini_nc(jh)    ! Initialize/Update communicator for neighbourhood collective communications 
     1221         ! 
     1222      END DO 
     1223      l_IdoNFold = llsave 
     1224 
     1225   END SUBROUTINE init_excl_landpt 
    12911226 
    12921227 
    … …  
    13261261      ENDIF 
    13271262      ! 
    1328       CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) 
     1263      CALL flio_dom_set ( jpnij, narea-1, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) 
    13291264      ! 
    13301265   END SUBROUTINE init_ioipsl 
    … …  
    13451280      !!---------------------------------------------------------------------- 
    13461281      ! 
    1347       !initializes the north-fold communication variables 
    1348       isendto(:) = 0 
    1349       nsndto     = 0 
    1350       ! 
    1351       IF ( njmpp == MAXVAL( njmppt ) ) THEN      ! if I am a process in the north 
     1282      !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 
     1283      sxM = jpiglo - nimpp - jpi + 1 
     1284      !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 
     1285      dxM = jpiglo - nimpp + 2 
     1286      ! 
     1287      ! loop over the other north-fold processes to find the processes 
     1288      ! managing the points belonging to the sxT-dxT range 
     1289      ! 
     1290      nsndto = 0 
     1291      DO jn = 1, jpni 
    13521292         ! 
    1353          !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 
    1354          sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 
    1355          !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 
    1356          dxM = jpiglo - nimppt(narea) + 2 
     1293         sxT = nfimpp(jn)                    ! sxT = 1st  point (in the global domain) of the jn process 
     1294         dxT = nfimpp(jn) + nfjpi(jn) - 1    ! dxT = last point (in the global domain) of the jn process 
    13571295         ! 
    1358          ! loop over the other north-fold processes to find the processes 
    1359          ! managing the points belonging to the sxT-dxT range 
     1296         IF    ( sxT < sxM  .AND.  sxM < dxT ) THEN 
     1297            nsndto          = nsndto + 1 
     1298            isendto(nsndto) = jn 
     1299         ELSEIF( sxM <= sxT  .AND.  dxM >= dxT ) THEN 
     1300            nsndto          = nsndto + 1 
     1301            isendto(nsndto) = jn 
     1302         ELSEIF( dxM <  dxT  .AND.  sxT <  dxM ) THEN 
     1303            nsndto          = nsndto + 1 
     1304            isendto(nsndto) = jn 
     1305         ENDIF 
    13601306         ! 
    1361          DO jn = 1, jpni 
    1362             ! 
    1363             sxT = nfimpp(jn)                    ! sxT = 1st  point (in the global domain) of the jn process 
    1364             dxT = nfimpp(jn) + nfjpi(jn) - 1    ! dxT = last point (in the global domain) of the jn process 
    1365             ! 
    1366             IF    ( sxT < sxM  .AND.  sxM < dxT ) THEN 
    1367                nsndto          = nsndto + 1 
    1368                isendto(nsndto) = jn 
    1369             ELSEIF( sxM <= sxT  .AND.  dxM >= dxT ) THEN 
    1370                nsndto          = nsndto + 1 
    1371                isendto(nsndto) = jn 
    1372             ELSEIF( dxM <  dxT  .AND.  sxT <  dxM ) THEN 
    1373                nsndto          = nsndto + 1 
    1374                isendto(nsndto) = jn 
    1375             ENDIF 
    1376             ! 
    1377          END DO 
    1378          ! 
    1379       ENDIF 
    1380       l_north_nogather = .TRUE. 
     1307      END DO 
    13811308      ! 
    13821309   END SUBROUTINE init_nfdcom 
    … …  
    13911318      !!---------------------------------------------------------------------- 
    13921319      ! 
    1393       Nis0 =   1+nn_hls   ;   Nis1 = Nis0-1   ;   Nis2 = MAX(  1, Nis0-2) 
    1394       Njs0 =   1+nn_hls   ;   Njs1 = Njs0-1   ;   Njs2 = MAX(  1, Njs0-2) 
    1395       ! 
    1396       Nie0 = jpi-nn_hls   ;   Nie1 = Nie0+1   ;   Nie2 = MIN(jpi, Nie0+2) 
    1397       Nje0 = jpj-nn_hls   ;   Nje1 = Nje0+1   ;   Nje2 = MIN(jpj, Nje0+2) 
    1398       ! 
    1399       IF( nn_hls == 1 ) THEN          !* halo size of 1 
    1400          ! 
    1401          Nis1nxt2 = Nis0   ;   Njs1nxt2 = Njs0 
    1402          Nie1nxt2 = Nie0   ;   Nje1nxt2 = Nje0 
    1403          ! 
    1404       ELSE                            !* larger halo size... 
    1405          ! 
    1406          Nis1nxt2 = Nis1   ;   Njs1nxt2 = Njs1 
    1407          Nie1nxt2 = Nie1   ;   Nje1nxt2 = Nje1 
    1408          ! 
    1409       ENDIF 
     1320      Nis0 =   1+nn_hls 
     1321      Njs0 =   1+nn_hls 
     1322      Nie0 = jpi-nn_hls 
     1323      Nje0 = jpj-nn_hls 
    14101324      ! 
    14111325      Ni_0 = Nie0 - Nis0 + 1 
    14121326      Nj_0 = Nje0 - Njs0 + 1 
    1413       Ni_1 = Nie1 - Nis1 + 1 
    1414       Nj_1 = Nje1 - Njs1 + 1 
    1415       Ni_2 = Nie2 - Nis2 + 1 
    1416       Nj_2 = Nje2 - Njs2 + 1 
     1327      ! 
     1328      ! old indices to be removed... 
     1329      jpim1 = jpi-1                             ! inner domain indices 
     1330      jpjm1 = jpj-1                             !   "           " 
     1331      jpkm1 = jpk-1                             !   "           " 
    14171332      ! 
    14181333   END SUBROUTINE init_doloop 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LDF/ldfc1d_c2d.F90

    r14189 r14574  
    9595         END_3D 
    9696         ! Lateral boundary conditions 
    97          CALL lbc_lnk_multi( 'ldfc1d_c2d', pah1, 'U', 1.0_wp , pah2, 'V', 1.0_wp ) 
     97         CALL lbc_lnk( 'ldfc1d_c2d', pah1, 'U', 1.0_wp , pah2, 'V', 1.0_wp ) 
    9898         ! 
    9999      CASE DEFAULT                        ! error 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LDF/ldfdyn.F90

    r14201 r14574  
    412412         ENDIF 
    413413         ! 
    414          CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1.0_wp,  ahmf, 'F', 1.0_wp ) 
     414         CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_wp,  ahmf, 'F', 1.0_wp ) 
    415415         ! 
    416416         ! 
    … …  
    444444            END DO 
    445445            ! 
    446             CALL lbc_lnk_multi( 'ldfdyn', dtensq, 'T', 1.0_wp )  ! lbc_lnk on dshesq not needed 
     446            CALL lbc_lnk( 'ldfdyn', dtensq, 'T', 1.0_wp )  ! lbc_lnk on dshesq not needed 
    447447            ! 
    448448            DO jk = 1, jpkm1 
    … …  
    495495         ENDIF 
    496496         ! 
    497          CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1.0_wp , ahmf, 'F', 1.0_wp ) 
     497         CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_wp , ahmf, 'F', 1.0_wp ) 
    498498         ! 
    499499      END SELECT 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LDF/ldfslp.F90

    r13497 r14574  
    229229!!gm end modif 
    230230      END_3D 
    231       CALL lbc_lnk_multi( 'ldfslp', zwz, 'U', -1.0_wp,  zww, 'V', -1.0_wp )      ! lateral boundary conditions 
     231      CALL lbc_lnk( 'ldfslp', zwz, 'U', -1.0_wp,  zww, 'V', -1.0_wp )      ! lateral boundary conditions 
    232232      ! 
    233233      !                                    !* horizontal Shapiro filter 
    … …  
    245245               &                       + 4.*  zww(ji,jj    ,jk)                       ) 
    246246         END_2D 
    247          DO jj = 3, jpj-2                                    ! other rows 
    248             DO ji = 2, jpim1   ! vector opt. 
    249                uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      & 
    250                   &                       +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      & 
    251                   &                       + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)      & 
    252                   &                       +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )    & 
    253                   &                       + 4.*  zwz(ji  ,jj  ,jk)                       ) 
    254                vslp(ji,jj,jk) = z1_16 * (        zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)      & 
    255                   &                       +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)      & 
    256                   &                       + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)      & 
    257                   &                       +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )    & 
    258                   &                       + 4.*  zww(ji,jj    ,jk)                       ) 
    259             END DO 
    260          END DO 
    261247         !                                 !* decrease along coastal boundaries 
    262248         DO_2D( 0, 0, 0, 0 ) 
    … …  
    303289!!gm end modif 
    304290      END_3D 
    305       CALL lbc_lnk_multi( 'ldfslp', zwz, 'T', -1.0_wp,  zww, 'T', -1.0_wp )      ! lateral boundary conditions 
     291      CALL lbc_lnk( 'ldfslp', zwz, 'T', -1.0_wp,  zww, 'T', -1.0_wp )      ! lateral boundary conditions 
    306292      ! 
    307293      !                                           !* horizontal Shapiro filter 
    … …  
    321307                 &               + 4.*  zww(ji  ,jj  ,jk)                         ) * zcofw 
    322308         END_2D 
    323          DO jj = 3, jpj-2                               ! other rows 
    324             DO ji = 2, jpim1   ! vector opt. 
    325                zcofw = wmask(ji,jj,jk) * z1_16 
    326                wslpi(ji,jj,jk) = (         zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     & 
    327                     &               +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     & 
    328                     &               + 2.*( zwz(ji  ,jj-1,jk) + zwz(ji-1,jj  ,jk)     & 
    329                     &               +      zwz(ji+1,jj  ,jk) + zwz(ji  ,jj+1,jk) )   & 
    330                     &               + 4.*  zwz(ji  ,jj  ,jk)                         ) * zcofw 
    331  
    332                wslpj(ji,jj,jk) = (         zww(ji-1,jj-1,jk) + zww(ji+1,jj-1,jk)     & 
    333                     &               +      zww(ji-1,jj+1,jk) + zww(ji+1,jj+1,jk)     & 
    334                     &               + 2.*( zww(ji  ,jj-1,jk) + zww(ji-1,jj  ,jk)     & 
    335                     &               +      zww(ji+1,jj  ,jk) + zww(ji  ,jj+1,jk) )   & 
    336                     &               + 4.*  zww(ji  ,jj  ,jk)                         ) * zcofw 
    337             END DO 
    338          END DO 
    339309         !                                        !* decrease in vicinity of topography 
    340310         DO_2D( 0, 0, 0, 0 ) 
    … …  
    348318      ! IV. Lateral boundary conditions 
    349319      ! =============================== 
    350       CALL lbc_lnk_multi( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) 
     320      CALL lbc_lnk( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) 
    351321 
    352322      IF(sn_cfctl%l_prtctl) THEN 
    … …  
    689659      END_2D 
    690660      !!gm this lbc_lnk should be useless.... 
    691       CALL lbc_lnk_multi( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp )  
     661      CALL lbc_lnk( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp )  
    692662      ! 
    693663   END SUBROUTINE ldf_slp_mxl 
    … …  
    757727!               END DO 
    758728!            END DO 
    759 !            CALL lbc_lnk_multi( 'ldfslp', uslp , 'U', -1. ; CALL lbc_lnk( 'ldfslp', vslp , 'V', -1.,  wslpi, 'W', -1.,  wslpj, 'W', -1. ) 
     729!            CALL lbc_lnk( 'ldfslp', uslp , 'U', -1. ; CALL lbc_lnk( 'ldfslp', vslp , 'V', -1.,  wslpi, 'W', -1.,  wslpj, 'W', -1. ) 
    760730!!gm         ENDIF 
    761731      ENDIF 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/LDF/ldftra.F90

    r14537 r14574  
    697697         paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji  ,jj+1) ) * vmask(ji,jj,1) 
    698698      END_2D 
    699       CALL lbc_lnk_multi( 'ldftra', paeiu(:,:,1), 'U', 1.0_wp , paeiv(:,:,1), 'V', 1.0_wp )      ! lateral boundary condition 
     699      CALL lbc_lnk( 'ldftra', paeiu(:,:,1), 'U', 1.0_wp , paeiv(:,:,1), 'V', 1.0_wp )      ! lateral boundary condition 
    700700 
    701701      DO jk = 2, jpkm1                          !==  deeper values equal the surface one  ==! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/OBS/obs_averg_h2d.F90

    r12377 r14574  
    2121      & e1t, e2t, & 
    2222      & e1f, e2f, & 
    23       & glamt, gphit, & 
    24       & nproc 
     23      & glamt, gphit 
    2524   USE in_out_manager 
    2625   USE obs_const, ONLY : & 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/OBS/obs_grid.F90

    r13286 r14574  
    130130               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 
    131131                  &                             1, jpi, 1, jpj,           & 
    132                   &                             nproc, jpnij,             & 
     132                  &                             narea-1, jpnij,           & 
    133133                  &                             glamt, gphit, tmask,      & 
    134134                  &                             kobsin, plam, pphi,       & 
    … …  
    137137               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 
    138138                  &                             1, jpi, 1, jpj,           & 
    139                   &                             nproc, jpnij,             & 
     139                  &                             narea-1, jpnij,           & 
    140140                  &                             glamu, gphiu, umask,      & 
    141141                  &                             kobsin, plam, pphi,       & 
    … …  
    144144               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 
    145145                  &                             1, jpi, 1, jpj,           & 
    146                   &                             nproc, jpnij,             & 
     146                  &                             narea-1, jpnij,           & 
    147147                  &                             glamv, gphiv, vmask,      & 
    148148                  &                             kobsin, plam, pphi,       & 
    … …  
    151151               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 
    152152                  &                             1, jpi, 1, jpj,           & 
    153                   &                             nproc, jpnij,             & 
     153                  &                             narea-1, jpnij,           & 
    154154                  &                             glamf, gphif, fmask,      & 
    155155                  &                             kobsin, plam, pphi,       & 
    … …  
    176176      !! 
    177177      !! ** Action  : Return kproc holding the observation and kiobsi,kobsj 
    178       !!              valid on kproc=nproc processor only. 
     178      !!              valid on kproc=narea-1 processor only. 
    179179      !!    
    180180      !! History : 
    … …  
    248248         jlon     = jpiglo 
    249249         jlat     = jpjglo 
    250          joffset  = nproc 
     250         joffset  = narea-1 
    251251         jostride = jpnij 
    252252      ELSE 
    … …  
    513513                        IF ( ABS( zlam - zplam(jo) ) < 1e-6 ) THEN 
    514514                           IF ( llinvalidcell(ji,jj) ) THEN 
    515                               kproc(jo) = nproc + 1000000 
     515                              kproc(jo) = narea-1 + 1000000 
    516516                              kobsi(jo) = ji + 1 
    517517                              kobsj(jo) = jj + 1 
    518518                              CYCLE 
    519519                           ELSE 
    520                               kproc(jo) = nproc 
     520                              kproc(jo) = narea-1 
    521521                              kobsi(jo) = ji + 1 
    522522                              kobsj(jo) = jj + 1 
    … …  
    552552                           &          zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN 
    553553                           IF ( llinvalidcell(ji,jj) ) THEN 
    554                               kproc(jo) = nproc + 1000000 
     554                              kproc(jo) = narea-1 + 1000000 
    555555                              kobsi(jo) = ji + 1 
    556556                              kobsj(jo) = jj + 1 
    557557                              CYCLE 
    558558                           ELSE 
    559                               kproc(jo) = nproc 
     559                              kproc(jo) = narea-1 
    560560                              kobsi(jo) = ji + 1 
    561561                              kobsj(jo) = jj + 1 
    … …  
    584584                           &          zlamtm(:,ji,jj), zphitm(:,ji,jj) ) ) THEN 
    585585                           IF ( llinvalidcell(ji,jj) ) THEN 
    586                               kproc(jo) = nproc + 1000000 
     586                              kproc(jo) = narea-1 + 1000000 
    587587                              kobsi(jo) = ji + 1 
    588588                              kobsj(jo) = jj + 1 
    589589                              CYCLE 
    590590                           ELSE 
    591                               kproc(jo) = nproc 
     591                              kproc(jo) = narea-1 
    592592                              kobsi(jo) = ji + 1 
    593593                              kobsj(jo) = jj + 1 
    … …  
    716716            ! define the following format: "(a,a,ix.x,a,ix.x,a,ix.x,a)" 
    717717            WRITE(clfmt, "('(a,a,i', i1, '.', i1',a,i', i1, '.', i1',a,i', i1, '.', i1',a)')") idg, idg, idg, idg, idg, idg 
    718             WRITE(cfname,      clfmt     ) TRIM(cn_gridsearchfile),'_', nproc,'of', jpni,'by', jpnj,'.nc' 
     718            WRITE(cfname,      clfmt     ) TRIM(cn_gridsearchfile),'_', narea-1,'of', jpni,'by', jpnj,'.nc' 
    719719         ENDIF 
    720720 
    … …  
    820820            CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo,  & 
    821821               &                     1, jpi, 1, jpj,            & 
    822                &                     nproc, jpnij,              & 
     822               &                     narea-1, jpnij,            & 
    823823               &                     glamt, gphit, tmask,       & 
    824824               &                     nlons*nlats, lonsi, latsi, & 
    … …  
    10701070 
    10711071            IF ( ( .NOT. ln_grid_global ) .OR. & 
    1072                & ( ( ln_grid_global ) .AND. ( nproc==0 ) ) ) THEN 
     1072               & ( ( ln_grid_global ) .AND. ( narea-1==0 ) ) ) THEN 
    10731073 
    10741074               CALL chkerr( nf90_create (TRIM(cfname), nf90_clobber, idfile), & 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/OBS/obs_mpp.F90

    r14229 r14574  
    1818   !! obs_mpp_sum_integer   : Sum an integer from all processors 
    1919   !!---------------------------------------------------------------------- 
    20    USE dom_oce, ONLY :   nproc, mig, mjg   ! Ocean space and time domain variables 
    2120   USE mpp_map, ONLY :   mppmap 
    2221   USE in_out_manager 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/OBS/obs_prep.F90

    r14056 r14574  
    6262      !! * Modules used 
    6363      USE par_oce             ! Ocean parameters 
    64       USE dom_oce, ONLY       :   glamt, gphit, tmask, nproc   ! Geographical information 
     64      USE dom_oce, ONLY       :   glamt, gphit, tmask   ! Geographical information 
    6565      !! * Arguments 
    6666      TYPE(obs_surf), INTENT(INOUT) :: surfdata    ! Full set of surface data 
    … …  
    263263      USE par_oce             ! Ocean parameters 
    264264      USE dom_oce, ONLY : &   ! Geographical information 
    265          & gdept_1d,             & 
    266          & nproc 
     265         & gdept_1d 
    267266 
    268267      !! * Arguments 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/OBS/obs_read_prof.F90

    r14056 r14574  
    404404               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    405405                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    406                   IF ( nproc == 0 ) THEN 
    407                      IF ( inpfiles(jj)%iproc(ji,1) >  nproc ) CYCLE 
     406                  IF ( narea == 1 ) THEN 
     407                     IF ( inpfiles(jj)%iproc(ji,1) >  narea-1 ) CYCLE 
    408408                  ELSE 
    409                      IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE 
     409                     IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE 
    410410                  ENDIF 
    411411                  llvalprof = .FALSE. 
    … …  
    538538            & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 
    539539 
    540             IF ( nproc == 0 ) THEN 
    541                IF ( inpfiles(jj)%iproc(ji,1) >  nproc ) CYCLE 
     540            IF ( narea == 1 ) THEN 
     541               IF ( inpfiles(jj)%iproc(ji,1) >  narea-1 ) CYCLE 
    542542            ELSE 
    543                IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE 
     543               IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE 
    544544            ENDIF 
    545545 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/OBS/obs_read_surf.F90

    r14056 r14574  
    300300               IF ( ( inpfiles(jj)%ptim(ji) >  djulini(jj) ) .AND. & 
    301301                  & ( inpfiles(jj)%ptim(ji) <= djulend(jj) )       ) THEN 
    302                   IF ( nproc == 0 ) THEN 
    303                      IF ( inpfiles(jj)%iproc(ji,1) >  nproc ) CYCLE 
     302                  IF ( narea == 1 ) THEN 
     303                     IF ( inpfiles(jj)%iproc(ji,1) >  narea-1 ) CYCLE 
    304304                  ELSE 
    305                      IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE 
     305                     IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE 
    306306                  ENDIF 
    307307                  llvalprof = .FALSE. 
    … …  
    371371            & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN 
    372372 
    373             IF ( nproc == 0 ) THEN 
    374                IF ( inpfiles(jj)%iproc(ji,1) >  nproc ) CYCLE 
     373            IF ( narea == 1 ) THEN 
     374               IF ( inpfiles(jj)%iproc(ji,1) >  narea-1 ) CYCLE 
    375375            ELSE 
    376                IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE 
     376               IF ( inpfiles(jj)%iproc(ji,1) /= narea-1 ) CYCLE 
    377377            ENDIF 
    378378 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/OBS/obs_utils.F90

    r10068 r14574  
    6666      !! * Modules used 
    6767      USE netcdf             ! NetCDF library 
    68       USE dom_oce, ONLY : &  ! Ocean space and time domain variables 
    69          & nproc 
    7068 
    7169      !! * Arguments 
    … …  
    102100      !! * Modules used 
    103101      USE netcdf             ! NetCDF library 
    104       USE dom_oce, ONLY : &  ! Ocean space and time domain variables 
    105          & nproc 
    106102 
    107103      !! * Arguments 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/OBS/obs_write.F90

    r14056 r14574  
    210210      idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 )            ! how many digits to we need to write? min=4, max=9 
    211211      WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg   ! '(a,a,ix.x,a)' 
    212       WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', nproc, '.nc' 
     212      WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', narea-1, '.nc' 
    213213 
    214214      IF(lwp) THEN 
    … …  
    475475      idg = MAX( INT(LOG10(REAL(jpnij,wp))) + 1, 4 )            ! how many digits to we need to write? min=4, max=9 
    476476      WRITE(clfmt, "('(a,a,i', i1, '.', i1, ',a)')") idg, idg   ! '(a,a,ix.x,a)' 
    477       WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', nproc, '.nc' 
     477      WRITE(clfname,clfmt) TRIM(clfiletype), '_fdbk_', narea-1, '.nc' 
    478478 
    479479      IF(lwp) THEN 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/SBC/cpl_oasis3.F90

    r14227 r14574  
    294294      ! 
    295295#if defined key_agrif 
    296       IF( agrif_fixed() == Agrif_Nb_Fine_Grids() ) THEN 
     296      ! Warning: Agrif_Nb_Fine_Grids not yet defined at this stage for Agrif_Root -> must use Agrif_Root_Only() 
     297      IF( Agrif_Root_Only() .OR. agrif_fixed() == Agrif_Nb_Fine_Grids() ) THEN 
    297298#endif 
    298299      CALL oasis_enddef(nerror) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/SBC/fldread.F90

    r13546 r14574  
    211211            ! 
    212212            IF( sd(jf)%ln_tint ) THEN              ! temporal interpolation 
    213                IF(lwp .AND. kt - nit000 <= 100 ) THEN  
     213               IF(lwp .AND. ( kt - nit000 <= 20 .OR. nitend - kt <= 20 ) ) THEN  
    214214                  clfmt = "('   fld_read: var ', a, ' kt = ', i8, ' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," //   & 
    215215                     &    "', records b/a: ', i6.4, '/', i6.4, ' (days ', f9.4,'/', f9.4, ')')" 
    … …  
    223223               sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,ibb) + ztinta * sd(jf)%fdta(:,:,:,iaa) 
    224224            ELSE   ! nothing to do... 
    225                IF(lwp .AND. kt - nit000 <= 100 ) THEN 
     225               IF(lwp .AND. ( kt - nit000 <= 20 .OR. nitend - kt <= 20 ) ) THEN 
    226226                  clfmt = "('   fld_read: var ', a, ' kt = ', i8,' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," //   & 
    227227                     &    "', record: ', i6.4, ' (days ', f9.4, ' <-> ', f9.4, ')')" 
    … …  
    251251      !!--------------------------------------------------------------------- 
    252252      ! 
    253       IF( nflag == 0 )   nflag = -( HUGE(0) - 10 ) 
     253      IF( nflag == 0 )   nflag = -HUGE(0) 
    254254      ! 
    255255      CALL fld_def( sdjf ) 
    … …  
    908908      TYPE(FLD)        , INTENT(inout) ::   sdjf       ! input field related variables 
    909909      ! 
    910       INTEGER, DIMENSION(2)  :: isave 
     910      INTEGER  :: isave 
    911911      LOGICAL  :: llprev, llnext, llstop 
    912912      !!---------------------------------------------------------------------- 
    913913      ! 
    914914      llprev = sdjf%nrecsec(sdjf%nreclast) < nsec000_1jan000   ! file ends before the beginning of the job -> file may not exist 
    915       llnext = sdjf%nrecsec(       0     ) > nsecend_1jan000   ! file begins after the end of the job -> file may not exist  
     915      llnext = sdjf%nrecsec(      1      ) > nsecend_1jan000   ! file begins after the end of the job -> file may not exist  
    916916 
    917917      llstop = sdjf%ln_clim .OR. .NOT. ( llprev .OR. llnext ) 
    … …  
    926926         IF( llprev ) THEN   ! previous file does not exist : go back to current and accept to read only the first record 
    927927            CALL ctl_warn('previous file: '//TRIM(sdjf%clname)//' not found -> go back to current year/month/week/day file') 
    928             isave(1:2) = sdjf%nrecsec(sdjf%nreclast-1:sdjf%nreclast)   ! save previous file info 
    929             CALL fld_def( sdjf )   ! go back to current file 
    930             sdjf%nreclast = 1   ! force to use only the first record (do as if other were not existing...) 
    931             sdjf%nrecsec(0:1) = isave(1:2) 
     928            isave = sdjf%nrecsec(sdjf%nreclast)   ! save previous file info 
     929            CALL fld_def( sdjf )                  ! go back to current file 
     930            sdjf%nreclast = 1                     ! force to use only the first record (do as if other were not existing...) 
    932931         ENDIF 
    933932         ! 
    934933         IF( llnext ) THEN   ! next     file does not exist : go back to current and accept to read only the last  record  
    935934            CALL ctl_warn('next file: '//TRIM(sdjf%clname)//' not found -> go back to current year/month/week/day file') 
    936             isave(1:2) = sdjf%nrecsec(0:1)    ! save next file info 
    937             CALL fld_def( sdjf )   ! go back to current file 
    938             ! -> read last record but keep record info from the first record of next file 
    939             sdjf%nrecsec(sdjf%nreclast-1:sdjf%nreclast) = isave(1:2) 
    940             sdjf%nrecsec(0:sdjf%nreclast-2) = nflag 
    941          ENDIF 
     935            isave = sdjf%nrecsec(1)               ! save next file info 
     936            CALL fld_def( sdjf )                  ! go back to current file 
     937         ENDIF 
     938         ! -> read "last" record but keep record info from the first record of next file 
     939         sdjf%nrecsec(  sdjf%nreclast  ) = isave 
     940         sdjf%nrecsec(0:sdjf%nreclast-1) = nflag 
    942941         ! 
    943942         CALL iom_open( sdjf%clname, sdjf%num, ldiof = LEN_TRIM(sdjf%wgtname) > 0 )    

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/SBC/geo2ocean.F90

    r14215 r14574  
    272272      ! =========================== ! 
    273273      !           ! lateral boundary cond.: T-, U-, V-, F-pts, sgn 
    274       CALL lbc_lnk_multi( 'geo2ocean', gcost, 'T', -1.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, &  
    275                       &   gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp  ) 
     274      CALL lbc_lnk( 'geo2ocean', gcost, 'T', -1.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, &  
     275         &                       gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp  ) 
    276276      ! 
    277277   END SUBROUTINE angle 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/SBC/sbcblk.F90

    r14072 r14574  
    4040   USE sbcdcy         ! surface boundary condition: diurnal cycle 
    4141   USE sbcwave , ONLY :   cdn_wave ! wave module 
    42    USE lib_fortran    ! to use key_nosignedzero 
     42   USE lib_fortran    ! to use key_nosignedzero and glob_sum 
    4343   ! 
    4444#if defined key_si3 
    … …  
    348348      !                                      !- fill the bulk structure with namelist informations 
    349349      CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_init', 'surface boundary condition -- bulk formulae', 'namsbc_blk' ) 
     350      sf(jp_wndi )%zsgn = -1._wp   ;   sf(jp_wndj )%zsgn = -1._wp   ! vector field at T point: overwrite default definition of zsgn 
     351      sf(jp_uoatm)%zsgn = -1._wp   ;   sf(jp_voatm)%zsgn = -1._wp   ! vector field at T point: overwrite default definition of zsgn 
     352      sf(jp_hpgi )%zsgn = -1._wp   ;   sf(jp_hpgj )%zsgn = -1._wp   ! vector field at T point: overwrite default definition of zsgn 
    350353      ! 
    351354      DO jfpr= 1, jpfld 
    … …  
    501504      !!---------------------------------------------------------------------- 
    502505      REAL(wp), DIMENSION(jpi,jpj) ::   zssq, zcd_du, zsen, zlat, zevp 
    503       REAL(wp) :: ztmp 
     506      REAL(wp) :: ztst 
     507      LOGICAL  :: llerr 
    504508      !!---------------------------------------------------------------------- 
    505509      ! 
    … …  
    508512      ! Sanity/consistence test on humidity at first time step to detect potential screw-up: 
    509513      IF( kt == nit000 ) THEN 
    510          IF(lwp) WRITE(numout,*) '' 
    511 #if defined key_agrif 
    512          IF(lwp) WRITE(numout,*) ' === AGRIF => Sanity/consistence test on air humidity SKIPPED! :( ===' 
    513 #else 
    514          ztmp = SUM(tmask(:,:,1)) ! number of ocean points on local proc domain 
    515          IF( ztmp > 8._wp ) THEN ! test only on proc domains with at least 8 ocean points! 
    516             ztmp = SUM(sf(jp_humi)%fnow(:,:,1)*tmask(:,:,1))/ztmp ! mean humidity over ocean on proc 
    517             SELECT CASE( nhumi ) 
    518             CASE( np_humi_sph ) ! specific humidity => expect: 0. <= something < 0.065 [kg/kg] (0.061 is saturation at 45degC !!!) 
    519                IF(  (ztmp < 0._wp) .OR. (ztmp > 0.065)  ) ztmp = -1._wp 
    520             CASE( np_humi_dpt ) ! dew-point temperature => expect: 110. <= something < 320. [K] 
    521                IF( (ztmp < 110._wp).OR.(ztmp > 320._wp) ) ztmp = -1._wp 
    522             CASE( np_humi_rlh ) ! relative humidity => expect: 0. <= something < 100. [%] 
    523                IF(  (ztmp < 0._wp) .OR.(ztmp > 100._wp) ) ztmp = -1._wp 
    524             END SELECT 
    525             IF(ztmp < 0._wp) THEN 
    526                IF (lwp) WRITE(numout,'("   Mean humidity value found on proc #",i6.6," is: ",f10.5)') narea, ztmp 
    527                CALL ctl_stop( 'STOP', 'Something is wrong with air humidity!!!', & 
    528                   &   ' ==> check the unit in your input files'       , & 
    529                   &   ' ==> check consistence of namelist choice: specific? relative? dew-point?', & 
    530                   &   ' ==> ln_humi_sph -> [kg/kg] | ln_humi_rlh -> [%] | ln_humi_dpt -> [K] !!!' ) 
    531             END IF 
    532          END IF 
    533          IF(lwp) WRITE(numout,*) ' === Sanity/consistence test on air humidity sucessfuly passed! ===' 
    534 #endif 
    535          IF(lwp) WRITE(numout,*) '' 
    536       END IF !IF( kt == nit000 ) 
     514         ! mean humidity over ocean on proc 
     515         ztst = glob_sum( 'sbcblk', sf(jp_humi)%fnow(:,:,1) * e1e2t(:,:) * tmask(:,:,1) ) / glob_sum( 'sbcblk', e1e2t(:,:) * tmask(:,:,1) ) 
     516         llerr = .FALSE. 
     517         SELECT CASE( nhumi ) 
     518         CASE( np_humi_sph ) ! specific humidity => expect: 0. <= something < 0.065 [kg/kg] (0.061 is saturation at 45degC !!!) 
     519            IF( (ztst <   0._wp) .OR. (ztst > 0.065_wp) )   llerr = .TRUE. 
     520         CASE( np_humi_dpt ) ! dew-point temperature => expect: 110. <= something < 320. [K] 
     521            IF( (ztst < 110._wp) .OR. (ztst >  320._wp) )   llerr = .TRUE. 
     522         CASE( np_humi_rlh ) ! relative humidity => expect: 0. <= something < 100. [%] 
     523            IF( (ztst <   0._wp) .OR. (ztst >  100._wp) )   llerr = .TRUE. 
     524         END SELECT 
     525         IF(llerr) THEN 
     526            WRITE(ctmp1,'("   Error on mean humidity value: ",f10.5)') ztst 
     527            CALL ctl_stop( 'STOP', ctmp1, 'Something is wrong with air humidity!!!', & 
     528               &   ' ==> check the unit in your input files'       , & 
     529               &   ' ==> check consistence of namelist choice: specific? relative? dew-point?', & 
     530               &   ' ==> ln_humi_sph -> [kg/kg] | ln_humi_rlh -> [%] | ln_humi_dpt -> [K] !!!' ) 
     531         ENDIF 
     532         IF(lwp) THEN 
     533            WRITE(numout,*) '' 
     534            WRITE(numout,*) ' Global mean humidity at kt = nit000: ', ztst 
     535            WRITE(numout,*) ' === Sanity/consistence test on air humidity sucessfuly passed! ===' 
     536            WRITE(numout,*) '' 
     537         ENDIF 
     538      ENDIF   !IF( kt == nit000 ) 
    537539      !                                            ! compute the surface ocean fluxes using bulk formulea 
    538540      IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 
    … …  
    620622      !!--------------------------------------------------------------------- 
    621623      INTEGER , INTENT(in   )                 ::   kt     ! time step index 
    622       REAL(wp), INTENT(in   ), DIMENSION(:,:) ::   pwndi  ! atmospheric wind at U-point              [m/s] 
    623       REAL(wp), INTENT(in   ), DIMENSION(:,:) ::   pwndj  ! atmospheric wind at V-point              [m/s] 
     624      REAL(wp), INTENT(in   ), DIMENSION(:,:) ::   pwndi  ! atmospheric wind at T-point              [m/s] 
     625      REAL(wp), INTENT(in   ), DIMENSION(:,:) ::   pwndj  ! atmospheric wind at T-point              [m/s] 
    624626      REAL(wp), INTENT(in   ), DIMENSION(:,:) ::   pqair  ! specific humidity at T-points            [kg/kg] 
    625627      REAL(wp), INTENT(in   ), DIMENSION(:,:) ::   ptair  ! potential temperature at T-points        [Kelvin] 
    … …  
    830832 
    831833         IF( ln_crt_fbk ) THEN 
    832             CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1., taum, 'T', -1. ) 
     834            CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp, taum, 'T', 1._wp ) 
    833835         ELSE 
    834             CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1. ) 
     836            CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp ) 
    835837         ENDIF 
    836838 
    … …  
    10661068            pvtaui(ji,jj) = zztmp2 * ( pvtaui(ji,jj) + pvtaui(ji  ,jj+1) ) 
    10671069         END_2D 
    1068          CALL lbc_lnk_multi( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp ) 
     1070         CALL lbc_lnk( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp ) 
    10691071         ! 
    10701072         IF(sn_cfctl%l_prtctl)  CALL prt_ctl( tab2d_1=putaui  , clinfo1=' blk_ice: putaui : '   & 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/SBC/sbccpl.F90

    r14227 r14574  
    12481248                  frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji  ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) 
    12491249               END_2D 
    1250                CALL lbc_lnk_multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U',  -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V',  -1.0_wp ) 
     1250               CALL lbc_lnk( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U',  -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V',  -1.0_wp ) 
    12511251            ENDIF 
    12521252            llnewtx = .TRUE. 
    … …  
    16661666               p_tauj(ji,jj) = zztmp2 * ( frcv(jpr_ity1)%z3(ji  ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) ) 
    16671667            END_2D 
    1668             CALL lbc_lnk_multi( 'sbccpl', p_taui, 'U',  -1., p_tauj, 'V',  -1. ) 
     1668            CALL lbc_lnk( 'sbccpl', p_taui, 'U',  -1., p_tauj, 'V',  -1. ) 
    16691669         END SELECT 
    16701670 
    … …  
    25602560                  zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  )     + v_ice(ji  ,jj-1  )     ) *  fr_i(ji,jj) 
    25612561               END_2D 
    2562                CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) 
     2562               CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) 
    25632563            CASE( 'mixed oce-ice'        )      ! Ocean and Ice on C-grid ==> T 
    25642564               DO_2D( 0, 0, 0, 0 ) 
    … …  
    25692569               END_2D 
    25702570            END SELECT 
    2571             CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp,  zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) 
     2571            CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp,  zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) 
    25722572            ! 
    25732573         ENDIF 
    … …  
    26372637                zity1(ji,jj) = 0.5 * ( v_ice(ji,jj  ) + v_ice(ji  ,jj-1  ) ) *  fr_i(ji,jj) 
    26382638             END_2D 
    2639              CALL lbc_lnk_multi( 'sbccpl', zitx1, 'T', -1.0_wp,  zity1, 'T', -1.0_wp ) 
     2639             CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp,  zity1, 'T', -1.0_wp ) 
    26402640          CASE( 'mixed oce-ice'        )      ! Ocean and Ice on C-grid ==> T 
    26412641             DO_2D( 0, 0, 0, 0 ) 
    … …  
    26462646             END_2D 
    26472647          END SELECT 
    2648          CALL lbc_lnk_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) 
     2648         CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) 
    26492649         ! 
    26502650         ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/SBC/sbcflx.F90

    r14072 r14574  
    119119         !                                         ! fill sf with slf_i and control print 
    120120         CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' ) 
     121         sf(jp_utau)%cltype = 'U'   ;   sf(jp_utau)%zsgn = -1._wp   ! vector field at U point: overwrite default definition of cltype and zsgn 
     122         sf(jp_vtau)%cltype = 'V'   ;   sf(jp_vtau)%zsgn = -1._wp   ! vector field at V point: overwrite default definition of cltype and zsgn 
    121123         ! 
    122124      ENDIF 
    … …  
    129131            qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) 
    130132         ELSE 
    131             DO_2D( 0, 0, 0, 0 ) 
    132                qsr(ji,jj) =          sf(jp_qsr)%fnow(ji,jj,1)  * tmask(ji,jj,1) 
     133            DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
     134               qsr(ji,jj) =     sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1) 
    133135            END_2D 
    134136         ENDIF 
    135          DO_2D( 0, 0, 0, 0 )                                      ! set the ocean fluxes from read fields 
     137         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls )                  ! set the ocean fluxes from read fields 
    136138            utau(ji,jj) =   sf(jp_utau)%fnow(ji,jj,1)                              * umask(ji,jj,1) 
    137139            vtau(ji,jj) =   sf(jp_vtau)%fnow(ji,jj,1)                              * vmask(ji,jj,1) 
    … …  
    143145         !!clem: I do not think it is needed 
    144146         !!qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp        ! mass flux is at SST 
    145          ! 
    146          ! clem: without these lbc calls, it seems that the northfold is not ok (true in 3.6, not sure in 4.x) 
    147          CALL lbc_lnk_multi( 'sbcflx', utau, 'U', -1._wp, vtau, 'V', -1._wp, & 
    148             &                           qns, 'T',  1._wp, emp , 'T',  1._wp, qsr, 'T', 1._wp ) !! sfx, 'T', 1._wp  ) 
    149147         ! 
    150148         IF( nitend-nit000 <= 100 .AND. lwp ) THEN                ! control print (if less than 100 time-step asked) 
    … …  
    172170      END_2D 
    173171      ! 
    174       CALL lbc_lnk_multi( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp ) 
     172      CALL lbc_lnk( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp ) 
    175173      ! 
    176174   END SUBROUTINE sbc_flx 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/SBC/sbcice_cice.F90

    r14215 r14574  
    222222      END_2D 
    223223 
    224       CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1.0_wp,  fr_iv , 'V', 1.0_wp ) 
     224      CALL lbc_lnk( 'sbcice_cice', fr_iu , 'U', 1.0_wp,  fr_iv , 'V', 1.0_wp ) 
    225225 
    226226      ! set the snow+ice mass 
    … …  
    569569      fmmflx(:,:) = ztmp1(:,:) !!Joakim edit 
    570570       
    571       CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1.0_wp, sfx , 'T', 1.0_wp ) 
     571      CALL lbc_lnk( 'sbcice_cice', emp , 'T', 1.0_wp, sfx , 'T', 1.0_wp ) 
    572572 
    573573! Solar penetrative radiation and non solar surface heat flux 
    … …  
    626626      END_2D 
    627627 
    628       CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp ) 
     628      CALL lbc_lnk( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp ) 
    629629 
    630630      ! set the snow+ice mass 
    … …  
    877877! (may be OK but not 100% sure) 
    878878 
    879       IF(nproc==0) THEN      
     879      IF(narea==1) THEN      
    880880!        pcg(:,:)=0.0 
    881881         DO jn=1,jpnij 
    … …  
    998998! the lbclnk call on pn will replace these with sensible values 
    999999 
    1000       IF(nproc==0) THEN 
     1000      IF(narea==1) THEN 
    10011001         png(:,:,:)=0.0 
    10021002         DO jn=1,jpnij 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/SBC/sbcwave.F90

    r14072 r14574  
    211211      ENDIF 
    212212 
    213       CALL lbc_lnk_multi( 'sbcwave', usd, 'U', -1.0_wp, vsd, 'V', -1.0_wp ) 
     213      CALL lbc_lnk( 'sbcwave', usd, 'U', -1.0_wp, vsd, 'V', -1.0_wp ) 
    214214 
    215215      ! 
    … …  
    503503               ! 
    504504               CALL fld_fill( sf_sd, slf_i, cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) 
     505               sf_sd(jp_usd)%zsgn = -1._wp   ;  sf_sd(jp_vsd)%zsgn = -1._wp   ! vector field at T point: overwrite default definition of zsgn 
    505506            ENDIF 
    506507            ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TDE/tide.h90

    r11865 r14574  
    6767   !                         |                                                              Diurnal tidal constituents                                                                | 
    6868   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    69    tide_components( 8) = tide( 'K1'   , -0.142486_wp ,  1 ,  0 ,  1 ,  0 ,   0 ,    90 ,   0 ,    0 ,   -1 ,    0 ,  0 , 227 )      ! CE73           | S54 (Table 2)         | Note 1 | 
     69   tide_components( 8) = tide( 'K1'   ,  0.142486_wp ,  1 ,  0 ,  1 ,  0 ,   0 ,   -90 ,   0 ,    0 ,   -1 ,    0 ,  0 , 227 )      ! CE73, sign     | S54 (Table 2)         | Note 1 | 
     70   !                         |        |              |    |    |    |    |     |       |     |      |      |      |    |            | change         |                       |        | 
    7071   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    7172   tide_components( 9) = tide( 'O1'   ,  0.101316_wp ,  1 , -2 ,  1 ,  0 ,   0 ,    90 ,   2 ,   -1 ,    0 ,    0 ,  0 ,  75 )      ! CE73           | S54 (Table 2, A14)    |        | 
    … …  
    7576   tide_components(11) = tide( 'Q1'   ,  0.019396_wp ,  1 , -3 ,  1 ,  1 ,   0 ,    90 ,   2 ,   -1 ,    0 ,    0 ,  0 ,  75 )      ! CE73           | S54 (Table 2, A15)    |        | 
    7677   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    77    tide_components(12) = tide( 'J1'   , -0.007967_wp ,  1 ,  1 ,  1 , -1 ,   0 ,    90 ,   0 ,   -1 ,    0 ,    0 ,  0 ,  76 )      ! CE73           | S54 (Table 2, A24)    | Note 1 | 
     78   tide_components(12) = tide( 'J1'   ,  0.007967_wp ,  1 ,  1 ,  1 , -1 ,   0 ,   -90 ,   0 ,   -1 ,    0 ,    0 ,  0 ,  76 )      ! CE73, sign     | S54 (Table 2, A24)    | Note 1 | 
     79   !                         |        |              |    |    |    |    |     |       |     |      |      |      |    |            | change         |                       |        | 
    7880   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    7981   tide_components(13) = tide( 'S1'   ,  0.000000_wp ,  1 ,  0 ,  0 ,  0 ,   0 ,     0 ,   0 ,    0 ,    0 ,    0 ,  0 ,   0 )      ! Meteorological | S54 (Table 2, B71)    |        | 
    … …  
    9698   tide_components(20) = tide( '2N2'  ,  0.006184_wp ,  2 , -4 ,  2 ,  2 ,   0 ,     0 ,   2 ,   -2 ,    0 ,    0 ,  0 ,  78 )      ! CE73           | S54 (Table 2, A42)    |        | 
    9799   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    98    tide_components(21) = tide( 'L2'   , -0.006899_wp ,  2 , -1 ,  2 , -1 ,   0 ,     0 ,   2 ,   -2 ,    0 ,    0 , -1 , 215 )      ! CE73           | S54 (Table 2)         | Note 1 | 
     100   tide_components(21) = tide( 'L2'   ,  0.006899_wp ,  2 , -1 ,  2 , -1 ,   0 ,   180 ,   2 ,   -2 ,    0 ,    0 , -1 , 215 )      ! CE73, sign     | S54 (Table 2)         | Note 1 | 
     101   !                         |        |              |    |    |    |    |     |       |     |      |      |      |    |            | change         |                       |        | 
    99102   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    100103   tide_components(22) = tide( 'T2'   ,  0.006655_wp ,  2 ,  0 , -1 ,  0 ,   1 ,     0 ,   0 ,    0 ,    0 ,    0 ,  0 ,   0 )      ! CE73           | S54 (Table 2, B40)    |        | 
    … …  
    103106   !                         |        |              |    |    |    |    |     |       |     |      |      |      |    |            |                | algorithm)            |        | 
    104107   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    105    tide_components(24) = tide( 'lam2' , -0.001800_wp ,  2 , -1 ,  0 ,  1 ,   0 ,     0 ,   2 ,   -2 ,    0 ,    0 ,  0 ,  78 )      ! CE73           | S54 (Table 2, A44)    | Note 1 | 
     108   tide_components(24) = tide( 'lam2' ,  0.001800_wp ,  2 , -1 ,  0 ,  1 ,   0 ,   180 ,   2 ,   -2 ,    0 ,    0 ,  0 ,  78 )      ! CE73, sign     | S54 (Table 2, A44)    | Note 1 | 
     109   !                         |        |              |    |    |    |    |     |       |     |      |      |      |    |            | change         |                       |        | 
    106110   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    107    tide_components(25) = tide( 'R2'   , -0.000952_wp ,  2 ,  0 ,  1 ,  0 ,  -1 ,     0 ,   0 ,    0 ,    0 ,    0 ,  0 ,   0 )      ! CE73           | S54 (Table 2, B41)    | Note 1 | 
     111   tide_components(25) = tide( 'R2'   ,  0.000952_wp ,  2 ,  0 ,  1 ,  0 ,  -1 ,   180 ,   0 ,    0 ,    0 ,    0 ,  0 ,   0 )      ! CE73, sign     | S54 (Table 2, B41)    | Note 1 | 
     112   !                         |        |              |    |    |    |    |     |       |     |      |      |      |    |            | change         |                       |        | 
    108113   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    109114   !                         |                                                            Terdiurnal tidal constituents                                                               | 
    110115   !                         +--------+-------------+-----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    111    tide_components(26) = tide( 'M3'   , -0.003192_wp ,  3 , -3 ,  3 ,  0 ,   0 ,   180 ,   3 ,   -3 ,    0 ,    0 ,  0 , 149 )      ! CT71           | S54 (Table 2, A82)    | Note 2 | 
     116   tide_components(26) = tide( 'M3'   ,  0.003192_wp ,  3 , -3 ,  3 ,  0 ,   0 ,     0 ,   3 ,   -3 ,    0 ,    0 ,  0 , 149 )      ! CT71, sign     | S54 (Table 2, A82)    | Note 2 | 
     117   !                         |        |              |    |    |    |    |     |       |     |      |      |      |    |            | change         |                       |        | 
    112118   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    113119   !                         |                                                                    Compound tides                                                                      | 
    … …  
    135141   tide_components(34) = tide( 'M8'   ,  0.000000_wp ,  8 , -8 ,  8 ,  0 ,  0  ,     0 ,   8 ,   -8 ,    0 ,    0 ,  0 ,  20 )      ! Overtide       | S54                   |        | 
    136142   !                         +--------+--------------+----+----+----+----+-----+-------+-----+------+------+------+----+------------+----------------+-----------------------+--------+ 
    137    !   Note 1: the phase shift from Table 2 of S54 has been adjusted to accomodate the negative sign of the equilibrium-tide value derived from CE73. 
    138    !   Note 2: the phase shift from Table 2 of S54 has been adjusted to accomodate the negative sign of the equilibrium-tide value derived from CT71. 
     143   !   Note 1: the negative sign of the equilibrium-tide value derived from CE73 has been changed to accomodate the phase shift from Table 2 of S54. 
     144   !   Note 2: the negative sign of the equilibrium-tide value derived from CT71 has been changed to accomodate the phase shift from Table 2 of S54. 
    139145   !   Note 3: the nodal correction factor formulas from FES2014 and S54 differ; here, the version from FES2014 has been selected. 
    140146#else 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/traadv.F90

    r14537 r14574  
    182182         CASE ( np_FCT )                                 ! FCT scheme      : 2nd / 4th order 
    183183            IF (nn_hls.EQ.2) THEN 
    184                CALL lbc_lnk_multi( 'traadv', pts(:,:,:,:,Kbb), 'T', 1., pts(:,:,:,:,Kmm), 'T', 1.) 
    185                CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 
     184               CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1., pts(:,:,:,:,Kmm), 'T', 1.) 
     185               CALL lbc_lnk( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 
    186186#if defined key_loop_fusion 
    187187               CALL tra_adv_fct_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) 
    … …  
    208208         CASE ( np_QCK )                                 ! QUICKEST 
    209209            IF (nn_hls.EQ.2) THEN 
    210                CALL lbc_lnk_multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 
     210               CALL lbc_lnk( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 
    211211               CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 
    212212            END IF 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/traadv_cen.F90

    r14537 r14574  
    119119               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    120120            END_3D 
    121             IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. 
     121            IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. 
    122122            ! 
    123123            DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 )           ! Horizontal advective fluxes 
    … …  
    131131               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v 
    132132            END_3D 
    133             IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) 
     133            IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) 
    134134            ! 
    135135         CASE DEFAULT 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/traadv_fct.F90

    r14537 r14574  
    238238               END_2D 
    239239            END DO 
    240             CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     240            CALL lbc_lnk( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    241241            ! 
    242242            DO_3D( 1, 0, 1, 0, 1, jpkm1 ) 
    … …  
    247247               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) 
    248248            END_3D 
    249             IF (nn_hls.EQ.2) CALL lbc_lnk_multi( 'traadv_fct', zwx, 'U', -1.0_wp, zwy, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     249            IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv_fct', zwx, 'U', -1.0_wp, zwy, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    250250            ! 
    251251         CASE(  41 )                   !- 4th order centered       ==>>   !!gm coding attempt   need to be tested 
    … …  
    256256               ztv(ji,jj,jk) = ( pt(ji  ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 
    257257            END_3D 
    258             IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    259             ! 
    260             IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     258            IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    261259            ! 
    262260            DO_3D( 0, 0, 0, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
    … …  
    270268               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 
    271269            END_3D 
    272             IF (nn_hls.EQ.2) CALL lbc_lnk_multi( 'traadv_fct', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     270            IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv_fct', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    273271            ! 
    274272         END SELECT 
    … …  
    294292         ! 
    295293         IF (nn_hls.EQ.1) THEN 
    296             CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp ) 
    297          ELSE 
    298             CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) 
    299          END IF 
    300          ! 
    301          IF (nn_hls.EQ.1) THEN 
    302             CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp ) 
     294            CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp ) 
    303295         ELSE 
    304296            CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) 
    … …  
    457449         END_2D 
    458450      END DO 
    459       IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp )   ! lateral boundary cond. (unchanged sign) 
     451      IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp )   ! lateral boundary cond. (unchanged sign) 
    460452 
    461453      ! 3. monotonic flux in the i & j direction (paa & pbb) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/traadv_fct_lf.F90

    r14072 r14574  
    270270               END_2D 
    271271            END DO 
    272             CALL lbc_lnk_multi( 'traadv_fct', zltu_3d, 'T', 1.0_wp , zltv_3d, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     272            CALL lbc_lnk( 'traadv_fct', zltu_3d, 'T', 1.0_wp , zltv_3d, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    273273!            ! 
    274274            DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) 
    … …  
    280280            END_3D 
    281281            ! 
    282             CALL lbc_lnk_multi( 'traadv_fct', zwx_3d, 'U', -1.0_wp , zwy_3d, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     282            CALL lbc_lnk( 'traadv_fct', zwx_3d, 'U', -1.0_wp , zwy_3d, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    283283         CASE(  41 )                   !- 4th order centered       ==>>   !!gm coding attempt   need to be tested 
    284284            DO_3D( 0, 0, 0, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
    … …  
    298298               zwy_3d(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy_3d(ji,jj,jk) 
    299299            END_3D 
    300             CALL lbc_lnk_multi( 'traadv_fct', zwx_3d, 'U', -1.0_wp , zwy_3d, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     300            CALL lbc_lnk( 'traadv_fct', zwx_3d, 'U', -1.0_wp , zwy_3d, 'V', -1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    301301            ! 
    302302         END SELECT 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/traadv_mus.F90

    r14537 r14574  
    140140         END_3D 
    141141         ! lateral boundary conditions   (changed sign) 
    142          IF ( nn_hls.EQ.1 ) CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) 
     142         IF ( nn_hls.EQ.1 ) CALL lbc_lnk( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) 
    143143         !                                !-- Slopes of tracer 
    144144         zslpx(:,:,jpk) = 0._wp                 ! bottom values 
    … …  
    176176            zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 
    177177         END_3D 
    178          IF ( nn_hls.EQ.1 ) CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )   ! lateral boundary conditions   (changed sign) 
     178         IF ( nn_hls.EQ.1 ) CALL lbc_lnk( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )   ! lateral boundary conditions   (changed sign) 
    179179         ! 
    180180         DO_3D( 0, 0, 0, 0, 1, jpkm1 )    !-- Tracer advective trend 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/traadv_qck.F90

    r14537 r14574  
    149149            zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb)        ! Downstream in the x-direction for the tracer 
    150150         END_3D 
    151          IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions 
     151         IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions 
    152152 
    153153         ! 
    … …  
    167167         END_3D 
    168168         !--- Lateral boundary conditions 
    169          IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp,  zwx(:,:,:), 'T', 1.0_wp ) 
     169         IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp,  zwx(:,:,:), 'T', 1.0_wp ) 
    170170 
    171171         !--- QUICKEST scheme 
    … …  
    239239            END_2D 
    240240         END DO 
    241          IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions 
     241         IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp )   ! Lateral boundary conditions 
    242242 
    243243         ! 
    … …  
    259259 
    260260         !--- Lateral boundary conditions 
    261          IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) 
     261         IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) 
    262262 
    263263         !--- QUICKEST scheme 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/traadv_ubs.F90

    r14537 r14574  
    140140            ! 
    141141         END DO 
    142          IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'traadv_ubs', zltu, 'T', 1.0_wp, zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
     142         IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp, zltv, 'T', 1.0_wp )   ! Lateral boundary cond. (unchanged sgn) 
    143143         ! 
    144144         DO_3D( 1, 0, 1, 0, 1, jpkm1 )   !==  Horizontal advective fluxes  ==!     (UBS) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/traatf.F90

    r14072 r14574  
    110110#endif 
    111111      !                                              ! local domain boundaries  (T-point, unchanged sign) 
    112       CALL lbc_lnk_multi( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 
     112      CALL lbc_lnk( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 
    113113      ! 
    114114      IF( ln_bdy )   CALL bdy_tra( kt, Kbb, pts, Kaa )  ! BDY open boundaries 
    … …  
    156156         ENDIF 
    157157         ! 
    158          CALL lbc_lnk_multi( 'traatf',  pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp ) 
     158         CALL lbc_lnk( 'traatf',  pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp ) 
    159159 
    160160      ENDIF 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/traatf_qco.F90

    r14072 r14574  
    146146         ENDIF 
    147147         ! 
    148          CALL lbc_lnk_multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp ) 
     148         CALL lbc_lnk( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp ) 
    149149         ! 
    150150      ENDIF 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/trabbl.F90

    r14537 r14574  
    141141         IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN                       ! Do only on the last tile 
    142142            ! lateral boundary conditions ; just need for outputs 
    143             CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 
     143            CALL lbc_lnk( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 
    144144         CALL iom_put( "uoce_bbl", utr_bbl )  ! bbl i-transport 
    145145         CALL iom_put( "voce_bbl", vtr_bbl )  ! bbl j-transport 
    … …  
    518518      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    519519      zmbku(:,:) = REAL( mbku_d(:,:), wp )   ;     zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) 
    520       CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp) 
     520      CALL lbc_lnk( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp) 
    521521      mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ;  mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) 
    522522      ! 
    … …  
    537537         e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 
    538538      END_2D 
    539       CALL lbc_lnk_multi( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp )      ! lateral boundary conditions 
     539      CALL lbc_lnk( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp )      ! lateral boundary conditions 
    540540      ! 
    541541      !                             !* masked diffusive flux coefficients 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/tramle.F90

    r14210 r14574  
    361361               rfv(ji,jj) = SQRT(  zfv * zfv + z1_t2 ) 
    362362            END_2D 
    363             CALL lbc_lnk_multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 
     363            CALL lbc_lnk( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 
    364364            ! 
    365365         ELSEIF( nn_mle == 1 ) THEN           ! MLE array allocation & initialisation 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/trazdf.F90

    r14537 r14574  
    102102         END DO 
    103103!!gm this should be moved in trdtra.F90 and done on all trends 
    104          CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) 
     104         CALL lbc_lnk( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) 
    105105!!gm 
    106106         CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_zdf, ztrdt ) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRA/zpshde.F90

    r14189 r14574  
    173173      END DO 
    174174      ! 
    175       IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
     175      IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
    176176      ! 
    177177      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
    … …  
    206206            ENDIF 
    207207         END_2D 
    208          IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
     208         IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
    209209         ! 
    210210      END IF 
    … …  
    359359      END DO 
    360360      ! 
    361       IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
     361      IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
    362362 
    363363      ! horizontal derivative of density anomalies (rd) 
    … …  
    401401         END_2D 
    402402 
    403          IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
     403         IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp )   ! Lateral boundary conditions 
    404404         ! 
    405405      END IF 
    … …  
    452452         ! 
    453453      END DO 
    454       IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
     454      IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp )   ! Lateral boundary cond. 
    455455 
    456456      IF( PRESENT( prd ) ) THEN    !==  horizontal derivative of density anomalies (rd)  ==!    (optional part) 
    … …  
    491491 
    492492         END_2D 
    493          IF (nn_hls.EQ.1) CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp )   ! Lateral boundary conditions 
     493         IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp )   ! Lateral boundary conditions 
    494494         ! 
    495495      END IF 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRD/trddyn.F90

    r13497 r14574  
    128128                                 z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) ) 
    129129                              END_3D 
    130                               CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) 
     130                              CALL lbc_lnk( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) 
    131131                              CALL iom_put( "utrd_udx", z3dx  ) 
    132132                              CALL iom_put( "vtrd_vdy", z3dy  ) 
    … …  
    164164!                                 END DO 
    165165!                              END DO 
    166 !                              CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) 
     166!                              CALL lbc_lnk( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) 
    167167!                              CALL iom_put( "utrd_bfr", z3dx ) 
    168168!                              CALL iom_put( "vtrd_bfr", z3dy ) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRD/trdken.F90

    r13295 r14574  
    9090      !!---------------------------------------------------------------------- 
    9191      ! 
    92       CALL lbc_lnk_multi( 'trdken', putrd, 'U', -1.0_wp , pvtrd, 'V', -1.0_wp )      ! lateral boundary conditions 
     92      CALL lbc_lnk( 'trdken', putrd, 'U', -1.0_wp , pvtrd, 'V', -1.0_wp )      ! lateral boundary conditions 
    9393      ! 
    9494      nkstp = kt 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRD/trdmxl.F90

    r13497 r14574  
    154154!!gm to be put juste before the output ! 
    155155!      ! Lateral boundary conditions 
    156 !      CALL lbc_lnk_multi( 'trdmxl', tmltrd(:,:,jl), 'T', 1.0_wp , smltrd(:,:,jl), 'T', 1.0_wp ) 
     156!      CALL lbc_lnk( 'trdmxl', tmltrd(:,:,jl), 'T', 1.0_wp , smltrd(:,:,jl), 'T', 1.0_wp ) 
    157157!!gm end 
    158158 
    … …  
    472472         !-- Lateral boundary conditions 
    473473         !         ... temperature ...                    ... salinity ... 
    474          CALL lbc_lnk_multi( 'trdmxl', ztmltot , 'T', 1.0_wp, zsmltot , 'T', 1.0_wp, & 
    475                   &          ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, & 
    476                   &          ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp ) 
     474         CALL lbc_lnk( 'trdmxl', ztmltot , 'T', 1.0_wp, zsmltot , 'T', 1.0_wp, & 
     475            &                    ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, & 
     476            &                    ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp ) 
    477477 
    478478 
    … …  
    523523         !-- Lateral boundary conditions 
    524524         !         ... temperature ...                    ... salinity ... 
    525          CALL lbc_lnk_multi( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, & 
    526                   &          ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp ) 
    527          ! 
    528          CALL lbc_lnk_multi( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! /  in the NetCDF trends file 
     525         CALL lbc_lnk( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, & 
     526            &                    ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp ) 
     527         ! 
     528         CALL lbc_lnk( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! /  in the NetCDF trends file 
    529529          
    530530         ! III.3 Time evolution array swap 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/TRD/trdvor.F90

    r13497 r14574  
    162162 
    163163      zudpvor(:,:) = 0._wp                 ;   zvdpvor(:,:) = 0._wp                    ! Initialisation 
    164       CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp )      ! lateral boundary condition 
     164      CALL lbc_lnk( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp )      ! lateral boundary condition 
    165165       
    166166 
    … …  
    251251      zvdpvor(:,:) = 0._wp 
    252252      !                            ! lateral boundary condition on input momentum trends 
    253       CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp ) 
     253      CALL lbc_lnk( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp ) 
    254254 
    255255      !  ===================================== 
    … …  
    400400 
    401401         ! Boundary conditions 
    402          CALL lbc_lnk_multi( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp ) 
     402         CALL lbc_lnk( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp ) 
    403403 
    404404 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/USR/README.rst

    r14239 r14574  
    5858 
    5959.. _here: https://prodn.idris.fr/thredds/catalog/ipsl_public/rron463/catalog.html 
     60 
     61Option 4: Use the nesting tools to create embedded zooms or regional configurations from an existing grid 
     62--------------------------------------------------------------------------------------------------------- 
     63(see :download:`NESTING README <../../../tools/NESTING/README>`). 
     64 
    6065 
    6166Creating a completely new configuration 
    … …  
    111116   /* configuration name, configuration resolution                 */ 
    112117   int    ORCA, ORCA_index 
    113    /* global domain sizes                                          */ 
    114    int    jpiglo, jpjglo, jpkglo 
    115118   /* lateral global domain b.c.                                   */ 
    116    int    jperio 
     119   int    Iperio, Jperio, NFoldT, NFoldF 
    117120   /* flags for z-coord, z-coord with partial steps and s-coord    */ 
    118121   int    ln_zco, ln_zps, ln_sco 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/USR/usrdef_nam.F90

    r14072 r14574  
    3737CONTAINS 
    3838 
    39    SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 
     39   SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 
    4040      !!---------------------------------------------------------------------- 
    4141      !!                     ***  ROUTINE dom_nam  *** 
    … …  
    4949      !! ** input   : - namusr_def namelist found in namelist_cfg 
    5050      !!---------------------------------------------------------------------- 
    51       CHARACTER(len=*), INTENT(out) ::   cd_cfg          ! configuration name 
    52       INTEGER         , INTENT(out) ::   kk_cfg          ! configuration resolution 
    53       INTEGER         , INTENT(out) ::   kpi, kpj, kpk   ! global domain sizes 
    54       INTEGER         , INTENT(out) ::   kperio          ! lateral global domain b.c. 
     51      CHARACTER(len=*), INTENT(out) ::   cd_cfg               ! configuration name 
     52      INTEGER         , INTENT(out) ::   kk_cfg               ! configuration resolution 
     53      INTEGER         , INTENT(out) ::   kpi, kpj, kpk        ! global domain sizes 
     54      LOGICAL         , INTENT(out) ::   ldIperio, ldJperio   ! i- and j- periodicity 
     55      LOGICAL         , INTENT(out) ::   ldNFold              ! North pole folding 
     56      CHARACTER(len=1), INTENT(out) ::   cdNFtype             ! Folding type: T or F 
    5557      ! 
    5658      INTEGER ::   ios   ! Local integer 
    … …  
    8284      kpk = jpkglo 
    8385      !                             ! Set the lateral boundary condition of the global domain 
    84       kperio = 0                    ! GYRE configuration : closed domain 
     86      ldIperio = .FALSE.   ;   ldJperio = .FALSE.   ! GYRE configuration : closed domain 
     87      ldNFold  = .FALSE.   ;   cdNFtype = '-' 
    8588      ! 
    8689      !                             ! control print 
    … …  
    102105         WRITE(numout,*) '      number of model levels                           jpkglo = ', kpk 
    103106         WRITE(numout,*) '   ' 
    104          WRITE(numout,*) '   Lateral b.c. of the global domain set to closed     jperio = ', kperio 
    105107      ENDIF 
    106108      ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/USR/usrdef_sbc.F90

    r13295 r14574  
    181181         wndm(ji,jj) = SQRT( zmod * zcoef ) 
    182182      END_2D 
    183       CALL lbc_lnk_multi( 'usrdef_sbc', taum(:,:), 'T', 1.0_wp , wndm(:,:), 'T', 1.0_wp ) 
     183      CALL lbc_lnk( 'usrdef_sbc', taum(:,:), 'T', 1.0_wp , wndm(:,:), 'T', 1.0_wp ) 
    184184 
    185185      ! ---------------------------------- ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ZDF/zdfmfc.F90

    r14072 r14574  
    376376      ! 
    377377      ! 
    378       CALL lbc_lnk_multi( 'zdfmfc', edmfm,'T',1., edmfa,'T',1., edmfb,'T',1., edmfc,'T',1., edmftra(:,:,:,jp_tem),'T',1., edmftra(:,:,:,jp_sal),'T',1.) 
     378      CALL lbc_lnk( 'zdfmfc', edmfm,'T',1., edmfa,'T',1., edmfb,'T',1., edmfc,'T',1., edmftra(:,:,:,jp_tem),'T',1., edmftra(:,:,:,jp_sal),'T',1.) 
    379379      ! 
    380380   END SUBROUTINE tra_mfc 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ZDF/zdfosm.F90

    r14215 r14574  
    11631163     END_3D 
    11641164      ! Lateral boundary conditions on ghamu and ghamv, currently on W-grid  (sign unchanged), needed to caclulate gham[uv] on u and v grids 
    1165      CALL lbc_lnk_multi( 'zdfosm', p_avt, 'W', 1.0_wp , p_avm, 'W', 1.0_wp,   & 
    1166       &                  ghamu, 'W', 1.0_wp , ghamv, 'W', 1.0_wp ) 
     1165     CALL lbc_lnk( 'zdfosm', p_avt, 'W', 1.0_wp , p_avm, 'W', 1.0_wp,   & 
     1166        &                    ghamu, 'W', 1.0_wp , ghamv, 'W', 1.0_wp ) 
    11671167       DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 
    11681168            ghamu(ji,jj,jk) = ( ghamu(ji,jj,jk) + ghamu(ji+1,jj,jk) ) & 
    … …  
    11761176       END_3D 
    11771177        ! Lateral boundary conditions on final outputs for hbl,  on T-grid (sign unchanged) 
    1178         CALL lbc_lnk_multi( 'zdfosm', hbl, 'T', 1., dh, 'T', 1., hmle, 'T', 1. ) 
     1178        CALL lbc_lnk( 'zdfosm', hbl, 'T', 1., dh, 'T', 1., hmle, 'T', 1. ) 
    11791179        ! Lateral boundary conditions on final outputs for gham[ts],  on W-grid  (sign unchanged) 
    11801180        ! Lateral boundary conditions on final outputs for gham[uv],  on [UV]-grid  (sign changed) 
    1181         CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W',  1.0_wp , ghams, 'W',  1.0_wp,   & 
    1182          &                            ghamu, 'U', -1.0_wp , ghamv, 'V', -1.0_wp ) 
     1181        CALL lbc_lnk( 'zdfosm', ghamt, 'W',  1.0_wp , ghams, 'W',  1.0_wp,   & 
     1182           &                    ghamu, 'U', -1.0_wp , ghamv, 'V', -1.0_wp ) 
    11831183 
    11841184      IF(ln_dia_osm) THEN 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/ZDF/zdfphy.F90

    r14072 r14574  
    323323      !                                         !* Lateral boundary conditions (sign unchanged) 
    324324      IF( l_zdfsh2 ) THEN 
    325          CALL lbc_lnk_multi( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp,   & 
    326             &                avm  , 'W', 1.0_wp , avt  , 'W', 1.0_wp , avs , 'W', 1.0_wp ) 
     325         CALL lbc_lnk( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp,   & 
     326            &                    avm  , 'W', 1.0_wp , avt  , 'W', 1.0_wp , avs , 'W', 1.0_wp ) 
    327327      ELSE 
    328          CALL lbc_lnk_multi( 'zdfphy', avm  , 'W', 1.0_wp , avt  , 'W', 1.0_wp , avs , 'W', 1.0_wp ) 
     328         CALL lbc_lnk( 'zdfphy', avm  , 'W', 1.0_wp , avt  , 'W', 1.0_wp , avs , 'W', 1.0_wp ) 
    329329      ENDIF 
    330330      ! 
    331331      IF( l_zdfdrg ) THEN     ! drag  have been updated (non-linear cases) 
    332          IF( ln_isfcav ) THEN   ;  CALL lbc_lnk_multi( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp )   ! top & bot drag 
    333          ELSE                   ;  CALL lbc_lnk      ( 'zdfphy', rCdU_bot, 'T', 1.0_wp )                       ! bottom drag only 
     332         IF( ln_isfcav ) THEN   ;  CALL lbc_lnk( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp )   ! top & bot drag 
     333         ELSE                   ;  CALL lbc_lnk( 'zdfphy', rCdU_bot, 'T', 1.0_wp )                       ! bottom drag only 
    334334         ENDIF 
    335335      ENDIF 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/lib_fortran.F90

    r13327 r14574  
    220220      ! 
    221221      DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    222          IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   & 
     222         IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   &              ! 1st bottom left corner always at (Nis0-1, Njs0-1) 
    223223           & MOD(mjg(jj), 3) == MOD(nn_hls, 3)         ) THEN         ! bottom left corner of a 3x3 box 
    224224            ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box 
    … …  
    230230      END_2D 
    231231      CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 
    232       ! no need for 2nd exchange when nn_hls = 2 
    233       IF( nn_hls /= 2 ) THEN 
    234          IF( nbondi /= -1 ) THEN 
    235             IF( MOD(mig(    1), 3) == 1 )   p2d(    1,:) = p2d(    2,:) 
    236             IF( MOD(mig(    1), 3) == 2 )   p2d(    2,:) = p2d(    1,:) 
    237          ENDIF 
    238          IF( nbondi /=  1 ) THEN 
     232      ! no need for 2nd exchange when nn_hls > 1 
     233      IF( nn_hls == 1 ) THEN 
     234         IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN   ! 1st column was changed during the previous call to lbc_lnk 
     235            IF( MOD(mig(    1), 3) == 1 )   &   ! 1st box start at i=1 -> column 1 to 3 correctly computed locally 
     236               p2d(    1,:) = p2d(    2,:)      ! previous lbc_lnk corrupted column 1 -> put it back using column 2  
     237            IF( MOD(mig(    1), 3) == 2 )   &   ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh 
     238               p2d(    2,:) = p2d(    1,:)      !  previous lbc_lnk fix column 1 -> copy it to column 2  
     239         ENDIF 
     240         IF( mpiRnei(nn_hls,jpea) > -1 ) THEN 
    239241            IF( MOD(mig(jpi-2), 3) == 1 )   p2d(  jpi,:) = p2d(jpi-1,:) 
    240242            IF( MOD(mig(jpi-2), 3) == 0 )   p2d(jpi-1,:) = p2d(  jpi,:) 
    241243         ENDIF 
    242          IF( nbondj /= -1 ) THEN 
     244         IF( mpiRnei(nn_hls,jpso) > -1 ) THEN 
    243245            IF( MOD(mjg(    1), 3) == 1 )   p2d(:,    1) = p2d(:,    2) 
    244246            IF( MOD(mjg(    1), 3) == 2 )   p2d(:,    2) = p2d(:,    1) 
    245247         ENDIF 
    246          IF( nbondj /=  1 ) THEN 
     248         IF( mpiRnei(nn_hls,jpno) > -1 ) THEN 
    247249            IF( MOD(mjg(jpj-2), 3) == 1 )   p2d(:,  jpj) = p2d(:,jpj-1) 
    248250            IF( MOD(mjg(jpj-2), 3) == 0 )   p2d(:,jpj-1) = p2d(:,  jpj) 
    … …  
    274276         ! 
    275277         DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 
    276             IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   & 
     278            IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND.   &              ! 1st bottom left corner always at (Nis0-1, Njs0-1) 
    277279              & MOD(mjg(jj), 3) == MOD(nn_hls, 3)         ) THEN         ! bottom left corner of a 3x3 box 
    278280               ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1                  ! right position of the box 
    … …  
    285287      END DO 
    286288      CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 
    287       ! no need for 2nd exchange when nn_hls = 2 
    288       IF( nn_hls /= 2 ) THEN 
    289          IF( nbondi /= -1 ) THEN 
    290             IF( MOD(mig(    1), 3) == 1 )   p3d(    1,:,:) = p3d(    2,:,:) 
    291             IF( MOD(mig(    1), 3) == 2 )   p3d(    2,:,:) = p3d(    1,:,:) 
    292          ENDIF 
    293          IF( nbondi /=  1 ) THEN 
     289      ! no need for 2nd exchange when nn_hls > 1 
     290      IF( nn_hls == 1 ) THEN 
     291         IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN    ! 1st column was changed during the previous call to lbc_lnk 
     292            IF( MOD(mig(    1), 3) == 1 )   &    ! 1st box start at i=1 -> column 1 to 3 correctly computed locally 
     293               p3d(    1,:,:) = p3d(    2,:,:)   ! previous lbc_lnk corrupted column 1 -> put it back using column 2  
     294            IF( MOD(mig(    1), 3) == 2 )   &    ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh 
     295               p3d(    2,:,:) = p3d(    1,:,:)   !  previous lbc_lnk fix column 1 -> copy it to column 2  
     296         ENDIF 
     297         IF( mpiRnei(nn_hls,jpea) > -1 ) THEN 
    294298            IF( MOD(mig(jpi-2), 3) == 1 )   p3d(  jpi,:,:) = p3d(jpi-1,:,:) 
    295299            IF( MOD(mig(jpi-2), 3) == 0 )   p3d(jpi-1,:,:) = p3d(  jpi,:,:) 
    296300         ENDIF 
    297          IF( nbondj /= -1 ) THEN 
     301         IF( mpiRnei(nn_hls,jpso) > -1 ) THEN 
    298302            IF( MOD(mjg(    1), 3) == 1 )   p3d(:,    1,:) = p3d(:,    2,:) 
    299303            IF( MOD(mjg(    1), 3) == 2 )   p3d(:,    2,:) = p3d(:,    1,:) 
    300304         ENDIF 
    301          IF( nbondj /=  1 ) THEN 
     305         IF( mpiRnei(nn_hls,jpno) > -1 ) THEN 
    302306            IF( MOD(mjg(jpj-2), 3) == 1 )   p3d(:,  jpj,:) = p3d(:,jpj-1,:) 
    303307            IF( MOD(mjg(jpj-2), 3) == 0 )   p3d(:,jpj-1,:) = p3d(:,  jpj,:) 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/module_example.F90

    r14537 r14574  
    127127      ! WARNING! the lbc_lnk call could not be compatible with the tiling approach 
    128128      ! please refer to the manual for how to adapt your code 
    129       CALL lbc_lnk( 'module_example', avm, 'T', 1., ncsten=true )     ! Lateral boundary conditions (unchanged sign) 
    130       !                                                                ! ncsten=false for 5-points stencil communication 
    131       !                                                                ! ncsten=true (default)  for 9-points stencil communication 
     129      CALL lbc_lnk( 'module_example', avm, 'T', 1. )     ! Lateral boundary conditions (unchanged sign) 
    132130      ! 
    133131   END SUBROUTINE exa_mpl 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/nemogcm.F90

    r14239 r14574  
    378378      ! 
    379379      IF( ln_read_cfg ) THEN            ! Read sizes in domain configuration file 
    380          CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 
     380         CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 
    381381      ELSE                              ! user-defined namelist 
    382          CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio ) 
     382         CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 
    383383      ENDIF 
    384384      ! 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/par_kind.F90

    r13226 r14574  
    1010   IMPLICIT NONE 
    1111   PRIVATE 
    12  
    13    INTEGER, PUBLIC, PARAMETER ::   jpbyt   = 8    !: real size for mpp communications 
    14    INTEGER, PUBLIC, PARAMETER ::   jpbytda = 4    !: real size in input data files 4 or 8 
    1512 
    1613   ! Number model from which the SELECTED_*_KIND are requested: 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/par_oce.F90

    r14537 r14574  
    9393 
    9494   ! halo with and starting/inding DO-loop indices 
    95    INTEGER, PUBLIC ::   nn_hls   !: halo width (applies to both rows and columns) 
    96    INTEGER, PUBLIC ::   Nis0, Nis1, Nis1nxt2, Nis2   !: start I-index (_0: without halo, _1 or _2: with 1 or 2 halos) 
    97    INTEGER, PUBLIC ::   Nie0, Nie1, Nie1nxt2, Nie2   !: end   I-index (_0: without halo, _1 or _2: with 1 or 2 halos) 
    98    INTEGER, PUBLIC ::   Njs0, Njs1, Njs1nxt2, Njs2   !: start J-index (_0: without halo, _1 or _2: with 1 or 2 halos) 
    99    INTEGER, PUBLIC ::   Nje0, Nje1, Nje1nxt2, Nje2   !: end   J-index (_0: without halo, _1 or _2: with 1 or 2 halos) 
    100    INTEGER, PUBLIC ::   Ni_0, Nj_0, Ni_1, Nj_1, Ni_2, Nj_2   !: domain size (_0: without halo, _1 or _2: with 1 or 2 halos) 
    101    INTEGER, PUBLIC ::   Ni0glo, Nj0glo 
     95   INTEGER, PUBLIC ::   nn_hls           !: halo width (applies to both rows and columns) 
     96   INTEGER, PUBLIC ::   Nis0             !: start I-index without halo 
     97   INTEGER, PUBLIC ::   Nie0             !: end   I-index without halo 
     98   INTEGER, PUBLIC ::   Njs0             !: start J-index without halo 
     99   INTEGER, PUBLIC ::   Nje0             !: end   J-index without halo 
     100   INTEGER, PUBLIC ::   Ni_0, Nj_0       !: local domain size without halo 
     101   INTEGER, PUBLIC ::   Ni0glo, Nj0glo   !: global domain size without halo 
    102102 
    103103   !!---------------------------------------------------------------------- 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/stpctl.F90

    r14143 r14574  
    1515   !!---------------------------------------------------------------------- 
    1616   !!   stp_ctl      : Control the run 
    17    !!   stp_ctl_SWE  : Control the run (SWE only) 
    1817   !!---------------------------------------------------------------------- 
    1918   USE oce             ! ocean dynamics and tracers variables 
    … …  
    3433 
    3534   PUBLIC stp_ctl           ! routine called by step.F90 
    36    PUBLIC stp_ctl_SWE       ! routine called by stpmlf.F90 
    37  
    38    INTEGER                ::   nrunid   ! netcdf file id 
    39    INTEGER, DIMENSION(8)  ::   nvarid   ! netcdf variable id 
    40    INTEGER, DIMENSION(2)  ::   nvarid_SWE   ! netcdf variable id (SWE only) 
     35 
     36   INTEGER, PARAMETER         ::   jpvar = 8 
     37   INTEGER                    ::   nrunid   ! netcdf file id 
     38   INTEGER, DIMENSION(jpvar)  ::   nvarid   ! netcdf variable id 
    4139   !!---------------------------------------------------------------------- 
    4240   !! NEMO/OCE 4.0 , NEMO Consortium (2018) 
    … …  
    4947      !!---------------------------------------------------------------------- 
    5048      !!                    ***  ROUTINE stp_ctl  *** 
    51       !!                      
     49      !! 
    5250      !! ** Purpose :   Control the run 
    5351      !! 
    … …  
    6563      INTEGER, INTENT(in   ) ::   Kmm      ! ocean time level index 
    6664      !! 
     65      INTEGER, PARAMETER              ::   jptst = 4 
    6766      INTEGER                         ::   ji                                    ! dummy loop indices 
    6867      INTEGER                         ::   idtime, istatus 
    69       INTEGER , DIMENSION(9)          ::   iareasum, iareamin, iareamax 
    70       INTEGER , DIMENSION(3,4)        ::   iloc                                  ! min/max loc indices 
     68      INTEGER , DIMENSION(jptst)      ::   iareasum, iareamin, iareamax 
     69      INTEGER , DIMENSION(3,jptst)    ::   iloc                                  ! min/max loc indices 
    7170      REAL(wp)                        ::   zzz, zminsal, zmaxsal                 ! local real  
    72       REAL(wp), DIMENSION(9)          ::   zmax, zmaxlocal 
     71      REAL(wp), DIMENSION(jpvar+1)    ::   zmax 
     72      REAL(wp), DIMENSION(jptst)      ::   zmaxlocal 
    7373      LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce 
    7474      LOGICAL, DIMENSION(jpi,jpj,jpk) ::   llmsk 
    … …  
    7878      ! 
    7979      ll_wrtstp  = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) 
    80       ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1  
     80      ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1 
    8181      ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm 
    8282      ! 
    … …  
    111111            istatus = NF90_ENDDEF(nrunid) 
    112112         ENDIF 
    113          !     
     113         ! 
    114114      ENDIF 
    115115      ! 
    … …  
    123123      !                                   !==  done by all processes at every time step  ==! 
    124124      ! 
    125       llmsk(   1:Nis1,:,:) = .FALSE.                                              ! exclude halos from the checked region 
    126       llmsk(Nie1: jpi,:,:) = .FALSE. 
    127       llmsk(:,   1:Njs1,:) = .FALSE. 
    128       llmsk(:,Nje1: jpj,:) = .FALSE. 
     125      llmsk(     1:nn_hls,:,:) = .FALSE.                                          ! exclude halos from the checked region 
     126      llmsk(Nie0+1:  jpi,:,:) = .FALSE. 
     127      llmsk(:,     1:nn_hls,:) = .FALSE. 
     128      llmsk(:,Nje0+1:  jpj,:) = .FALSE. 
    129129      ! 
    130130      llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp         ! define only the inner domain 
    … …  
    155155         zmax(5:8) = 0._wp 
    156156      ENDIF 
    157       zmax(9) = REAL( nstop, wp )                                                 ! stop indicator 
     157      zmax(jpvar+1) = REAL( nstop, wp )                                           ! stop indicator 
    158158      ! 
    159159      !                                   !==               get global extrema             ==! 
    160160      !                                   !==  done by all processes if writting run.stat  ==! 
    161161      IF( ll_colruns ) THEN 
    162          zmaxlocal(:) = zmax(:) 
     162         zmaxlocal(:) = zmax(1:jptst) 
    163163         CALL mpp_max( "stpctl", zmax )          ! max over the global domain: ok even of ll_0oce = .true.  
    164          nstop = NINT( zmax(9) )                 ! update nstop indicator (now sheared among all local domains) 
     164         nstop = NINT( zmax(jpvar+1) )           ! update nstop indicator (now sheared among all local domains) 
    165165      ELSE 
    166166         ! if no ocean point: MAXVAL returns -HUGE => we must overwrite this value to avoid error handling bellow. 
    167          IF( ll_0oce )   zmax(1:4) = (/ 0._wp, 0._wp, -1._wp, 1._wp /)   ! default "valid" values... 
    168       ENDIF 
    169       ! 
    170       zmax(3) = -zmax(3)                         ! move back from max(-zz) to min(zz) : easier to manage!  
    171       zmax(5) = -zmax(5)                         ! move back from max(-zz) to min(zz) : easier to manage! 
    172       IF( ll_colruns ) THEN 
    173          zmaxlocal(3) = -zmaxlocal(3)            ! move back from max(-zz) to min(zz) : easier to manage!  
    174          zmaxlocal(5) = -zmaxlocal(5)            ! move back from max(-zz) to min(zz) : easier to manage! 
    175       ENDIF 
     167         IF( ll_0oce )   zmax(1:jptst) = (/ 0._wp, 0._wp, -1._wp, 1._wp /)   ! default "valid" values... 
     168      ENDIF 
     169      ! 
     170      zmax(3) = -zmax(3)                              ! move back from max(-zz) to min(zz) : easier to manage!  
     171      zmax(5) = -zmax(5)                              ! move back from max(-zz) to min(zz) : easier to manage! 
     172      IF( ll_colruns ) zmaxlocal(3) = -zmaxlocal(3)   ! move back from max(-zz) to min(zz) : easier to manage! 
    176173      ! 
    177174      !                                   !==              write "run.stat" files              ==! 
    178175      !                                   !==  done only by 1st subdomain at writting timestep  ==! 
    179176      IF( ll_wrtruns ) THEN 
    180          WRITE(numrun,9500) kt, zmax(1), zmax(2), zmax(3), zmax(4) 
    181          DO ji = 1, 6 + 2 * COUNT( (/ln_zad_Aimp/) ) 
     177         WRITE(numrun,9500) kt, zmax(1:jptst) 
     178         DO ji = 1, jpvar - 2 * COUNT( .NOT. (/ln_zad_Aimp/) ) 
    182179            istatus = NF90_PUT_VAR( nrunid, nvarid(ji), (/zmax(ji)/), (/kt/), (/1/) ) 
    183180         END DO 
    … …  
    188185      ! 
    189186      IF ( ln_SEOS.AND.(rn_b0==0._wp) ) THEN             ! Discard checks on salinity 
    190          zmaxsal = +1.e38                                ! if not used in eos 
    191          zminsal = -1.e38  
     187         zmaxsal =  HUGE(1._wp)                               ! if not used in eos 
     188         zminsal = -HUGE(1._wp) 
    192189      ELSE 
    193190         zmaxsal = 100._wp 
    … …  
    195192      ENDIF  
    196193      !  
    197       IF(  zmax(1) >   20._wp .OR.   &                   ! too large sea surface height ( > 20 m ) 
    198          & zmax(2) >   10._wp .OR.   &                   ! too large velocity ( > 10 m/s) 
    199          & zmax(3) <= zminsal .OR.   &                   ! negative or zero sea surface salinity 
    200          & zmax(4) >= zmaxsal .OR.   &                   ! too large sea surface salinity ( > 100 ) 
    201          & zmax(4) <  zminsal .OR.   &                   ! too large sea surface salinity (keep this line for sea-ice) 
    202          & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR.   &               ! NaN encounter in the tests 
    203          & ABS(   zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN   ! Infinity encounter in the tests 
     194      IF(  zmax(1) >   20._wp .OR.   &                        ! too large sea surface height ( > 20 m ) 
     195         & zmax(2) >   10._wp .OR.   &                        ! too large velocity ( > 10 m/s) 
     196         & zmax(3) <= zminsal .OR.   &                        ! negative or zero sea surface salinity 
     197         & zmax(4) >= zmaxsal .OR.   &                        ! too large sea surface salinity ( > 100 ) 
     198         & zmax(4) <  zminsal .OR.   &                        ! too large sea surface salinity (keep this line for sea-ice) 
     199         & ISNAN( SUM(zmax(1:jptst)) ) .OR.   &               ! NaN encounter in the tests 
     200         & ABS(   SUM(zmax(1:jptst)) ) > HUGE(1._wp) ) THEN   ! Infinity encounter in the tests 
    204201         ! 
    205202         iloc(:,:) = 0 
    … …  
    217214            ! find which subdomain has the max. 
    218215            iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
    219             DO ji = 1, 9 
     216            DO ji = 1, jptst 
    220217               IF( zmaxlocal(ji) == zmax(ji) ) THEN 
    221218                  iareamin(ji) = narea   ;   iareamax(ji) = narea   ;   iareasum(ji) = 1 
    … …  
    234231            iloc(1:3,3) = MINLOC(       ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 
    235232            iloc(1:3,4) = MAXLOC(       ts(:,:,:,jp_sal,Kmm) , mask = llmsk(:,:,:) ) 
    236             DO ji = 1, 4   ! local domain indices ==> global domain indices, excluding halos 
     233            DO ji = 1, jptst   ! local domain indices ==> global domain indices, excluding halos 
    237234               iloc(1:2,ji) = (/ mig0(iloc(1,ji)), mjg0(iloc(2,ji)) /) 
    238235            END DO 
    … …  
    253250         CALL dia_wri_state( Kmm, 'output.abort' )     ! create an output.abort file 
    254251         ! 
    255          IF( ll_colruns .or. jpnij == 1 ) THEN   ! all processes synchronized -> use lwp to print in opened ocean.output files 
     252         IF( ll_colruns .OR. jpnij == 1 ) THEN   ! all processes synchronized -> use lwp to print in opened ocean.output files 
    256253            IF(lwp) THEN   ;   CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ctmp4, ctmp5, ' ', ctmp6 ) 
    257254            ELSE           ;   nstop = MAX(1, nstop)   ! make sure nstop > 0 (automatically done when calling ctl_stop) 
    … …  
    271268      ! 
    272269   END SUBROUTINE stp_ctl 
    273  
    274  
    275    SUBROUTINE stp_ctl_SWE( kt, Kmm ) 
    276       !!---------------------------------------------------------------------- 
    277       !!                    ***  ROUTINE stp_ctl_SWE  *** 
    278       !!                      
    279       !! ** Purpose :   Control the run 
    280       !! 
    281       !! ** Method  : - Save the time step in numstp 
    282       !!              - Print it each 50 time steps 
    283       !!              - Stop the run IF problem encountered by setting nstop > 0 
    284       !!                Problems checked: e3t0+ssh minimum smaller that 0 
    285       !!                                  |U|   maximum larger than 10 m/s  
    286       !!                                  ( not for SWE : negative sea surface salinity ) 
    287       !! 
    288       !! ** Actions :   "time.step" file = last ocean time-step 
    289       !!                "run.stat"  file = run statistics 
    290       !!                 nstop indicator sheared among all local domain 
    291       !!---------------------------------------------------------------------- 
    292       INTEGER, INTENT(in   ) ::   kt       ! ocean time-step index 
    293       INTEGER, INTENT(in   ) ::   Kmm      ! ocean time level index 
    294       !! 
    295       INTEGER                         ::   ji                                    ! dummy loop indices 
    296       INTEGER                         ::   idtime, istatus 
    297       INTEGER , DIMENSION(3)          ::   iareasum, iareamin, iareamax 
    298       INTEGER , DIMENSION(3,4)        ::   iloc                                  ! min/max loc indices 
    299       REAL(wp)                        ::   zzz                                   ! local real  
    300       REAL(wp), DIMENSION(3)          ::   zmax, zmaxlocal 
    301       LOGICAL                         ::   ll_wrtstp, ll_colruns, ll_wrtruns, ll_0oce 
    302       LOGICAL, DIMENSION(jpi,jpj,jpk) ::   llmsk 
    303       CHARACTER(len=20)               ::   clname 
    304       !!---------------------------------------------------------------------- 
    305       ! 
    306       IF( nstop > 0 .AND. ngrdstop > -1 )   RETURN   !   stpctl was already called by a child grid 
    307       ! 
    308       ll_wrtstp  = ( MOD( kt-nit000, sn_cfctl%ptimincr ) == 0 ) .OR. ( kt == nitend ) 
    309       ll_colruns = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1  
    310       ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm 
    311       ! 
    312       IF( kt == nit000 ) THEN 
    313          ! 
    314          IF( lwp ) THEN 
    315             WRITE(numout,*) 
    316             WRITE(numout,*) 'stp_ctl_SWE : time-stepping control' 
    317             WRITE(numout,*) '~~~~~~~~~~~' 
    318          ENDIF 
    319          !                                ! open time.step    ascii file, done only by 1st subdomain 
    320          IF( lwm )   CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    321          ! 
    322          IF( ll_wrtruns ) THEN 
    323             !                             ! open run.stat     ascii file, done only by 1st subdomain 
    324             CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    325             !                             ! open run.stat.nc netcdf file, done only by 1st subdomain 
    326             clname = 'run.stat.nc' 
    327             IF( .NOT. Agrif_Root() )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
    328             istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, nrunid ) 
    329             istatus = NF90_DEF_DIM( nrunid, 'time', NF90_UNLIMITED, idtime ) 
    330             istatus = NF90_DEF_VAR( nrunid, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), nvarid_SWE(1) ) 
    331             istatus = NF90_DEF_VAR( nrunid,   'abs_u_max', NF90_DOUBLE, (/ idtime /), nvarid_SWE(2) ) 
    332             istatus = NF90_ENDDEF(nrunid) 
    333          ENDIF 
    334          !     
    335       ENDIF 
    336       ! 
    337       !                                   !==              write current time step              ==! 
    338       !                                   !==  done only by 1st subdomain at writting timestep  ==! 
    339       IF( lwm .AND. ll_wrtstp ) THEN 
    340          WRITE ( numstp, '(1x, i8)' )   kt 
    341          REWIND( numstp ) 
    342       ENDIF 
    343       !                                   !==            test of local extrema           ==! 
    344       !                                   !==  done by all processes at every time step  ==! 
    345       ! 
    346       llmsk(   1:Nis1,:,:) = .FALSE.                                              ! exclude halos from the checked region 
    347       llmsk(Nie1: jpi,:,:) = .FALSE. 
    348       llmsk(:,   1:Njs1,:) = .FALSE. 
    349       llmsk(:,Nje1: jpj,:) = .FALSE. 
    350       ! 
    351       llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp         ! define only the inner domain 
    352       ! 
    353       ll_0oce = .NOT. ANY( llmsk(:,:,1) )                                         ! no ocean point in the inner domain? 
    354       ! 
    355       zmax(1) = MINVAL( -e3t_0(:,:,1)-ssh(:,:,Kmm)  , mask = llmsk(:,:,1)  )       ! e3t_Kmm min 
    356       ! 
    357       llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
    358       zmax(2) = MAXVAL(  ABS( uu(:,:,:,Kmm) )      , mask = llmsk(:,:,:) )        ! velocity max (zonal only) 
    359       zmax(3) = REAL( nstop , wp )                                                ! stop indicator 
    360  
    361       !                                   !==               get global extrema             ==! 
    362       !                                   !==  done by all processes if writting run.stat  ==! 
    363       IF( ll_colruns ) THEN 
    364          zmaxlocal(:) = zmax(:) 
    365          CALL mpp_max( "stpctl", zmax )          ! max over the global domain 
    366          nstop = NINT( zmax(3) )                 ! update nstop indicator (now sheared among all local domains) 
    367       ELSE 
    368          ! if no ocean point: MAXVAL returns -HUGE => we must overwrite this value to avoid error handling bellow. 
    369          IF( ll_0oce )   zmax(1:4) = (/ 0._wp, 0._wp, -1._wp, 1._wp /)   ! default "valid" values... 
    370       ENDIF 
    371       ! 
    372       zmax(1) = -zmax(1)                         ! move back from max(-zz) to min(zz) : easier to manage! 
    373       ! 
    374       !                                   !==              write "run.stat" files              ==! 
    375       !                                   !==  done only by 1st subdomain at writting timestep  ==! 
    376       IF( ll_wrtruns ) THEN 
    377          WRITE(numrun,9500) kt, zmax(1), zmax(2) 
    378          istatus = NF90_PUT_VAR( nrunid, nvarid_SWE(1), (/ zmax(1)/), (/kt/), (/1/) ) 
    379          istatus = NF90_PUT_VAR( nrunid, nvarid_SWE(2), (/ zmax(2)/), (/kt/), (/1/) ) 
    380          IF( kt == nitend )   istatus = NF90_CLOSE(nrunid) 
    381       ENDIF 
    382       !                                   !==               error handling               ==! 
    383       !                                   !==  done by all processes at every time step  ==! 
    384       ! 
    385 !!SWE specific : start 
    386       IF(   zmax(1) <=   0._wp .OR.           &               ! negative e3t_Kmm 
    387          &  zmax(2) >   10._wp .OR.           &               ! too large velocity ( > 10 m/s) 
    388          &  ISNAN( zmax(1) + zmax(2) ) .OR.   &               ! NaN encounter in the tests 
    389          &  ABS(   zmax(1) + zmax(2) ) > HUGE(1._wp) ) THEN   ! Infinity encounter in the tests 
    390          ! 
    391          iloc(:,:) = 0 
    392          IF( ll_colruns ) THEN   ! zmax is global, so it is the same on all subdomains -> no dead lock with mpp_maxloc 
    393             ! first: close the netcdf file, so we can read it 
    394             IF( lwm .AND. kt /= nitend )   istatus = NF90_CLOSE(nrunid) 
    395             ! get global loc on the min/max 
    396             llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp         ! define only the inner domain 
    397             CALL mpp_minloc( 'stpctl', e3t_0(:,:,1) + ssh(:,:,Kmm), llmsk(:,:,1), zzz, iloc(1:2,1) )   ! mpp_maxloc ok if mask = F 
    398             llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
    399             CALL mpp_maxloc( 'stpctl', ABS( uu(:,:,:,Kmm))        , llmsk(:,:,:), zzz, iloc(1:3,2) ) 
    400             ! find which subdomain has the max. 
    401             iareamin(:) = jpnij+1   ;   iareamax(:) = 0   ;   iareasum(:) = 0 
    402             DO ji = 1, 3 
    403                IF( zmaxlocal(ji) == zmax(ji) ) THEN 
    404                   iareamin(ji) = narea   ;   iareamax(ji) = narea   ;   iareasum(ji) = 1 
    405                ENDIF 
    406             END DO 
    407             CALL mpp_min( "stpctl", iareamin )         ! min over the global domain 
    408             CALL mpp_max( "stpctl", iareamax )         ! max over the global domain 
    409             CALL mpp_sum( "stpctl", iareasum )         ! sum over the global domain 
    410          ELSE                    ! find local min and max locations: 
    411             ! if we are here, this means that the subdomain contains some oce points -> no need to test the mask used in maxloc 
    412             llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0 ) == 1._wp        ! define only the inner domain 
    413             iloc(1:2,1) = MINLOC( e3t_0(:,:,1) + ssh(:,:,Kmm), mask = llmsk(:,:,1) ) 
    414             ! 
    415             llmsk(Nis0:Nie0,Njs0:Nje0,:) = umask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp        ! define only the inner domain 
    416             iloc(1:3,2) = MAXLOC( ABS(  uu(:,:,:,       Kmm)), mask = llmsk(:,:,:) ) 
    417             iareamin(:) = narea   ;   iareamax(:) = narea   ;   iareasum(:) = 1         ! this is local information 
    418          ENDIF 
    419          ! 
    420          WRITE(ctmp1,*) ' stp_ctl_SWE:  e3t0+ssh < 0 m  or  |U| > 10 m/s  or  NaN encounter in the tests' 
    421          CALL wrt_line( ctmp2, kt, 'e3t0+ssh min',  zmax(1), iloc(:,1), iareasum(1), iareamin(1), iareamax(1) ) 
    422          CALL wrt_line( ctmp3, kt, '|U|   max'   ,  zmax(2), iloc(:,2), iareasum(2), iareamin(2), iareamax(2) ) 
    423          IF( Agrif_Root() ) THEN 
    424             WRITE(ctmp6,*) '      ===> output of last computed fields in output.abort* files' 
    425          ELSE 
    426             WRITE(ctmp6,*) '      ===> output of last computed fields in '//TRIM(Agrif_CFixed())//'_output.abort* files' 
    427          ENDIF 
    428          ! 
    429          CALL dia_wri_state( Kmm, 'output.abort' )     ! create an output.abort file 
    430          ! 
    431          IF( ll_colruns .or. jpnij == 1 ) THEN   ! all processes synchronized -> use lwp to print in opened ocean.output files 
    432             IF(lwp) THEN   ;   CALL ctl_stop( ctmp1, ' ', ctmp2, ctmp3, ' ', ctmp6 ) 
    433             ELSE           ;   nstop = MAX(1, nstop)   ! make sure nstop > 0 (automatically done when calling ctl_stop) 
    434             ENDIF 
    435          ELSE                                    ! only mpi subdomains with errors are here -> STOP now 
    436             CALL ctl_stop( 'STOP', ctmp1, ' ', ctmp2, ctmp3, ' ', ctmp6 ) 
    437          ENDIF 
    438          ! 
    439       ENDIF 
    440 !!SWE specific : end 
    441       ! 
    442       IF( nstop > 0 ) THEN                                                  ! an error was detected and we did not abort yet... 
    443          ngrdstop = Agrif_Fixed()                                           ! store which grid got this error 
    444          IF( .NOT. ll_colruns .AND. jpnij > 1 )   CALL ctl_stop( 'STOP' )   ! we must abort here to avoid MPI deadlock 
    445       ENDIF 
    446       ! 
    447 9500  FORMAT(' it :', i8, '      e3t_min: ', D23.16, ' |U|_max: ', D23.16) 
    448       ! 
    449    END SUBROUTINE stp_ctl_SWE 
    450270 
    451271 

  • NEMO/branches/2021/dev_r14273_HPC-02_Daley_Tiling/src/OCE/stpmlf.F90

    r14239 r14574  
    508508# endif 
    509509      !                                        ! local domain boundaries  (T-point, unchanged sign) 
    510       CALL lbc_lnk_multi( 'finalize_lbc', puu(:,:,:,       Kaa), 'U', -1., pvv(:,:,:       ,Kaa), 'V', -1.   & 
    511                        &                , pts(:,:,:,jp_tem,Kaa), 'T',  1., pts(:,:,:,jp_sal,Kaa), 'T',  1. ) 
     510      CALL lbc_lnk( 'finalize_lbc', puu(:,:,:,       Kaa), 'U', -1., pvv(:,:,:       ,Kaa), 'V', -1.   & 
     511                       &          , pts(:,:,:,jp_tem,Kaa), 'T',  1., pts(:,:,:,jp_sal,Kaa), 'T',  1. ) 
    512512      ! 
    513513      !                                        !* BDY open boundaries 
Note: See TracChangeset for help on using the changeset viewer.