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 14433 for NEMO/trunk/src/OCE – NEMO

Changeset 14433 for NEMO/trunk/src/OCE


Ignore:
Timestamp:
2021-02-11T09:06:49+01:00 (3 years ago)
Author:
smasson
Message:

trunk: merge dev_r14312_MPI_Interface into the trunk, #2598

Location:
NEMO/trunk/src/OCE
Files:
4 deleted
80 edited
3 copied

Legend:

Unmodified
Added
Removed
  • NEMO/trunk/src/OCE/BDY/bdydyn2d.F90

    r13226 r14433  
    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/trunk/src/OCE/BDY/bdydyn3d.F90

    r13226 r14433  
    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/trunk/src/OCE/BDY/bdyice.F90

    r13601 r14433  
    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/trunk/src/OCE/BDY/bdyini.F90

    r13541 r14433  
    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/trunk/src/OCE/BDY/bdytra.F90

    r14072 r14433  
    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/trunk/src/OCE/CRS/crs.F90

    r13286 r14433  
    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/trunk/src/OCE/CRS/crsdom.F90

    r14275 r14433  
    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(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 (:) 
     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 
     
    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/trunk/src/OCE/CRS/crslbclnk.F90

    r11536 r14433  
    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/trunk/src/OCE/DIA/diacfl.F90

    r13497 r14433  
    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/trunk/src/OCE/DOM/dom_oce.F90

    r14275 r14433  
    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 
     
    8580 
    8681   !                             !: domain MPP decomposition parameters 
    87    INTEGER             , PUBLIC ::   nimpp, njmpp     !: i- & j-indexes for mpp-subdomain left bottom 
    88    INTEGER             , PUBLIC ::   narea            !: number for local area = MPI rank + 1 
    89    INTEGER             , PUBLIC ::   nbondi, nbondj   !: mark of i- and j-direction local boundaries 
    90    INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy(:)    !: mark i-direction local boundaries for BDY open boundaries 
    91    INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy(:)    !: mark j-direction local boundaries for BDY open boundaries 
    92    INTEGER, ALLOCATABLE, PUBLIC ::   nbondi_bdy_b(:)  !: mark i-direction of neighbours local boundaries for BDY open boundaries 
    93    INTEGER, ALLOCATABLE, PUBLIC ::   nbondj_bdy_b(:)  !: mark j-direction of neighbours local boundaries for BDY open boundaries 
    94  
    95    INTEGER, PUBLIC ::   npolj             !: north fold mark (0, 3 or 4) 
    96    INTEGER, PUBLIC ::   noea, nowe        !: index of the local neighboring processors in 
    97    INTEGER, PUBLIC ::   noso, nono        !: east, west, south and north directions 
    98    INTEGER, PUBLIC ::   nones, nonws        !: north-east, north-west directions for sending 
    99    INTEGER, PUBLIC ::   noses, nosws        !: south-east, south-west directions for sending 
    100    INTEGER, PUBLIC ::   noner, nonwr        !: north-east, north-west directions for receiving 
    101    INTEGER, PUBLIC ::   noser, noswr        !: south-east, south-west directions for receiving 
    102    INTEGER, PUBLIC ::   nidom             !: ??? 
     82   INTEGER              , PUBLIC ::   nimpp, njmpp     !: i- & j-indexes for mpp-subdomain left bottom 
     83   INTEGER              , PUBLIC ::   narea            !: number for local area (starting at 1) = MPI rank + 1 
     84   INTEGER,               PUBLIC ::   nidom      !: IOIPSL things... 
    10385 
    10486   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   mig        !: local ==> global domain, including halos (jpiglo), i-index 
     
    11092   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   mj0, mj1   !: global, including halos (jpjglo) ==> local domain j-index 
    11193   !                                                                !:    (mj0=1 and mj1=0 if global index not in local domain) 
    112    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nimppt,  njmppt   !: i-, j-indexes for each processor 
    113    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   ibonit,  ibonjt   !: i-, j- processor neighbour existence 
    114    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   jpiall,  jpjall   !: dimensions of all subdomain 
    115    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nis0all, njs0all  !: first, last indoor index for all i-subdomain 
    116    INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nie0all, nje0all  !: first, last indoor index for all j-subdomain 
    11794   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nfimpp, nfproc, nfjpi 
    11895 
  • NEMO/trunk/src/OCE/DOM/domain.F90

    r14255 r14433  
    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/trunk/src/OCE/DOM/dommsk.F90

    r14215 r14433  
    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/trunk/src/OCE/DOM/domqco.F90

    r14179 r14433  
    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/trunk/src/OCE/DOM/domvvl.F90

    r14140 r14433  
    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/trunk/src/OCE/DOM/domwri.F90

    r13295 r14433  
    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/trunk/src/OCE/DOM/domzgr.F90

    r13295 r14433  
    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/trunk/src/OCE/DYN/dynadv_ubs.F90

    r13497 r14433  
    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/trunk/src/OCE/DYN/dynatf.F90

    r14224 r14433  
    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/trunk/src/OCE/DYN/dynhpg.F90

    r14227 r14433  
    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/trunk/src/OCE/DYN/dynldf_iso.F90

    r14215 r14433  
    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/trunk/src/OCE/DYN/dynldf_lap_blp.F90

    r14053 r14433  
    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/trunk/src/OCE/DYN/dynspg_ts.F90

    r14225 r14433  
    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/trunk/src/OCE/DYN/dynvor.F90

    r14233 r14433  
    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/trunk/src/OCE/DYN/wet_dry.F90

    r13558 r14433  
    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/trunk/src/OCE/ICB/icbini.F90

    r14030 r14433  
    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/trunk/src/OCE/ICB/icblbc.F90

    r14229 r14433  
    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/trunk/src/OCE/IOM/iom_nf90.F90

    r14072 r14433  
    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/trunk/src/OCE/ISF/isfcav.F90

    r14072 r14433  
    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/trunk/src/OCE/ISF/isfcpl.F90

    r14143 r14433  
    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/trunk/src/OCE/ISF/isfpar.F90

    r13226 r14433  
    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/trunk/src/OCE/LBC/lbc_nfd_ext_generic.h90

    r13286 r14433  
    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/trunk/src/OCE/LBC/lbc_nfd_generic.h90

    r13286 r14433  
    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/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90

    r13286 r14433  
    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/trunk/src/OCE/LBC/lbclnk.F90

    r14229 r14433  
    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/trunk/src/OCE/LBC/lbcnfd.F90

    r13286 r14433  
    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/trunk/src/OCE/LBC/lib_mpp.F90

    r14354 r14433  
    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 
     
    130138   INTEGER :: MPI_SUMDD 
    131139 
     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 
    132157   ! variables used for zonal integration 
    133    INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average 
    134    LOGICAL, PUBLIC ::   l_znl_root      !: True on the 'left'most processor on the same row 
    135    INTEGER         ::   ngrp_znl        ! group ID for the znl processors 
    136    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 
    137162   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain 
    138163 
    139164   ! variables used for MPI3 neighbourhood collectives 
    140    INTEGER, PUBLIC :: mpi_nc_com                   ! MPI3 neighbourhood collectives communicator 
    141    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) 
    142167 
    143168   ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) 
     
    185210 
    186211   LOGICAL, PUBLIC ::   ln_nnogather                !: namelist control of northfold comms 
    187    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 
    188219 
    189220   !! * Substitutions 
     
    263294      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
    264295      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
    265       INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     296      INTEGER , INTENT(inout) ::   md_req     ! argument for isend 
    266297      !! 
    267298      INTEGER ::   iflag 
     
    292323      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
    293324      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
    294       INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     325      INTEGER , INTENT(inout) ::   md_req     ! argument for isend 
    295326      !! 
    296327      INTEGER ::   iflag 
     
    315346      INTEGER , INTENT(in   ) ::   kdest      ! receive process number 
    316347      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message 
    317       INTEGER , INTENT(in   ) ::   md_req     ! argument for isend 
     348      INTEGER , INTENT(inout) ::   md_req     ! argument for isend 
    318349      !! 
    319350      INTEGER ::   iflag 
     
    942973      LOGICAL, OPTIONAL, INTENT(in) :: ld_abort    ! source process number 
    943974      LOGICAL ::   ll_abort 
    944       INTEGER ::   info 
     975      INTEGER ::   info, ierr 
    945976      !!---------------------------------------------------------------------- 
    946977      ll_abort = .FALSE. 
     
    949980#if ! defined key_mpi_off 
    950981      IF(ll_abort) THEN 
    951          CALL mpi_abort( MPI_COMM_WORLD ) 
     982         CALL mpi_abort( MPI_COMM_WORLD, 123, info ) 
    952983      ELSE 
    953984         CALL mppsync 
     
    962993   SUBROUTINE mpp_comm_free( kcom ) 
    963994      !!---------------------------------------------------------------------- 
    964       INTEGER, INTENT(in) ::   kcom 
     995      INTEGER, INTENT(inout) ::   kcom 
    965996      !! 
    966997      INTEGER :: ierr 
     
    10711102   END SUBROUTINE mpp_ini_znl 
    10721103 
    1073    SUBROUTINE mpp_ini_nc 
     1104    
     1105   SUBROUTINE mpp_ini_nc( khls ) 
    10741106      !!---------------------------------------------------------------------- 
    10751107      !!               ***  routine mpp_ini_nc  *** 
     
    10821114      ! 
    10831115      !! ** output 
    1084       !!         mpi_nc_com = MPI3 neighbourhood collectives communicator 
    1085       !!         mpi_nc_all_com = MPI3 neighbourhood collectives communicator 
    1086       !!                          (with diagonals) 
    1087       !! 
    1088       !!---------------------------------------------------------------------- 
    1089       INTEGER, DIMENSION(:), ALLOCATABLE :: ineigh, ineighalls, ineighallr 
    1090       INTEGER :: ideg, idegalls, idegallr, icont, icont1 
    1091       INTEGER :: ierr 
    1092       LOGICAL, PARAMETER :: ireord = .FALSE. 
    1093  
    1094 #if ! defined key_mpi_off 
    1095  
    1096       ideg = 0 
    1097       idegalls = 0 
    1098       idegallr = 0 
    1099       icont = 0 
    1100       icont1 = 0 
    1101  
    1102       IF (nbondi .eq. 1) THEN 
    1103          ideg = ideg + 1 
    1104       ELSEIF (nbondi .eq. -1) THEN 
    1105          ideg = ideg + 1 
    1106       ELSEIF (nbondi .eq. 0) THEN 
    1107          ideg = ideg + 2 
    1108       ENDIF 
    1109  
    1110       IF (nbondj .eq. 1) THEN 
    1111          ideg = ideg + 1 
    1112       ELSEIF (nbondj .eq. -1) THEN 
    1113          ideg = ideg + 1 
    1114       ELSEIF (nbondj .eq. 0) THEN 
    1115          ideg = ideg + 2 
    1116       ENDIF 
    1117  
    1118       idegalls = ideg 
    1119       idegallr = ideg 
    1120  
    1121       IF (nones .ne. -1) idegalls = idegalls + 1 
    1122       IF (nonws .ne. -1) idegalls = idegalls + 1 
    1123       IF (noses .ne. -1) idegalls = idegalls + 1 
    1124       IF (nosws .ne. -1) idegalls = idegalls + 1 
    1125       IF (noner .ne. -1) idegallr = idegallr + 1 
    1126       IF (nonwr .ne. -1) idegallr = idegallr + 1 
    1127       IF (noser .ne. -1) idegallr = idegallr + 1 
    1128       IF (noswr .ne. -1) idegallr = idegallr + 1 
    1129  
    1130       ALLOCATE(ineigh(ideg)) 
    1131       ALLOCATE(ineighalls(idegalls)) 
    1132       ALLOCATE(ineighallr(idegallr)) 
    1133  
    1134       IF (nbondi .eq. 1) THEN 
    1135          icont = icont + 1 
    1136          ineigh(icont) = nowe 
    1137          ineighalls(icont) = nowe 
    1138          ineighallr(icont) = nowe 
    1139       ELSEIF (nbondi .eq. -1) THEN 
    1140          icont = icont + 1 
    1141          ineigh(icont) = noea 
    1142          ineighalls(icont) = noea 
    1143          ineighallr(icont) = noea 
    1144       ELSEIF (nbondi .eq. 0) THEN 
    1145          icont = icont + 1 
    1146          ineigh(icont) = nowe 
    1147          ineighalls(icont) = nowe 
    1148          ineighallr(icont) = nowe 
    1149          icont = icont + 1 
    1150          ineigh(icont) = noea 
    1151          ineighalls(icont) = noea 
    1152          ineighallr(icont) = noea 
    1153       ENDIF 
    1154  
    1155       IF (nbondj .eq. 1) THEN 
    1156          icont = icont + 1 
    1157          ineigh(icont) = noso 
    1158          ineighalls(icont) = noso 
    1159          ineighallr(icont) = noso 
    1160       ELSEIF (nbondj .eq. -1) THEN 
    1161          icont = icont + 1 
    1162          ineigh(icont) = nono 
    1163          ineighalls(icont) = nono 
    1164          ineighallr(icont) = nono 
    1165       ELSEIF (nbondj .eq. 0) THEN 
    1166          icont = icont + 1 
    1167          ineigh(icont) = noso 
    1168          ineighalls(icont) = noso 
    1169          ineighallr(icont) = noso 
    1170          icont = icont + 1 
    1171          ineigh(icont) = nono 
    1172          ineighalls(icont) = nono 
    1173          ineighallr(icont) = nono 
    1174       ENDIF 
    1175  
    1176       icont1 = icont 
    1177       IF (nosws .ne. -1) THEN 
    1178          icont = icont + 1 
    1179          ineighalls(icont) = nosws 
    1180       ENDIF 
    1181       IF (noses .ne. -1) THEN 
    1182          icont = icont + 1 
    1183          ineighalls(icont) = noses 
    1184       ENDIF 
    1185       IF (nonws .ne. -1) THEN 
    1186          icont = icont + 1 
    1187          ineighalls(icont) = nonws 
    1188       ENDIF 
    1189       IF (nones .ne. -1) THEN 
    1190          icont = icont + 1 
    1191          ineighalls(icont) = nones 
    1192       ENDIF 
    1193       IF (noswr .ne. -1) THEN 
    1194          icont1 = icont1 + 1 
    1195          ineighallr(icont1) = noswr 
    1196       ENDIF 
    1197       IF (noser .ne. -1) THEN 
    1198          icont1 = icont1 + 1 
    1199          ineighallr(icont1) = noser 
    1200       ENDIF 
    1201       IF (nonwr .ne. -1) THEN 
    1202          icont1 = icont1 + 1 
    1203          ineighallr(icont1) = nonwr 
    1204       ENDIF 
    1205       IF (noner .ne. -1) THEN 
    1206          icont1 = icont1 + 1 
    1207          ineighallr(icont1) = noner 
    1208       ENDIF 
    1209  
    1210       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) 
    1211       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) 
    1212  
    1213       DEALLOCATE (ineigh) 
    1214       DEALLOCATE (ineighalls) 
    1215       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 ) 
    12161146#endif 
    12171147   END SUBROUTINE mpp_ini_nc 
    1218  
    12191148 
    12201149 
     
    12321161      !! 
    12331162      !! ** output 
    1234       !!      njmppmax = njmpp for northern procs 
    12351163      !!      ndim_rank_north = number of processors in the northern line 
    12361164      !!      nrank_north (ndim_rank_north) = number  of the northern procs. 
     
    12471175      ! 
    12481176#if ! defined key_mpi_off 
    1249       njmppmax = MAXVAL( njmppt ) 
    12501177      ! 
    12511178      ! Look for how many procs on the northern boundary 
  • NEMO/trunk/src/OCE/LBC/mpp_lbc_north_icb_generic.h90

    r14229 r14433  
    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/trunk/src/OCE/LBC/mpp_lnk_icb_generic.h90

    r13286 r14433  
    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/trunk/src/OCE/LBC/mpp_nfd_generic.h90

    r14229 r14433  
    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/trunk/src/OCE/LBC/mppini.F90

    r14275 r14433  
    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       !!                    noea      : number for local neighboring processor 
    136       !!                    nowe      : number for local neighboring processor 
    137       !!                    noso      : number for local neighboring processor 
    138       !!                    nono      : number for local neighboring processor 
    139       !!---------------------------------------------------------------------- 
    140       INTEGER ::   ji, jj, jn, jproc, jarea   ! dummy loop indices 
    141       INTEGER ::   inijmin 
    142       INTEGER ::   inum                       ! local logical unit 
    143       INTEGER ::   idir, ifreq                ! local integers 
    144       INTEGER ::   ii, il1, ili, imil         !   -       - 
    145       INTEGER ::   ij, il2, ilj, ijm1         !   -       - 
    146       INTEGER ::   iino, ijno, iiso, ijso     !   -       - 
    147       INTEGER ::   iiea, ijea, iiwe, ijwe     !   -       - 
    148       INTEGER ::   iarea0                     !   -       - 
    149       INTEGER ::   ierr, ios                  ! 
    150       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 
    151136      LOGICAL ::   llbest, llauto 
    152137      LOGICAL ::   llwrtlay 
     138      LOGICAL ::   llmpi_Iperio, llmpi_Jperio, llmpiNFold 
    153139      LOGICAL ::   ln_listonly 
    154       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   iin, ii_nono, ii_noea          ! 1D workspace 
    155       INTEGER, ALLOCATABLE, DIMENSION(:)     ::   ijn, ii_noso, ii_nowe          !  -     - 
    156       INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iimppt, ijpi, ibondi, ipproc   ! 2D workspace 
    157       INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   ijmppt, ijpj, ibondj, ipolj    !  -     - 
    158       INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   iie0, iis0, iono, ioea         !  -     - 
    159       INTEGER, ALLOCATABLE, DIMENSION(:,:) ::   ije0, ijs0, ioso, iowe         !  -     - 
    160       LOGICAL, ALLOCATABLE, DIMENSION(:,:) ::   llisoce                        !  -     - 
     140      LOGICAL, ALLOCATABLE, DIMENSION(:,:  ) ::   llisOce  ! is not land-domain only? 
     141      LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) ::   llnei    ! are neighbourgs existing? 
    161142      NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file,           & 
    162143           &             ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta,     & 
     
    165146           &             cn_ice, nn_ice_dta,                                     & 
    166147           &             ln_vol, nn_volctl, nn_rimwidth 
    167       NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 
     148      NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly, nn_comm 
    168149      !!---------------------------------------------------------------------- 
    169150      ! 
     
    193174      IF(lwm)   WRITE( numond, nammpp ) 
    194175      ! 
    195 !!!------------------------------------ 
    196 !!!  nn_hls shloud be read in nammpp 
    197 !!!------------------------------------ 
    198176      jpiglo = Ni0glo + 2 * nn_hls 
    199177      jpjglo = Nj0glo + 2 * nn_hls 
     
    213191      ! ----------------------------------- 
    214192      ! 
    215       ! 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 
    216194      ! then we calculate them here now that we have our communicator size 
    217195      IF(lwp) THEN 
     
    260238 
    261239      ! look for land mpi subdomains... 
    262       ALLOCATE( llisoce(jpni,jpnj) ) 
    263       CALL mpp_is_ocean( llisoce ) 
    264       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 
    265243 
    266244      IF( mppsize < inijmin ) THEN   ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... 
     
    3192979003  FORMAT (a, i5) 
    320298 
    321       ALLOCATE(  nfimpp(jpni ) , nfproc(jpni ) ,   nfjpi(jpni ) ,                     & 
    322          &       nimppt(jpnij) , ibonit(jpnij) ,  jpiall(jpnij) ,  jpjall(jpnij) ,    & 
    323          &       njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) ,    & 
    324          &                                       nie0all(jpnij) , nje0all(jpnij) ,    & 
    325          &       iin(jpnij), ii_nono(jpnij), ii_noea(jpnij),   & 
    326          &       ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij),   & 
    327          &       iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj),   & 
    328          &       ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj),  ipolj(jpni,jpnj),   & 
    329          &         iie0(jpni,jpnj), iis0(jpni,jpnj),   iono(jpni,jpnj),   ioea(jpni,jpnj),   & 
    330          &         ije0(jpni,jpnj), ijs0(jpni,jpnj),   ioso(jpni,jpnj),   iowe(jpni,jpnj),   & 
    331          &       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 ) 
    332305      CALL mpp_sum( 'mppini', ierr ) 
    333306      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' ) 
     
    343316      ! 
    344317      CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 
    345       CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 
    346       ! 
    347       !DO jn = 1, jpni 
    348       !   jproc = ipproc(jn,jpnj) 
    349       !   ii = iin(jproc+1) 
    350       !   ij = ijn(jproc+1) 
    351       !   nfproc(jn) = jproc 
    352       !   nfimpp(jn) = iimppt(ii,ij) 
    353       !   nfjpi (jn) =   ijpi(ii,ij) 
    354       !END DO 
    355       nfproc(:) = ipproc(:,jpnj) 
    356       nfimpp(:) = iimppt(:,jpnj) 
    357       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) 
    358330      ! 
    359331      IF(lwp) THEN 
     
    365337         WRITE(numout,*) '      jpnj = ', jpnj 
    366338         WRITE(numout,*) '     jpnij = ', jpnij 
     339         WRITE(numout,*) '     nimpp = ', nimpp 
     340         WRITE(numout,*) '     njmpp = ', njmpp 
    367341         WRITE(numout,*) 
    368342         WRITE(numout,*) '      sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 
    369          WRITE(numout,*) '      sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 
    370       ENDIF 
    371  
    372       ! 3. Subdomain description in the Regular Case 
    373       ! -------------------------------------------- 
    374       ! specific cases where there is no communication -> must do the periodicity by itself 
    375       ! Warning: because of potential land-area suppression, do not use nbond[ij] == 2 
    376       l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 
    377       l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 
    378  
    379       DO jarea = 1, jpni*jpnj 
    380          ! 
    381          iarea0 = jarea - 1 
    382          ii = 1 + MOD(iarea0,jpni) 
    383          ij = 1 +     iarea0/jpni 
    384          ili = ijpi(ii,ij) 
    385          ilj = ijpj(ii,ij) 
    386          ibondi(ii,ij) = 0                         ! default: has e-w neighbours 
    387          IF( ii   ==    1 )   ibondi(ii,ij) = -1   ! first column, has only e neighbour 
    388          IF( ii   == jpni )   ibondi(ii,ij) =  1   ! last column,  has only w neighbour 
    389          IF( jpni ==    1 )   ibondi(ii,ij) =  2   ! has no e-w neighbour 
    390          ibondj(ii,ij) = 0                         ! default: has n-s neighbours 
    391          IF( ij   ==    1 )   ibondj(ii,ij) = -1   ! first row, has only n neighbour 
    392          IF( ij   == jpnj )   ibondj(ii,ij) =  1   ! last row,  has only s neighbour 
    393          IF( jpnj ==    1 )   ibondj(ii,ij) =  2   ! has no n-s neighbour 
    394  
    395          ! Subdomain neighbors (get their zone number): default definition 
    396          ioso(ii,ij) = iarea0 - jpni 
    397          iowe(ii,ij) = iarea0 - 1 
    398          ioea(ii,ij) = iarea0 + 1 
    399          iono(ii,ij) = iarea0 + jpni 
    400          iis0(ii,ij) =  1  + nn_hls 
    401          iie0(ii,ij) = ili - nn_hls 
    402          ijs0(ii,ij) =  1  + nn_hls 
    403          ije0(ii,ij) = ilj - nn_hls 
    404  
    405          ! East-West periodicity: change ibondi, ioea, iowe 
    406          IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 
    407             IF( jpni  /= 1 )   ibondi(ii,ij) = 0                        ! redefine: all have e-w neighbours 
    408             IF( ii ==    1 )   iowe(ii,ij) = iarea0 +        (jpni-1)   ! redefine: first column, address of w neighbour 
    409             IF( ii == jpni )   ioea(ii,ij) = iarea0 -        (jpni-1)   ! redefine: last column,  address of e neighbour 
    410          ENDIF 
    411  
    412          ! Simple North-South periodicity: change ibondj, ioso, iono 
    413          IF( jperio == 2 .OR. jperio == 7 ) THEN 
    414             IF( jpnj  /= 1 )   ibondj(ii,ij) = 0                        ! redefine: all have n-s neighbours 
    415             IF( ij ==    1 )   ioso(ii,ij) = iarea0 + jpni * (jpnj-1)   ! redefine: first row, address of s neighbour 
    416             IF( ij == jpnj )   iono(ii,ij) = iarea0 - jpni * (jpnj-1)   ! redefine: last row,  address of n neighbour 
    417          ENDIF 
    418  
    419          ! North fold: define ipolj, change iono. Warning: we do not change ibondj... 
    420          ipolj(ii,ij) = 0 
    421          IF( jperio == 3 .OR. jperio == 4 ) THEN 
    422             ijm1 = jpni*(jpnj-1) 
    423             imil = ijm1+(jpni+1)/2 
    424             IF( jarea > ijm1 ) ipolj(ii,ij) = 3 
    425             IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4 
    426             IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1   ! MPI rank of northern neighbour 
    427          ENDIF 
    428          IF( jperio == 5 .OR. jperio == 6 ) THEN 
    429             ijm1 = jpni*(jpnj-1) 
    430             imil = ijm1+(jpni+1)/2 
    431             IF( jarea > ijm1) ipolj(ii,ij) = 5 
    432             IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6 
    433             IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1    ! MPI rank of northern neighbour 
    434          ENDIF 
    435          ! 
    436       END DO 
    437  
    438       ! 4. deal with land subdomains 
    439       ! ---------------------------- 
    440       ! 
    441       ! neighbour treatment: change ibondi, ibondj if next to a land zone 
    442       DO jarea = 1, jpni*jpnj 
    443          ii = 1 + MOD( jarea-1  , jpni ) 
    444          ij = 1 +     (jarea-1) / jpni 
    445          ! land-only area with an active n neigbour 
    446          IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN 
    447             iino = 1 + MOD( iono(ii,ij) , jpni )                    ! ii index of this n neigbour 
    448             ijno = 1 +      iono(ii,ij) / jpni                      ! ij index of this n neigbour 
    449             ! In case of north fold exchange: I am the n neigbour of my n neigbour!! (#1057) 
    450             ! --> for northern neighbours of northern row processors (in case of north-fold) 
    451             !     need to reverse the LOGICAL direction of communication 
    452             idir = 1                                           ! we are indeed the s neigbour of this n neigbour 
    453             IF( ij == jpnj .AND. ijno == jpnj )   idir = -1    ! both are on the last row, we are in fact the n neigbour 
    454             IF( ibondj(iino,ijno) == idir     )   ibondj(iino,ijno) =   2     ! this n neigbour had only a s/n neigbour -> no more 
    455             IF( ibondj(iino,ijno) == 0        )   ibondj(iino,ijno) = -idir   ! this n neigbour had both, n-s neighbours -> keep 1 
    456          ENDIF 
    457          ! land-only area with an active s neigbour 
    458          IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN 
    459             iiso = 1 + MOD( ioso(ii,ij) , jpni )                    ! ii index of this s neigbour 
    460             ijso = 1 +      ioso(ii,ij) / jpni                      ! ij index of this s neigbour 
    461             IF( ibondj(iiso,ijso) == -1 )   ibondj(iiso,ijso) = 2   ! this s neigbour had only a n neigbour    -> no more neigbour 
    462             IF( ibondj(iiso,ijso) ==  0 )   ibondj(iiso,ijso) = 1   ! this s neigbour had both, n-s neighbours -> keep s neigbour 
    463          ENDIF 
    464          ! land-only area with an active e neigbour 
    465          IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN 
    466             iiea = 1 + MOD( ioea(ii,ij) , jpni )                    ! ii index of this e neigbour 
    467             ijea = 1 +      ioea(ii,ij) / jpni                      ! ij index of this e neigbour 
    468             IF( ibondi(iiea,ijea) == 1 )   ibondi(iiea,ijea) =  2   ! this e neigbour had only a w neigbour    -> no more neigbour 
    469             IF( ibondi(iiea,ijea) == 0 )   ibondi(iiea,ijea) = -1   ! this e neigbour had both, e-w neighbours -> keep e neigbour 
    470          ENDIF 
    471          ! land-only area with an active w neigbour 
    472          IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN 
    473             iiwe = 1 + MOD( iowe(ii,ij) , jpni )                    ! ii index of this w neigbour 
    474             ijwe = 1 +      iowe(ii,ij) / jpni                      ! ij index of this w neigbour 
    475             IF( ibondi(iiwe,ijwe) == -1 )   ibondi(iiwe,ijwe) = 2   ! this w neigbour had only a e neigbour    -> no more neigbour 
    476             IF( ibondi(iiwe,ijwe) ==  0 )   ibondi(iiwe,ijwe) = 1   ! this w neigbour had both, e-w neighbours -> keep w neigbour 
    477          ENDIF 
    478       END DO 
    479  
    480       ! 5. Subdomain print 
    481       ! ------------------ 
    482       IF(lwp) THEN 
     343         WRITE(numout,*) '      sum ijpj(1,j) = ', SUM(ijpj(1,:)), ' jpjglo = ', jpjglo 
     344          
     345         ! Subdomain grid print 
    483346         ifreq = 4 
    484347         il1 = 1 
     
    503366 9404    FORMAT('           *  '   ,20('     ' ,i4,'   *   ') ) 
    504367      ENDIF 
    505  
    506       ! just to save nono etc for all proc 
    507       ! warning ii*ij (zone) /= mpprank (processors)! 
    508       ! ioso = zone number, ii_noso = proc number 
    509       ii_noso(:) = -1 
    510       ii_nono(:) = -1 
    511       ii_noea(:) = -1 
    512       ii_nowe(:) = -1 
    513       DO jproc = 1, jpnij 
    514          ii = iin(jproc) 
    515          ij = ijn(jproc) 
    516          IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 
    517             iiso = 1 + MOD( ioso(ii,ij) , jpni ) 
    518             ijso = 1 +      ioso(ii,ij) / jpni 
    519             ii_noso(jproc) = ipproc(iiso,ijso) 
    520          ENDIF 
    521          IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN 
    522           iiwe = 1 + MOD( iowe(ii,ij) , jpni ) 
    523           ijwe = 1 +      iowe(ii,ij) / jpni 
    524           ii_nowe(jproc) = ipproc(iiwe,ijwe) 
    525          ENDIF 
    526          IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN 
    527             iiea = 1 + MOD( ioea(ii,ij) , jpni ) 
    528             ijea = 1 +      ioea(ii,ij) / jpni 
    529             ii_noea(jproc)= ipproc(iiea,ijea) 
    530          ENDIF 
    531          IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN 
    532             iino = 1 + MOD( iono(ii,ij) , jpni ) 
    533             ijno = 1 +      iono(ii,ij) / jpni 
    534             ii_nono(jproc)= ipproc(iino,ijno) 
    535          ENDIF 
    536       END DO 
    537  
    538       ! 6. Change processor name 
    539       ! ------------------------ 
    540       ii = iin(narea) 
    541       ij = ijn(narea) 
    542       ! 
    543       jpi    = ijpi(ii,ij) 
    544 !!$      Nis0  = iis0(ii,ij) 
    545 !!$      Nie0  = iie0(ii,ij) 
    546       jpj    = ijpj(ii,ij) 
    547 !!$      Njs0  = ijs0(ii,ij) 
    548 !!$      Nje0  = ije0(ii,ij) 
    549       nbondi = ibondi(ii,ij) 
    550       nbondj = ibondj(ii,ij) 
    551       nimpp = iimppt(ii,ij) 
    552       njmpp = ijmppt(ii,ij) 
    553       jpk = jpkglo                              ! third dim 
    554  
    555       ! set default neighbours 
    556       noso = ii_noso(narea) 
    557       nowe = ii_nowe(narea) 
    558       noea = ii_noea(narea) 
    559       nono = ii_nono(narea) 
    560  
    561       nones = -1 
    562       nonws = -1 
    563       noses = -1 
    564       nosws = -1 
    565  
    566       noner = -1 
    567       nonwr = -1 
    568       noser = -1 
    569       noswr = -1 
    570  
    571       IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists 
    572          IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN 
    573             nones = ii_nono(noea+1)                  ! east neighbour has north and south neighbours 
    574             noses = ii_noso(noea+1) 
    575          ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN 
    576             nones = ii_nono(noea+1)                  ! east neighbour has north neighbour 
    577          ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN 
    578             noses = ii_noso(noea+1)                  ! east neighbour has south neighbour 
    579          END IF 
    580       END IF 
    581       IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN  ! west neighbour exists 
    582          IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN 
    583             nonws = ii_nono(nowe+1)                  ! west neighbour has north and south neighbours 
    584             nosws = ii_noso(nowe+1) 
    585          ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN 
    586             nonws = ii_nono(nowe+1)                  ! west neighbour has north neighbour 
    587          ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1)  THEN 
    588             nosws = ii_noso(nowe+1)                  ! west neighbour has north neighbour 
    589          END IF 
    590       END IF 
    591  
    592       IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists 
    593          IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN 
    594             noner = ii_noea(nono+1)                  ! north neighbour has east and west neighbours 
    595             nonwr = ii_nowe(nono+1) 
    596          ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN 
    597             noner = ii_noea(nono+1)                  ! north neighbour has east neighbour 
    598          ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN 
    599             nonwr = ii_nowe(nono+1)                  ! north neighbour has west neighbour 
    600          END IF 
    601       END IF 
    602       IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN  ! south neighbour exists 
    603          IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN 
    604             noser = ii_noea(noso+1)                  ! south neighbour has east and west neighbours 
    605             noswr = ii_nowe(noso+1) 
    606          ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN 
    607             noser = ii_noea(noso+1)                  ! south neighbour has east neighbour 
    608          ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN 
    609             noswr = ii_nowe(noso+1)                  ! south neighbour has west neighbour 
    610          END IF 
    611       END IF 
    612  
    613       ! 
    614       CALL init_doloop                          ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 
    615       ! 
    616       jpim1 = jpi-1                             ! inner domain indices 
    617       jpjm1 = jpj-1                             !   "           " 
    618       jpkm1 = MAX( 1, jpk-1 )                   !   "           " 
    619       jpij  = jpi*jpj                           !  jpi x j 
    620       DO jproc = 1, jpnij 
    621          ii = iin(jproc) 
    622          ij = ijn(jproc) 
    623          jpiall (jproc) = ijpi(ii,ij) 
    624          nis0all(jproc) = iis0(ii,ij) 
    625          nie0all(jproc) = iie0(ii,ij) 
    626          jpjall (jproc) = ijpj(ii,ij) 
    627          njs0all(jproc) = ijs0(ii,ij) 
    628          nje0all(jproc) = ije0(ii,ij) 
    629          ibonit(jproc) = ibondi(ii,ij) 
    630          ibonjt(jproc) = ibondj(ii,ij) 
    631          nimppt(jproc) = iimppt(ii,ij) 
    632          njmppt(jproc) = ijmppt(ii,ij) 
    633       END DO 
    634  
     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      ! 
    635439      ! Save processor layout in ascii file 
    636440      IF (llwrtlay) THEN 
    637441         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
    638          WRITE(inum,'(a)') '   jpnij   jpimax  jpjmax    jpk  jpiglo  jpjglo'//& 
    639    &           ' ( local:    narea     jpi     jpj )' 
    640          WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 
    641    &           ' ( local: ',narea,jpi,jpj,' )' 
    642          WRITE(inum,'(a)') 'narea   jpi  jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 
    643  
    644          DO jproc = 1, jpnij 
    645             WRITE(inum,'(13i5,2i7)')     jproc,  jpiall(jproc),  jpjall(jproc),   & 
    646                &                                nis0all(jproc), njs0all(jproc),   & 
    647                &                                nie0all(jproc), nje0all(jproc),   & 
    648                &                                nimppt (jproc), njmppt (jproc),   & 
    649                &                                ii_nono(jproc), ii_noso(jproc),   & 
    650                &                                ii_nowe(jproc), ii_noea(jproc),   & 
    651                &                                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) 
    652454         END DO 
    653       END IF 
    654  
    655       !                          ! north fold parameter 
    656       ! Defined npolj, either 0, 3 , 4 , 5 , 6 
    657       ! In this case the important thing is that npolj /= 0 
    658       ! Because if we go through these line it is because jpni >1 and thus 
    659       ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0 
    660       npolj = 0 
    661       ij = ijn(narea) 
    662       IF( jperio == 3 .OR. jperio == 4 ) THEN 
    663          IF( ij == jpnj )   npolj = 3 
    664       ENDIF 
    665       IF( jperio == 5 .OR. jperio == 6 ) THEN 
    666          IF( ij == jpnj )   npolj = 5 
    667       ENDIF 
     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 
    668491      ! 
    669492      IF(lwp) THEN 
    670493         WRITE(numout,*) 
    671494         WRITE(numout,*) '   resulting internal parameters : ' 
    672          WRITE(numout,*) '      narea  = ', narea 
    673          WRITE(numout,*) '      nowe   = ', nowe  , '   noea  =  ', noea 
    674          WRITE(numout,*) '      nono   = ', nono  , '   noso  =  ', noso 
    675          WRITE(numout,*) '      nbondi = ', nbondi 
    676          WRITE(numout,*) '      nbondj = ', nbondj 
    677          WRITE(numout,*) '      npolj  = ', npolj 
    678          WRITE(numout,*) '    l_Iperio = ', l_Iperio 
    679          WRITE(numout,*) '    l_Jperio = ', l_Jperio 
    680          WRITE(numout,*) '      nimpp  = ', nimpp 
    681          WRITE(numout,*) '      njmpp  = ', njmpp 
    682       ENDIF 
    683  
     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 
    684501      !                          ! Prepare mpp north fold 
    685       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 
    686507         CALL mpp_ini_north 
    687508         IF (lwp) THEN 
    688509            WRITE(numout,*) 
    689510            WRITE(numout,*) '   ==>>>   North fold boundary prepared for jpni >1' 
    690             ! additional prints in layout.dat 
    691          ENDIF 
    692          IF (llwrtlay) THEN 
     511         ENDIF 
     512         IF (llwrtlay) THEN      ! additional prints in layout.dat 
    693513            WRITE(inum,*) 
    694514            WRITE(inum,*) 
    695             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 
    696516            WRITE(inum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north 
    697             DO jproc = 1, ndim_rank_north, 5 
    698                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/) ) ) 
    699519            END DO 
    700520         ENDIF 
    701       ENDIF 
    702  
    703       ! 
    704       CALL mpp_ini_nc        ! Initialize communicator for neighbourhood collective communications 
    705       ! 
    706       CALL init_ioipsl       ! Prepare NetCDF output file (if necessary) 
    707       ! 
    708       IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 
    709          CALL init_nfdcom     ! northfold neighbour lists 
    710          IF (llwrtlay) THEN 
    711             WRITE(inum,*) 
    712             WRITE(inum,*) 
    713             WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 
    714             WRITE(inum,*) 'nsndto : ', nsndto 
    715             WRITE(inum,*) 'isendto : ', isendto 
    716          ENDIF 
    717       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) 
    718569      ! 
    719570      IF (llwrtlay) CLOSE(inum) 
    720571      ! 
    721       DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe,    & 
    722          &       iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj,   & 
    723          &       ijpi, ijpj, iie0, ije0, iis0, ijs0,              & 
    724          &       iono, ioea, ioso, iowe, llisoce) 
     572      DEALLOCATE(iin, ijn, iimppt, ijmppt, ijpi, ijpj, ipproc, inei, llnei, impi, llisOce) 
    725573      ! 
    726574    END SUBROUTINE mpp_init 
     
    789637        CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 
    790638      ENDIF 
    791       IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN 
     639      IF( l_NFold ) THEN 
    792640         ! minimize the size of the last row to compensate for the north pole folding coast 
    793          IF( jperio == 3 .OR. jperio == 4 )   ijpjmin = 2+3*khls   ! V and F folding must be outside of southern halos 
    794          IF( jperio == 5 .OR. jperio == 6 )   ijpjmin = 1+3*khls   ! V and F folding must be outside of southern halos 
    795          irm = knbj - irestj                                       ! total number of lines to be removed 
    796          klcj(:,knbj) = MAX( ijpjmin, kjmax-irm )                  ! we must have jpj >= ijpjmin in the last row 
    797          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 
    798646         irestj = knbj - 1 - irm 
    799647         klcj(:, irestj+1:knbj-1) = kjmax-1 
     
    860708      LOGICAL :: llist 
    861709      LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d                 ! max size of the subdomains along i,j 
    862       LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisoce              !  -     - 
     710      LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisOce              !  -     - 
    863711      REAL(wp)::   zpropland 
    864712      !!---------------------------------------------------------------------- 
     
    883731      iszimin = 4*nn_hls          ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 
    884732      iszjmin = 4*nn_hls 
    885       IF( jperio == 3 .OR. jperio == 4 )   iszjmin = MAX(iszjmin, 2+3*nn_hls)   ! V and F folding must be outside of southern halos 
    886       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 
    887735      ! 
    888736      ! get the list of knbi that gives a smaller jpimax than knbi-1 
     
    933781               iszi1(ii) = iszi0(ji) 
    934782               iszj1(ii) = iszj0(jj) 
    935             END IF 
     783            ENDIF 
    936784         END DO 
    937785      END DO 
     
    989837            WRITE(numout,*) '  -----------------------------------------------------' 
    990838            WRITE(numout,*) 
    991          END IF 
     839         ENDIF 
    992840         ji = isz0   ! initialization with the largest value 
    993          ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 
    994          CALL mpp_is_ocean( llisoce )   ! Warning: must be call by all cores (call mpp_sum) 
    995          inbijold = COUNT(llisoce) 
    996          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 ) 
    997845         DO ji =isz0-1,1,-1 
    998             ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) 
    999             CALL mpp_is_ocean( llisoce )   ! Warning: must be call by all cores (call mpp_sum) 
    1000             inbij = COUNT(llisoce) 
    1001             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 ) 
    1002850            IF(lwp .AND. inbij < inbijold) THEN 
    1003851               WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)')                                 & 
     
    1006854                  &   '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 
    1007855               inbijold = inbij 
    1008             END IF 
     856            ENDIF 
    1009857         END DO 
    1010858         DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) 
     
    1022870      DO WHILE( inbij > knbij )   ! while the number of ocean subdomains exceed the number of procs 
    1023871         ii = ii -1 
    1024          ALLOCATE( llisoce(inbi0(ii), inbj0(ii)) ) 
    1025          CALL mpp_is_ocean( llisoce )            ! must be done by all core 
    1026          inbij = COUNT(llisoce) 
    1027          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 ) 
    1028876      END DO 
    1029877      knbi = inbi0(ii) 
     
    1073921         ! 
    1074922         ALLOCATE( lloce(Ni0glo, ijsz) )                                     ! allocate the strip 
    1075          CALL readbot_strip( ijstr, ijsz, lloce ) 
     923         CALL read_mask( 1, ijstr, Ni0glo, ijsz, lloce ) 
    1076924         inboce = COUNT(lloce)                                               ! number of ocean point in the stripe 
    1077925         DEALLOCATE(lloce) 
     
    1087935 
    1088936 
    1089    SUBROUTINE mpp_is_ocean( ldisoce ) 
     937   SUBROUTINE mpp_is_ocean( ldIsOce ) 
    1090938      !!---------------------------------------------------------------------- 
    1091939      !!                  ***  ROUTINE mpp_is_ocean  *** 
     
    1095943      !!              at least 1 ocean point. 
    1096944      !!              We must indeed ensure that each subdomain that is a neighbour 
    1097       !!              of a land subdomain as only land points on its boundary 
     945      !!              of a land subdomain, has only land points on its boundary 
    1098946      !!              (inside the inner subdomain) with the land subdomain. 
    1099947      !!              This is needed to get the proper bondary conditions on 
     
    1102950      !! ** Method  : read inbj strips (of length Ni0glo) of the land-sea mask 
    1103951      !!---------------------------------------------------------------------- 
    1104       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 
    1105953      ! 
    1106954      INTEGER :: idiv, iimax, ijmax, iarea 
     
    1115963      ! do nothing if there is no land-sea mask 
    1116964      IF( numbot == -1 .AND. numbdy == -1 ) THEN 
    1117          ldisoce(:,:) = .TRUE. 
     965         ldIsOce(:,:) = .TRUE. 
    1118966         RETURN 
    1119967      ENDIF 
    1120968      ! 
    1121       inbi = SIZE( ldisoce, dim = 1 ) 
    1122       inbj = SIZE( ldisoce, dim = 2 ) 
     969      inbi = SIZE( ldIsOce, dim = 1 ) 
     970      inbj = SIZE( ldIsOce, dim = 2 ) 
    1123971      ! 
    1124972      ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 
     
    1143991            inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) )      ! number of point to read in y-direction 
    1144992            isty = 1 + COUNT( (/ iarea == 1 /) )                       ! read from the first or the second line? 
    1145             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 
    1146994            ! 
    1147995            IF( iarea == 1    ) THEN                                   ! the first line was not read 
    1148                IF( jperio == 2 .OR. jperio == 7 ) THEN                 !   north-south periodocity 
    1149                   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 
    1150998               ELSE 
    1151999                  lloce(2:inx-1,  1) = .FALSE.                         !   closed boundary 
     
    11531001            ENDIF 
    11541002            IF( iarea == inbj ) THEN                                   ! the last line was not read 
    1155                IF( jperio == 2 .OR. jperio == 7 ) THEN                 !   north-south periodocity 
    1156                   CALL readbot_strip( 1, 1, lloce(2:inx-1,iny) )       !      read the first line -> last line of lloce 
    1157                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 
    11581006                  lloce(2,iny) = lloce(2,iny-2)                        !      here we have 1 halo (even if nn_hls>1) 
    11591007                  DO ji = 3,inx-1 
     
    11631011                     lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 
    11641012                  END DO 
    1165                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 
    11661014                  lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1)            !      here we have 1 halo (even if nn_hls>1) 
    11671015                  lloce(inx  -1,iny-1) = lloce(2    ,iny-1) 
     
    11741022            ENDIF 
    11751023            !                                                          ! first and last column were not read 
    1176             IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 
     1024            IF( l_Iperio ) THEN 
    11771025               lloce(1,:) = lloce(inx-1,:)   ;   lloce(inx,:) = lloce(2,:)   ! east-west periodocity 
    11781026            ELSE 
     
    11931041      CALL mpp_sum( 'mppini', inboce_1d ) 
    11941042      inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 
    1195       ldisoce(:,:) = inboce(:,:) /= 0 
     1043      ldIsOce(:,:) = inboce(:,:) /= 0 
    11961044      DEALLOCATE(inboce, inboce_1d) 
    11971045      ! 
     
    11991047 
    12001048 
    1201    SUBROUTINE readbot_strip( kjstr, kjcnt, ldoce ) 
    1202       !!---------------------------------------------------------------------- 
    1203       !!                  ***  ROUTINE readbot_strip  *** 
     1049   SUBROUTINE read_mask( kistr, kjstr, kicnt, kjcnt, ldoce ) 
     1050      !!---------------------------------------------------------------------- 
     1051      !!                  ***  ROUTINE read_mask  *** 
    12041052      !! 
    12051053      !! ** Purpose : Read relevant bathymetric information in order to 
     
    12091057      !! ** Method  : read stipe of size (Ni0glo,...) 
    12101058      !!---------------------------------------------------------------------- 
    1211       INTEGER                         , INTENT(in   ) ::   kjstr       ! starting j position of the reading 
    1212       INTEGER                         , INTENT(in   ) ::   kjcnt       ! number of lines to read 
    1213       LOGICAL, DIMENSION(Ni0glo,kjcnt), INTENT(  out) ::   ldoce       ! ldoce(i,j) = .true. if the point (i,j) is ocean 
    1214       ! 
    1215       INTEGER                           ::   inumsave                ! local logical unit 
    1216       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 
    12171065      !!---------------------------------------------------------------------- 
    12181066      ! 
     
    12201068      ! 
    12211069      IF( numbot /= -1 ) THEN 
    1222          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/) ) 
    12231071      ELSE 
    12241072         zbot(:,:) = 1._wp                      ! put a non-null value 
     
    12261074      ! 
    12271075      IF( numbdy /= -1 ) THEN                   ! Adjust with bdy_msk if it exists 
    1228          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/) ) 
    12291077         zbot(:,:) = zbot(:,:) * zbdy(:,:) 
    12301078      ENDIF 
    12311079      ! 
    1232       ldoce(:,:) = zbot(:,:) > 0._wp 
     1080      ldoce(:,:) = NINT(zbot(:,:)) > 0 
    12331081      numout = inumsave 
    12341082      ! 
    1235    END SUBROUTINE readbot_strip 
    1236  
    1237  
    1238    SUBROUTINE mpp_getnum( ldisoce, kproc, kipos, kjpos ) 
     1083   END SUBROUTINE read_mask 
     1084 
     1085 
     1086   SUBROUTINE mpp_getnum( ldIsOce, kproc, kipos, kjpos ) 
    12391087      !!---------------------------------------------------------------------- 
    12401088      !!                  ***  ROUTINE mpp_getnum  *** 
     
    12441092      !! ** Method  : start from bottom left. First skip land subdomain, and finally use them if needed 
    12451093      !!---------------------------------------------------------------------- 
    1246       LOGICAL, DIMENSION(:,:), INTENT(in   ) ::   ldisoce     ! F if land process 
    1247       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) 
    12481096      INTEGER, DIMENSION(  :), INTENT(  out) ::   kipos       ! i-position of the subdomain (from 1 to jpni) 
    12491097      INTEGER, DIMENSION(  :), INTENT(  out) ::   kjpos       ! j-position of the subdomain (from 1 to jpnj) 
     
    12531101      !!---------------------------------------------------------------------- 
    12541102      ! 
    1255       ini = SIZE(ldisoce, dim = 1) 
    1256       inj = SIZE(ldisoce, dim = 2) 
     1103      ini = SIZE(ldIsOce, dim = 1) 
     1104      inj = SIZE(ldIsOce, dim = 2) 
    12571105      inij = SIZE(kipos) 
    12581106      ! 
     
    12641112         ii = 1 + MOD(iarea0,ini) 
    12651113         ij = 1 +     iarea0/ini 
    1266          IF( ldisoce(ii,ij) ) THEN 
     1114         IF( ldIsOce(ii,ij) ) THEN 
    12671115            icont = icont + 1 
    12681116            kproc(ii,ij) = icont 
     
    12721120      END DO 
    12731121      ! if needed add some land subdomains to reach inij active subdomains 
    1274       i2add = inij - COUNT( ldisoce ) 
     1122      i2add = inij - COUNT( ldIsOce ) 
    12751123      DO jarea = 1, ini*inj 
    12761124         iarea0 = jarea - 1 
    12771125         ii = 1 + MOD(iarea0,ini) 
    12781126         ij = 1 +     iarea0/ini 
    1279          IF( .NOT. ldisoce(ii,ij) .AND. i2add > 0 ) THEN 
     1127         IF( .NOT. ldIsOce(ii,ij) .AND. i2add > 0 ) THEN 
    12801128            icont = icont + 1 
    12811129            kproc(ii,ij) = icont 
     
    12871135      ! 
    12881136   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 
    12891226 
    12901227 
     
    13431280      !!---------------------------------------------------------------------- 
    13441281      ! 
    1345       !initializes the north-fold communication variables 
    1346       isendto(:) = 0 
    1347       nsndto     = 0 
    1348       ! 
    1349       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 
    13501292         ! 
    1351          !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 
    1352          sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 
    1353          !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 
    1354          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 
    13551295         ! 
    1356          ! loop over the other north-fold processes to find the processes 
    1357          ! 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 
    13581306         ! 
    1359          DO jn = 1, jpni 
    1360             ! 
    1361             sxT = nfimpp(jn)                    ! sxT = 1st  point (in the global domain) of the jn process 
    1362             dxT = nfimpp(jn) + nfjpi(jn) - 1    ! dxT = last point (in the global domain) of the jn process 
    1363             ! 
    1364             IF    ( sxT < sxM  .AND.  sxM < dxT ) THEN 
    1365                nsndto          = nsndto + 1 
    1366                isendto(nsndto) = jn 
    1367             ELSEIF( sxM <= sxT  .AND.  dxM >= dxT ) THEN 
    1368                nsndto          = nsndto + 1 
    1369                isendto(nsndto) = jn 
    1370             ELSEIF( dxM <  dxT  .AND.  sxT <  dxM ) THEN 
    1371                nsndto          = nsndto + 1 
    1372                isendto(nsndto) = jn 
    1373             ENDIF 
    1374             ! 
    1375          END DO 
    1376          ! 
    1377       ENDIF 
    1378       l_north_nogather = .TRUE. 
     1307      END DO 
    13791308      ! 
    13801309   END SUBROUTINE init_nfdcom 
     
    13891318      !!---------------------------------------------------------------------- 
    13901319      ! 
    1391       Nis0 =   1+nn_hls   ;   Nis1 = Nis0-1   ;   Nis2 = MAX(  1, Nis0-2) 
    1392       Njs0 =   1+nn_hls   ;   Njs1 = Njs0-1   ;   Njs2 = MAX(  1, Njs0-2) 
    1393       ! 
    1394       Nie0 = jpi-nn_hls   ;   Nie1 = Nie0+1   ;   Nie2 = MIN(jpi, Nie0+2) 
    1395       Nje0 = jpj-nn_hls   ;   Nje1 = Nje0+1   ;   Nje2 = MIN(jpj, Nje0+2) 
    1396       ! 
    1397       IF( nn_hls == 1 ) THEN          !* halo size of 1 
    1398          ! 
    1399          Nis1nxt2 = Nis0   ;   Njs1nxt2 = Njs0 
    1400          Nie1nxt2 = Nie0   ;   Nje1nxt2 = Nje0 
    1401          ! 
    1402       ELSE                            !* larger halo size... 
    1403          ! 
    1404          Nis1nxt2 = Nis1   ;   Njs1nxt2 = Njs1 
    1405          Nie1nxt2 = Nie1   ;   Nje1nxt2 = Nje1 
    1406          ! 
    1407       ENDIF 
     1320      Nis0 =   1+nn_hls 
     1321      Njs0 =   1+nn_hls 
     1322      Nie0 = jpi-nn_hls 
     1323      Nje0 = jpj-nn_hls 
    14081324      ! 
    14091325      Ni_0 = Nie0 - Nis0 + 1 
    14101326      Nj_0 = Nje0 - Njs0 + 1 
    1411       Ni_1 = Nie1 - Nis1 + 1 
    1412       Nj_1 = Nje1 - Njs1 + 1 
    1413       Ni_2 = Nie2 - Nis2 + 1 
    1414       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                             !   "           " 
    14151332      ! 
    14161333   END SUBROUTINE init_doloop 
  • NEMO/trunk/src/OCE/LDF/ldfc1d_c2d.F90

    r14189 r14433  
    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/trunk/src/OCE/LDF/ldfdyn.F90

    r14201 r14433  
    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/trunk/src/OCE/LDF/ldfslp.F90

    r14312 r14433  
    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 
     
    289289!!gm end modif 
    290290      END_3D 
    291       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 
    292292      ! 
    293293      !                                           !* horizontal Shapiro filter 
     
    318318      ! IV. Lateral boundary conditions 
    319319      ! =============================== 
    320       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 ) 
    321321 
    322322      IF(sn_cfctl%l_prtctl) THEN 
     
    659659      END_2D 
    660660      !!gm this lbc_lnk should be useless.... 
    661       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 )  
    662662      ! 
    663663   END SUBROUTINE ldf_slp_mxl 
     
    727727!               END DO 
    728728!            END DO 
    729 !            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. ) 
    730730!!gm         ENDIF 
    731731      ENDIF 
  • NEMO/trunk/src/OCE/LDF/ldftra.F90

    r14201 r14433  
    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/trunk/src/OCE/SBC/geo2ocean.F90

    r14215 r14433  
    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/trunk/src/OCE/SBC/sbcblk.F90

    r14402 r14433  
    832832 
    833833         IF( ln_crt_fbk ) THEN 
    834             CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp, taum, 'T', 1._wp ) 
     834            CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp, taum, 'T', 1._wp ) 
    835835         ELSE 
    836             CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp ) 
     836            CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp ) 
    837837         ENDIF 
    838838 
     
    10681068            pvtaui(ji,jj) = zztmp2 * ( pvtaui(ji,jj) + pvtaui(ji  ,jj+1) ) 
    10691069         END_2D 
    1070          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 ) 
    10711071         ! 
    10721072         IF(sn_cfctl%l_prtctl)  CALL prt_ctl( tab2d_1=putaui  , clinfo1=' blk_ice: putaui : '   & 
  • NEMO/trunk/src/OCE/SBC/sbccpl.F90

    r14227 r14433  
    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/trunk/src/OCE/SBC/sbcflx.F90

    r14401 r14433  
    170170      END_2D 
    171171      ! 
    172       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 ) 
    173173      ! 
    174174   END SUBROUTINE sbc_flx 
  • NEMO/trunk/src/OCE/SBC/sbcice_cice.F90

    r14275 r14433  
    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 
  • NEMO/trunk/src/OCE/SBC/sbcwave.F90

    r14398 r14433  
    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      ! 
  • NEMO/trunk/src/OCE/TRA/traadv.F90

    r14189 r14433  
    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/trunk/src/OCE/TRA/traadv_cen.F90

    r14072 r14433  
    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/trunk/src/OCE/TRA/traadv_fct.F90

    r14298 r14433  
    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) 
     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) 
    259259            ! 
    260260            DO_3D( 0, 0, 0, 0, 1, jpkm1 )    ! Horizontal advective fluxes 
     
    268268               zwy(ji,jj,jk) =  0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 
    269269            END_3D 
    270             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) 
    271271            ! 
    272272         END SELECT 
     
    292292         ! 
    293293         IF (nn_hls.EQ.1) THEN 
    294             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 ) 
    295295         ELSE 
    296296            CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) 
     
    449449         END_2D 
    450450      END DO 
    451       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) 
    452452 
    453453      ! 3. monotonic flux in the i & j direction (paa & pbb) 
  • NEMO/trunk/src/OCE/TRA/traadv_fct_lf.F90

    r14072 r14433  
    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/trunk/src/OCE/TRA/traadv_mus.F90

    r14072 r14433  
    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/trunk/src/OCE/TRA/traadv_qck.F90

    r14215 r14433  
    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/trunk/src/OCE/TRA/traadv_ubs.F90

    r14072 r14433  
    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/trunk/src/OCE/TRA/traatf.F90

    r14072 r14433  
    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/trunk/src/OCE/TRA/traatf_qco.F90

    r14072 r14433  
    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/trunk/src/OCE/TRA/trabbl.F90

    r14215 r14433  
    141141         IF( ntile == 0 .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 
     
    522522      ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 
    523523      zmbku(:,:) = REAL( mbku_d(:,:), wp )   ;     zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) 
    524       CALL lbc_lnk_multi( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp) 
     524      CALL lbc_lnk( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp) 
    525525      mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ;  mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) 
    526526      ! 
     
    541541         e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji  ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 
    542542      END_2D 
    543       CALL lbc_lnk_multi( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp )      ! lateral boundary conditions 
     543      CALL lbc_lnk( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp )      ! lateral boundary conditions 
    544544      ! 
    545545      !                             !* masked diffusive flux coefficients 
  • NEMO/trunk/src/OCE/TRA/tramle.F90

    r14210 r14433  
    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/trunk/src/OCE/TRA/trazdf.F90

    r14189 r14433  
    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/trunk/src/OCE/TRA/zpshde.F90

    r14189 r14433  
    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/trunk/src/OCE/TRD/trddyn.F90

    r13497 r14433  
    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/trunk/src/OCE/TRD/trdken.F90

    r13295 r14433  
    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/trunk/src/OCE/TRD/trdmxl.F90

    r13497 r14433  
    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/trunk/src/OCE/TRD/trdvor.F90

    r13497 r14433  
    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/trunk/src/OCE/USR/README.rst

    r14239 r14433  
    111111   /* configuration name, configuration resolution                 */ 
    112112   int    ORCA, ORCA_index 
    113    /* global domain sizes                                          */ 
    114    int    jpiglo, jpjglo, jpkglo 
    115113   /* lateral global domain b.c.                                   */ 
    116    int    jperio 
     114   int    Iperio, Jperio, NFoldT, NFoldF 
    117115   /* flags for z-coord, z-coord with partial steps and s-coord    */ 
    118116   int    ln_zco, ln_zps, ln_sco 
  • NEMO/trunk/src/OCE/USR/usrdef_nam.F90

    r14072 r14433  
    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/trunk/src/OCE/USR/usrdef_sbc.F90

    r13295 r14433  
    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/trunk/src/OCE/ZDF/zdfmfc.F90

    r14072 r14433  
    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/trunk/src/OCE/ZDF/zdfosm.F90

    r14215 r14433  
    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/trunk/src/OCE/ZDF/zdfphy.F90

    r14072 r14433  
    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/trunk/src/OCE/lib_fortran.F90

    r13327 r14433  
    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/trunk/src/OCE/module_example.F90

    r14041 r14433  
    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/trunk/src/OCE/nemogcm.F90

    r14239 r14433  
    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/trunk/src/OCE/par_kind.F90

    r13226 r14433  
    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/trunk/src/OCE/par_oce.F90

    r14072 r14433  
    9191 
    9292   ! halo with and starting/inding DO-loop indices 
    93    INTEGER, PUBLIC ::   nn_hls   !: halo width (applies to both rows and columns) 
    94    INTEGER, PUBLIC ::   Nis0, Nis1, Nis1nxt2, Nis2   !: start I-index (_0: without halo, _1 or _2: with 1 or 2 halos) 
    95    INTEGER, PUBLIC ::   Nie0, Nie1, Nie1nxt2, Nie2   !: end   I-index (_0: without halo, _1 or _2: with 1 or 2 halos) 
    96    INTEGER, PUBLIC ::   Njs0, Njs1, Njs1nxt2, Njs2   !: start J-index (_0: without halo, _1 or _2: with 1 or 2 halos) 
    97    INTEGER, PUBLIC ::   Nje0, Nje1, Nje1nxt2, Nje2   !: end   J-index (_0: without halo, _1 or _2: with 1 or 2 halos) 
    98    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) 
    99    INTEGER, PUBLIC ::   Ni0glo, Nj0glo 
     93   INTEGER, PUBLIC ::   nn_hls           !: halo width (applies to both rows and columns) 
     94   INTEGER, PUBLIC ::   Nis0             !: start I-index without halo 
     95   INTEGER, PUBLIC ::   Nie0             !: end   I-index without halo 
     96   INTEGER, PUBLIC ::   Njs0             !: start J-index without halo 
     97   INTEGER, PUBLIC ::   Nje0             !: end   J-index without halo 
     98   INTEGER, PUBLIC ::   Ni_0, Nj_0       !: local domain size without halo 
     99   INTEGER, PUBLIC ::   Ni0glo, Nj0glo   !: global domain size without halo 
    100100 
    101101   !!---------------------------------------------------------------------- 
  • NEMO/trunk/src/OCE/stpctl.F90

    r14318 r14433  
    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 
  • NEMO/trunk/src/OCE/stpmlf.F90

    r14239 r14433  
    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.