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 – NEMO

Changeset 14433


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

trunk: merge dev_r14312_MPI_Interface into the trunk, #2598

Location:
NEMO/trunk
Files:
5 deleted
154 edited
3 copied

Legend:

Unmodified
Added
Removed

  • NEMO/trunk/cfgs/C1D_PAPA/MY_SRC/usrdef_nam.F90

    r12377 r14433  
    3939CONTAINS 
    4040 
    41    SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 
     41   SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 
    4242      !!---------------------------------------------------------------------- 
    4343      !!                     ***  ROUTINE dom_nam  *** 
    … …  
    5151      !! ** input   : - namusr_def namelist found in namelist_cfg 
    5252      !!---------------------------------------------------------------------- 
    53       CHARACTER(len=*)              , INTENT(out) ::   cd_cfg          ! configuration name 
    54       INTEGER                       , INTENT(out) ::   kk_cfg          ! configuration resolution 
    55       INTEGER                       , INTENT(out) ::   kpi, kpj, kpk   ! global domain sizes  
    56       INTEGER                       , INTENT(out) ::   kperio          ! lateral global domain b.c.  
     53      CHARACTER(len=*), INTENT(out) ::   cd_cfg               ! configuration name 
     54      INTEGER         , INTENT(out) ::   kk_cfg               ! configuration resolution 
     55      INTEGER         , INTENT(out) ::   kpi, kpj, kpk        ! global domain sizes 
     56      LOGICAL         , INTENT(out) ::   ldIperio, ldJperio   ! i- and j- periodicity 
     57      LOGICAL         , INTENT(out) ::   ldNFold              ! North pole folding 
     58      CHARACTER(len=1), INTENT(out) ::   cdNFtype             ! Folding type: T or F 
    5759      ! 
    5860      INTEGER ::   ios   ! Local integer 
    … …  
    7476      kpk = 75  
    7577      !                             ! Set the lateral boundary condition of the global domain 
    76       kperio =  7                   ! C1D configuration : 3x3 basin with cyclic Est-West and Norht-South condition 
     78      ldIperio =  .TRUE.   ;   ldJperio = .TRUE.   ! C1D configuration : 3x3 basin with cyclic Est-West and Norht-South condition 
     79      ldNFold  = .FALSE.   ;   cdNFtype = '-' 
    7780      ! 
    7881      !                             ! control print 
    … …  
    9093         WRITE(numout,*) '                                               jpjglo = ', kpj 
    9194         WRITE(numout,*) '                                               jpkglo = ', kpk 
    92          WRITE(numout,*) '   Lateral boundary condition of the global domain' 
    93          WRITE(numout,*) '      C1D : closed basin                       jperio = ', kperio 
     95         WRITE(numout,*) '   ' 
    9496      ENDIF 
    9597      ! 

  • NEMO/trunk/cfgs/SHARED/namelist_ref

    r14400 r14433  
    14981498   jpnj        =   0       !  number of processors following j (set automatically if < 1), see also ln_listonly = T 
    14991499   nn_hls      =   1       !  halo width (applies to both rows and columns) 
     1500   nn_comm     =   1       !  comm choice 
    15001501/ 
    15011502!----------------------------------------------------------------------- 

  • NEMO/trunk/doc/NEMO_manual_state.txt

    r13461 r14433  
    1515chap_misc.tex: key{mpp\_mpi} key{nosignedzero} key{vectopt\_loop} np{iom\_get} np{jpjdta} np{jpjglo} np{nn\_bench} np{nn\_bit\_cmp} np{open\_ocean\_jstart}  
    1616chap_LDF.tex: hf{dynldf\_cNd} hf{ldfdyn\_substitute} hf{ldftra\_substitute} hf{traldf\_c1d} hf{traldf\_cNd} key{dynldf\_c1d} key{dynldf\_c2d} key{dynldf\_c3d} key{traldf\_c1d} key{traldf\_c2d} key{traldf\_c3d} key{traldf\_cNd} key{traldf\_eiv} mdl{ldfdyn\_c2d} mdl{ldfeiv} mdl{traadv\_eiv} np{ln\_dynldf\_bilap} np{ln\_sco} np{nn\_eos} np{rn\_aeih\_0} np{rn\_aeiv} np{rn\_aeiv\_0} np{rn\_ahm0} np{rn\_ahmb0} np{rn\_aht0} np{rn\_ahtb0} np{traldf\_grif} np{traldf\_grif\_iso} rou{ldf\_dyn\_c2d\_orca} rou{ldfslp\_init}  
    17 chap_LBC.tex: jp{jpreci} key{mpp\_mpi} np{jperio} np{jpiglo} np{jpindt} np{jpinft} np{jpjglo} np{jpjnob} np{nbdysegn} np{nn\_bdy\_jpk} np{nn\_msh} np{nn\_tra} rou{inimpp2}  
    18 chap_DOM.tex: key{mpp\_mpi} ngn{namzgr} ngn{namzgr\_sco} nlst{namzgr} nlst{namzgr_sco} np{jperio} np{jpiglo} np{jpjglo} np{jpkglo} np{ln\_sco} np{ln\_sigcrit} np{ln\_s\_SF12} np{ln\_s\_SH94} np{ln\_tsd\_ini} np{ln\_zco} np{ln\_zps} np{nn\_bathy} np{nn\_msh} np{ppa0} np{ppa1} np{ppacr} np{ppdzmin} np{pphmax} np{ppkth} np{ppsur} np{rn\_alpha} np{rn\_bb} np{rn\_e3zps\_min} np{rn\_e3zps\_rat} np{rn\_hc} np{rn\_rmax} np{rn\_sbot\_max} np{rn\_sbot\_min} np{rn\_theta} np{rn\_zb\_a} np{rn\_zb\_b} np{rn\_zs} rou{istate\_t\_s}  
     17chap_LBC.tex: jp{jpreci} key{mpp\_mpi} np{jpiglo} np{jpindt} np{jpinft} np{jpjglo} np{jpjnob} np{nbdysegn} np{nn\_bdy\_jpk} np{nn\_msh} np{nn\_tra} rou{inimpp2}  
     18chap_DOM.tex: key{mpp\_mpi} ngn{namzgr} ngn{namzgr\_sco} nlst{namzgr} nlst{namzgr_sco} np{jpiglo} np{jpjglo} np{jpkglo} np{ln\_sco} np{ln\_sigcrit} np{ln\_s\_SF12} np{ln\_s\_SH94} np{ln\_tsd\_ini} np{ln\_zco} np{ln\_zps} np{nn\_bathy} np{nn\_msh} np{ppa0} np{ppa1} np{ppacr} np{ppdzmin} np{pphmax} np{ppkth} np{ppsur} np{rn\_alpha} np{rn\_bb} np{rn\_e3zps\_min} np{rn\_e3zps\_rat} np{rn\_hc} np{rn\_rmax} np{rn\_sbot\_max} np{rn\_sbot\_min} np{rn\_theta} np{rn\_zb\_a} np{rn\_zb\_b} np{rn\_zs} rou{istate\_t\_s}  
    1919chap_conservation.tex: key{\_}  
    2020annex_iso.tex: key{trabbl} key{traldf\_eiv} np{ln\_traldf\_eiv} np{ln\_traldf\_gdia}  

  • NEMO/trunk/doc/latex/NEMO/subfiles/chap_DOM.tex

    r14257 r14433  
    377377in which case \np{cn_cfg}{cn\_cfg} and \np{nn_cfg}{nn\_cfg} are set from these values accordingly). 
    378378 
    379 The global lateral boundary condition type is selected from 8 options using parameter \texttt{jperio}. 
     379The global lateral boundary condition type is selected from 8 options using parameters \texttt{l\_Iperio}, \texttt{l\_Jperio}, \texttt{l\_NFold} and \texttt{c\_NFtype}. 
    380380See \autoref{sec:LBC_jperio} for details on the available options and 
    381 the corresponding values for \texttt{jperio}. 
     381the corresponding values for \texttt{l\_Iperio}, \texttt{l\_Jperio}, \texttt{l\_NFold} and \texttt{c\_NFtype}. 
    382382 
    383383%% ================================================================================================= 
    … …  
    394394 
    395395\begin{clines} 
    396 int    jpiglo, jpjglo, jpkglo     /* global domain sizes                                    */ 
    397 int    jperio                     /* lateral global domain b.c.                             */ 
    398 double glamt, glamu, glamv, glamf /* geographic longitude (t,u,v and f points respectively) */ 
    399 double gphit, gphiu, gphiv, gphif /* geographic latitude                                    */ 
    400 double e1t, e1u, e1v, e1f         /* horizontal scale factors                               */ 
    401 double e2t, e2u, e2v, e2f         /* horizontal scale factors                               */ 
     396integer   Ni0glo, NjOglo, jpkglo       /* global domain sizes (without MPI halos)                */ 
     397logical   l\_Iperio, l\_Jperio         /* lateral global domain b.c.: i- j-periodicity           */ 
     398logical   l\_NFold                     /* lateral global domain b.c.: North Pole folding         */ 
     399char(1)   c\_NFtype                    /*    type of North pole Folding: T or F point            */ 
     400real      glamt, glamu, glamv, glamf   /* geographic longitude (t,u,v and f points respectively) */ 
     401real      gphit, gphiu, gphiv, gphif   /* geographic latitude                                    */ 
     402real      e1t, e1u, e1v, e1f           /* horizontal scale factors                               */ 
     403real      e2t, e2u, e2v, e2f           /* horizontal scale factors                               */ 
    402404\end{clines} 
    403405 

  • NEMO/trunk/doc/latex/NEMO/subfiles/chap_LBC.tex

    r14257 r14433  
    159159 
    160160%% ================================================================================================= 
    161 \section{Model domain boundary condition (\forcode{jperio})} 
     161\section{Model domain boundary condition} 
    162162\label{sec:LBC_jperio} 
    163163 
    … …  
    168168 
    169169%% ================================================================================================= 
    170 \subsection{Closed, cyclic (\forcode{jperio={0,1,2,7}})} 
     170\subsection{Closed, cyclic (\forcode{l\_Iperio,l\_jperio})} 
    171171\label{subsec:LBC_jperio012} 
    172172 
    173173The choice of closed or cyclic model domain boundary condition is made by 
    174 setting \forcode{jperio} to 0, 1, 2 or 7 in namelist \nam{cfg}{cfg}. 
     174setting \forcode{l\_Iperio,l\_jperio} to true or false in namelist \nam{cfg}{cfg}. 
    175175Each time such a boundary condition is needed, it is set by a call to routine \mdl{lbclnk}. 
    176176The computation of momentum and tracer trends proceeds from $i=2$ to $i=jpi-1$ and from $j=2$ to $j=jpj-1$, 
    … …  
    181181\begin{description} 
    182182 
    183 \item [For closed boundary (\forcode{jperio=0})], solid walls are imposed at all model boundaries: 
     183\item [For closed boundary (\forcode{l\_Iperio = .false.,l\_jperio = .false.})], solid walls are imposed at all model boundaries: 
    184184  first and last rows and columns are set to zero. 
    185185 
    186 \item [For cyclic east-west boundary (\forcode{jperio=1})], first and last rows are set to zero (closed) whilst the first column is set to 
     186\item [For cyclic east-west boundary (\forcode{l\_Iperio = .true.,l\_jperio = .false.})], first and last rows are set to zero (closed) whilst the first column is set to 
    187187  the value of the last-but-one column and the last column to the value of the second one 
    188188  (\autoref{fig:LBC_jperio}-a). 
    189189  Whatever flows out of the eastern (western) end of the basin enters the western (eastern) end. 
    190190 
    191 \item [For cyclic north-south boundary (\forcode{jperio=2})], first and last columns are set to zero (closed) whilst the first row is set to 
     191\item [For cyclic north-south boundary (\forcode{l\_Iperio = .false.,l\_jperio = .true.})], first and last columns are set to zero (closed) whilst the first row is set to 
    192192  the value of the last-but-one row and the last row to the value of the second one 
    193193  (\autoref{fig:LBC_jperio}-a). 
    194194  Whatever flows out of the northern (southern) end of the basin enters the southern (northern) end. 
    195195 
    196 \item [Bi-cyclic east-west and north-south boundary (\forcode{jperio=7})] combines cases 1 and 2. 
     196\item [Bi-cyclic east-west and north-south boundary (\forcode{l\_Iperio = .true.,l\_jperio = .true.})] combines cases 1 and 2. 
    197197 
    198198\end{description} 
    … …  
    207207 
    208208%% ================================================================================================= 
    209 \subsection{North-fold (\forcode{jperio={3,6}})} 
     209\subsection{North-fold (\forcode{l\_NFold = .true.})} 
    210210\label{subsec:LBC_north_fold} 
    211211 
    … …  
    220220  \includegraphics[width=0.66\textwidth]{LBC_North_Fold_T} 
    221221  \caption[North fold boundary in ORCA 2\deg, 1/4\deg and 1/12\deg]{ 
    222     North fold boundary with a $T$-point pivot and cyclic east-west boundary condition ($jperio=4$), 
     222    North fold boundary with a $T$-point pivot and cyclic east-west boundary condition ($c\_NFtype='T'$), 
    223223    as used in ORCA 2\deg, 1/4\deg and 1/12\deg. 
    224224    Pink shaded area corresponds to the inner domain mask (see text).} 

  • NEMO/trunk/src/ABL/ablmod.F90

    r14239 r14433  
    534534      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    535535      ! 
    536       CALL lbc_lnk_multi( 'ablmod',  u_abl(:,:,:,nt_a      ), 'T', -1._wp,  v_abl(:,:,:,nt_a)      , 'T', -1._wp                            ) 
    537       CALL lbc_lnk_multi( 'ablmod', tq_abl(:,:,:,nt_a,jp_ta), 'T', 1._wp , tq_abl(:,:,:,nt_a,jp_qa), 'T',  1._wp , kfillmode = jpfillnothing )   ! ++++ this should not be needed... 
     536      CALL lbc_lnk( 'ablmod',  u_abl(:,:,:,nt_a      ), 'T', -1._wp,  v_abl(:,:,:,nt_a)      , 'T', -1._wp                            ) 
     537      CALL lbc_lnk( 'ablmod', tq_abl(:,:,:,nt_a,jp_ta), 'T', 1._wp , tq_abl(:,:,:,nt_a,jp_qa), 'T',  1._wp , kfillmode = jpfillnothing )   ! ++++ this should not be needed... 
    538538      ! 
    539539#if defined key_xios 
    … …  
    600600      END_2D 
    601601      ! 
    602       CALL lbc_lnk_multi( 'ablmod', zwnd_i(:,:) , 'T', -1.0_wp, zwnd_j(:,:) , 'T', -1.0_wp ) 
     602      CALL lbc_lnk( 'ablmod', zwnd_i(:,:) , 'T', -1.0_wp, zwnd_j(:,:) , 'T', -1.0_wp ) 
    603603      ! 
    604604      ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) 
    … …  
    625625      END_2D 
    626626      ! 
    627       CALL lbc_lnk_multi( 'ablmod', ptaui(:,:), 'U', -1.0_wp, ptauj(:,:), 'V', -1.0_wp ) 
     627      CALL lbc_lnk( 'ablmod', ptaui(:,:), 'U', -1.0_wp, ptauj(:,:), 'V', -1.0_wp ) 
    628628 
    629629      CALL iom_put( "taum_oce", ptaum ) 
    … …  
    645645            &                      * ( 0.5_wp * ( v_abl(ji,jj+1,2,nt_a) + v_abl(ji,jj,2,nt_a) ) - pssv_ice(ji,jj) ) 
    646646      END_2D 
    647       CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice, 'V', -1.0_wp ) 
     647      CALL lbc_lnk( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice, 'V', -1.0_wp ) 
    648648      ! 
    649649      IF(sn_cfctl%l_prtctl)   CALL prt_ctl( tab2d_1=ptaui_ice  , clinfo1=' abl_stp: putaui : '   & 
    … …  
    664664            &         * ( zztmp2 - pssv_ice(ji,jj) ) 
    665665      END_2D 
    666       CALL lbc_lnk_multi( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice,'V', -1.0_wp ) 
     666      CALL lbc_lnk( 'ablmod', ptaui_ice, 'U', -1.0_wp, ptauj_ice,'V', -1.0_wp ) 
    667667      ! 
    668668      IF(sn_cfctl%l_prtctl) THEN 

  • NEMO/trunk/src/ICE/icecor.F90

    r13641 r14433  
    116116            ENDIF 
    117117         END_2D 
    118          CALL lbc_lnk_multi( 'icecor', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp ) 
     118         CALL lbc_lnk( 'icecor', u_ice, 'U', -1.0_wp, v_ice, 'V', -1.0_wp ) 
    119119      ENDIF 
    120120      ! 

  • NEMO/trunk/src/ICE/icedyn_adv_pra.F90

    r14215 r14433  
    115115      CALL icemax3D( ph_ip, zhip_max) 
    116116      CALL icemax3D( zs_i , zsi_max ) 
    117       CALL lbc_lnk_multi( 'icedyn_adv_pra', zhi_max, 'T', 1._wp, zhs_max, 'T', 1._wp, zhip_max, 'T', 1._wp, zsi_max, 'T', 1._wp ) 
     117      CALL lbc_lnk( 'icedyn_adv_pra', zhi_max, 'T', 1._wp, zhs_max, 'T', 1._wp, zhip_max, 'T', 1._wp, zsi_max, 'T', 1._wp ) 
    118118      ! 
    119119      ! enthalpies 
    … …  
    265265         ! --- Lateral boundary conditions --- ! 
    266266         !     caution: for gradients (sx and sy) the sign changes 
    267          CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ice , 'T', 1._wp, sxice , 'T', -1._wp, syice , 'T', -1._wp  & ! ice volume 
    268             &                                , sxxice, 'T', 1._wp, syyice, 'T',  1._wp, sxyice, 'T',  1._wp  & 
    269             &                                , z0snw , 'T', 1._wp, sxsn  , 'T', -1._wp, sysn  , 'T', -1._wp  & ! snw volume 
    270             &                                , sxxsn , 'T', 1._wp, syysn , 'T',  1._wp, sxysn , 'T',  1._wp  ) 
    271          CALL lbc_lnk_multi( 'icedyn_adv_pra', z0smi , 'T', 1._wp, sxsal , 'T', -1._wp, sysal , 'T', -1._wp  & ! ice salinity 
    272             &                                , sxxsal, 'T', 1._wp, syysal, 'T',  1._wp, sxysal, 'T',  1._wp  & 
    273             &                                , z0ai  , 'T', 1._wp, sxa   , 'T', -1._wp, sya   , 'T', -1._wp  & ! ice concentration 
    274             &                                , sxxa  , 'T', 1._wp, syya  , 'T',  1._wp, sxya  , 'T',  1._wp  ) 
    275          CALL lbc_lnk_multi( 'icedyn_adv_pra', z0oi  , 'T', 1._wp, sxage , 'T', -1._wp, syage , 'T', -1._wp  & ! ice age 
    276             &                                , sxxage, 'T', 1._wp, syyage, 'T',  1._wp, sxyage, 'T',  1._wp  ) 
    277          CALL lbc_lnk_multi( 'icedyn_adv_pra', z0es  , 'T', 1._wp, sxc0  , 'T', -1._wp, syc0  , 'T', -1._wp  & ! snw enthalpy 
    278             &                                , sxxc0 , 'T', 1._wp, syyc0 , 'T',  1._wp, sxyc0 , 'T',  1._wp  ) 
    279          CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ei  , 'T', 1._wp, sxe   , 'T', -1._wp, sye   , 'T', -1._wp  & ! ice enthalpy 
    280             &                                , sxxe  , 'T', 1._wp, syye  , 'T',  1._wp, sxye  , 'T',  1._wp  ) 
     267         CALL lbc_lnk( 'icedyn_adv_pra', z0ice , 'T', 1._wp, sxice , 'T', -1._wp, syice , 'T', -1._wp  & ! ice volume 
     268            &                          , sxxice, 'T', 1._wp, syyice, 'T',  1._wp, sxyice, 'T',  1._wp  & 
     269            &                          , z0snw , 'T', 1._wp, sxsn  , 'T', -1._wp, sysn  , 'T', -1._wp  & ! snw volume 
     270            &                          , sxxsn , 'T', 1._wp, syysn , 'T',  1._wp, sxysn , 'T',  1._wp  ) 
     271         CALL lbc_lnk( 'icedyn_adv_pra', z0smi , 'T', 1._wp, sxsal , 'T', -1._wp, sysal , 'T', -1._wp  & ! ice salinity 
     272            &                          , sxxsal, 'T', 1._wp, syysal, 'T',  1._wp, sxysal, 'T',  1._wp  & 
     273            &                          , z0ai  , 'T', 1._wp, sxa   , 'T', -1._wp, sya   , 'T', -1._wp  & ! ice concentration 
     274            &                          , sxxa  , 'T', 1._wp, syya  , 'T',  1._wp, sxya  , 'T',  1._wp  ) 
     275         CALL lbc_lnk( 'icedyn_adv_pra', z0oi  , 'T', 1._wp, sxage , 'T', -1._wp, syage , 'T', -1._wp  & ! ice age 
     276            &                          , sxxage, 'T', 1._wp, syyage, 'T',  1._wp, sxyage, 'T',  1._wp  ) 
     277         CALL lbc_lnk( 'icedyn_adv_pra', z0es  , 'T', 1._wp, sxc0  , 'T', -1._wp, syc0  , 'T', -1._wp  & ! snw enthalpy 
     278            &                          , sxxc0 , 'T', 1._wp, syyc0 , 'T',  1._wp, sxyc0 , 'T',  1._wp  ) 
     279         CALL lbc_lnk( 'icedyn_adv_pra', z0ei  , 'T', 1._wp, sxe   , 'T', -1._wp, sye   , 'T', -1._wp  & ! ice enthalpy 
     280            &                          , sxxe  , 'T', 1._wp, syye  , 'T',  1._wp, sxye  , 'T',  1._wp  ) 
    281281         IF ( ln_pnd_LEV .OR. ln_pnd_TOPO ) THEN 
    282             CALL lbc_lnk_multi( 'icedyn_adv_pra', z0ap , 'T', 1._wp, sxap , 'T', -1._wp, syap , 'T', -1._wp  & ! melt pond fraction 
    283                &                                , sxxap, 'T', 1._wp, syyap, 'T',  1._wp, sxyap, 'T',  1._wp  & 
    284                &                                , z0vp , 'T', 1._wp, sxvp , 'T', -1._wp, syvp , 'T', -1._wp  & ! melt pond volume 
    285                &                                , sxxvp, 'T', 1._wp, syyvp, 'T',  1._wp, sxyvp, 'T',  1._wp  ) 
     282            CALL lbc_lnk( 'icedyn_adv_pra', z0ap , 'T', 1._wp, sxap , 'T', -1._wp, syap , 'T', -1._wp  & ! melt pond fraction 
     283               &                          , sxxap, 'T', 1._wp, syyap, 'T',  1._wp, sxyap, 'T',  1._wp  & 
     284               &                          , z0vp , 'T', 1._wp, sxvp , 'T', -1._wp, syvp , 'T', -1._wp  & ! melt pond volume 
     285               &                          , sxxvp, 'T', 1._wp, syyvp, 'T',  1._wp, sxyvp, 'T',  1._wp  ) 
    286286            IF ( ln_pnd_lids ) THEN 
    287                CALL lbc_lnk_multi( 'icedyn_adv_pra', z0vl ,'T', 1._wp, sxvl ,'T', -1._wp, syvl ,'T', -1._wp  & ! melt pond lid volume 
    288                   &                                , sxxvl,'T', 1._wp, syyvl,'T',  1._wp, sxyvl,'T',  1._wp  ) 
     287               CALL lbc_lnk( 'icedyn_adv_pra', z0vl ,'T', 1._wp, sxvl ,'T', -1._wp, syvl ,'T', -1._wp  & ! melt pond lid volume 
     288                  &                          , sxxvl,'T', 1._wp, syyvl,'T',  1._wp, sxyvl,'T',  1._wp  ) 
    289289            ENDIF 
    290290         ENDIF 

  • NEMO/trunk/src/ICE/icedyn_adv_umx.F90

    r14215 r14433  
    119119      CALL icemax3D( ph_ip, zhip_max) 
    120120      CALL icemax3D( zs_i , zsi_max ) 
    121       CALL lbc_lnk_multi( 'icedyn_adv_umx', zhi_max, 'T', 1._wp, zhs_max, 'T', 1._wp, zhip_max, 'T', 1._wp, zsi_max, 'T', 1._wp ) 
     121      CALL lbc_lnk( 'icedyn_adv_umx', zhi_max, 'T', 1._wp, zhs_max, 'T', 1._wp, zhip_max, 'T', 1._wp, zsi_max, 'T', 1._wp ) 
    122122      ! 
    123123      ! enthalpies 
    … …  
    360360         ! --- Lateral boundary conditions --- ! 
    361361         IF    ( ( ln_pnd_LEV .OR. ln_pnd_TOPO ) .AND. ln_pnd_lids ) THEN 
    362             CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp & 
    363                &                                , pa_ip,'T',1._wp, pv_ip,'T',1._wp, pv_il,'T',1._wp ) 
     362            CALL lbc_lnk( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp & 
     363               &                          , pa_ip,'T',1._wp, pv_ip,'T',1._wp, pv_il,'T',1._wp ) 
    364364         ELSEIF( ( ln_pnd_LEV .OR. ln_pnd_TOPO ) .AND. .NOT.ln_pnd_lids ) THEN 
    365             CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp & 
    366                &                                , pa_ip,'T',1._wp, pv_ip,'T',1._wp ) 
     365            CALL lbc_lnk( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp & 
     366               &                          , pa_ip,'T',1._wp, pv_ip,'T',1._wp ) 
    367367         ELSE 
    368             CALL lbc_lnk_multi( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp ) 
     368            CALL lbc_lnk( 'icedyn_adv_umx', pa_i,'T',1._wp, pv_i,'T',1._wp, pv_s,'T',1._wp, psv_i,'T',1._wp, poa_i,'T',1._wp ) 
    369369         ENDIF 
    370370         CALL lbc_lnk( 'icedyn_adv_umx', pe_i, 'T', 1._wp ) 
    … …  
    11691169            END_2D 
    11701170         END DO 
    1171          CALL lbc_lnk_multi( 'icedyn_adv_umx', zti_ups, 'T', 1.0_wp, ztj_ups, 'T', 1.0_wp ) 
     1171         CALL lbc_lnk( 'icedyn_adv_umx', zti_ups, 'T', 1.0_wp, ztj_ups, 'T', 1.0_wp ) 
    11721172 
    11731173         DO jl = 1, jpl 
    … …  
    11911191            END_2D 
    11921192         END DO 
    1193          CALL lbc_lnk_multi( 'icedyn_adv_umx', pfu_ho, 'U', -1.0_wp, pfv_ho, 'V', -1.0_wp )   ! lateral boundary cond. 
     1193         CALL lbc_lnk( 'icedyn_adv_umx', pfu_ho, 'U', -1.0_wp, pfv_ho, 'V', -1.0_wp )   ! lateral boundary cond. 
    11941194 
    11951195      ENDIF 
    … …  
    12481248         END_2D 
    12491249      END DO 
    1250       CALL lbc_lnk_multi( 'icedyn_adv_umx', zbetup, 'T', 1.0_wp, zbetdo, 'T', 1.0_wp )   ! lateral boundary cond. (unchanged sign) 
     1250      CALL lbc_lnk( 'icedyn_adv_umx', zbetup, 'T', 1.0_wp, zbetdo, 'T', 1.0_wp )   ! lateral boundary cond. (unchanged sign) 
    12511251 
    12521252 

  • NEMO/trunk/src/ICE/icedyn_rhg_eap.F90

    r14120 r14433  
    350350 
    351351      END_2D 
    352       CALL lbc_lnk_multi( 'icedyn_rhg_eap', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp ) 
     352      CALL lbc_lnk( 'icedyn_rhg_eap', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp ) 
    353353      ! 
    354354      !                                  !== Landfast ice parameterization ==! 
    … …  
    488488            zs2(ji,jj) = ( zs2(ji,jj) * zalph1 + zstressmtmp ) * z1_alph1 
    489489         END_2D 
    490          CALL lbc_lnk_multi( 'icedyn_rhg_eap', zstress12tmp, 'T', 1.0_wp , paniso_11, 'T', 1.0_wp , paniso_12, 'T', 1.0_wp) 
     490         CALL lbc_lnk( 'icedyn_rhg_eap', zstress12tmp, 'T', 1.0_wp , paniso_11, 'T', 1.0_wp , paniso_12, 'T', 1.0_wp) 
    491491 
    492492        ! Save beta at T-points for further computations 
    … …  
    516516 
    517517         END_2D 
    518          CALL lbc_lnk_multi( 'icedyn_rhg_eap', zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp, zs12, 'F', 1.0_wp ) 
     518         CALL lbc_lnk( 'icedyn_rhg_eap', zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp, zs12, 'F', 1.0_wp ) 
    519519 
    520520         ! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- ! 
    … …  
    810810 
    811811      END_2D 
    812       CALL lbc_lnk_multi( 'icedyn_rhg_eap', pshear_i, 'T', 1.0_wp, pdivu_i, 'T', 1.0_wp, pdelta_i, 'T', 1.0_wp, & 
    813          &                                    zten_i, 'T', 1.0_wp, zs1    , 'T', 1.0_wp, zs2     , 'T', 1.0_wp, & 
    814          &                                      zs12, 'F', 1.0_wp ) 
     812      CALL lbc_lnk( 'icedyn_rhg_eap', pshear_i, 'T', 1.0_wp, pdivu_i, 'T', 1.0_wp, pdelta_i, 'T', 1.0_wp, & 
     813         &                              zten_i, 'T', 1.0_wp, zs1    , 'T', 1.0_wp, zs2     , 'T', 1.0_wp, & 
     814         &                                zs12, 'F', 1.0_wp ) 
    815815 
    816816      ! --- Store the stress tensor for the next time step --- ! 
    … …  
    827827         & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN 
    828828         ! 
    829          CALL lbc_lnk_multi( 'icedyn_rhg_eap', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, ztaux_ai, 'U', -1.0_wp, & 
    830             &                                  ztauy_ai, 'V', -1.0_wp, ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 
     829         CALL lbc_lnk( 'icedyn_rhg_eap', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, ztaux_ai, 'U', -1.0_wp, & 
     830            &                            ztauy_ai, 'V', -1.0_wp, ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 
    831831         ! 
    832832         CALL iom_put( 'utau_oi' , ztaux_oi * aimsk00 ) 
    … …  
    912912      IF( iom_use('yield11') .OR. iom_use('yield12') .OR. iom_use('yield22')) THEN 
    913913 
    914          CALL lbc_lnk_multi( 'icedyn_rhg_eap', zyield11, 'T', 1.0_wp, zyield22, 'T', 1.0_wp, zyield12, 'T', 1.0_wp ) 
     914         CALL lbc_lnk( 'icedyn_rhg_eap', zyield11, 'T', 1.0_wp, zyield22, 'T', 1.0_wp, zyield12, 'T', 1.0_wp ) 
    915915 
    916916         CALL iom_put( 'yield11', zyield11 * aimsk00 ) 
    … …  
    929929         & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN 
    930930         ! 
    931          CALL lbc_lnk_multi( 'icedyn_rhg_eap', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & 
    932             &                                  zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, & 
    933             &                                    zfU, 'U', -1.0_wp,   zfV, 'V', -1.0_wp ) 
     931         CALL lbc_lnk( 'icedyn_rhg_eap', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & 
     932            &                            zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, & 
     933            &                              zfU, 'U', -1.0_wp,   zfV, 'V', -1.0_wp ) 
    934934 
    935935         CALL iom_put( 'dssh_dx' , zspgU * aimsk00 )   ! Sea-surface tilt term in force balance (x) 
    … …  
    963963         END_2D 
    964964 
    965          CALL lbc_lnk_multi( 'icedyn_rhg_eap', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & 
    966             &                                  zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & 
    967             &                                  zdiag_xatrp    , 'U', -1.0_wp, zdiag_yatrp    , 'V', -1.0_wp ) 
     965         CALL lbc_lnk( 'icedyn_rhg_eap', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & 
     966            &                            zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & 
     967            &                            zdiag_xatrp    , 'U', -1.0_wp, zdiag_yatrp    , 'V', -1.0_wp ) 
    968968 
    969969         CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice )   ! X-component of sea-ice mass transport (kg/s) 

  • NEMO/trunk/src/ICE/icedyn_rhg_evp.F90

    r14072 r14433  
    316316 
    317317      END_2D 
    318       CALL lbc_lnk_multi( 'icedyn_rhg_evp', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp ) 
     318      CALL lbc_lnk( 'icedyn_rhg_evp', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp ) 
    319319      ! 
    320320      !                                  !== Landfast ice parameterization ==! 
    … …  
    750750 
    751751      END_2D 
    752       CALL lbc_lnk_multi( 'icedyn_rhg_evp', pshear_i, 'T', 1._wp, pdivu_i, 'T', 1._wp, pdelta_i, 'T', 1._wp, zten_i, 'T', 1._wp, & 
    753          &                                  zs1     , 'T', 1._wp, zs2    , 'T', 1._wp, zs12    , 'F', 1._wp ) 
     752      CALL lbc_lnk( 'icedyn_rhg_evp', pshear_i, 'T', 1._wp, pdivu_i, 'T', 1._wp, pdelta_i, 'T', 1._wp, zten_i, 'T', 1._wp, & 
     753         &                            zs1     , 'T', 1._wp, zs2    , 'T', 1._wp, zs12    , 'F', 1._wp ) 
    754754 
    755755      ! --- Store the stress tensor for the next time step --- ! 
    … …  
    766766         & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN 
    767767         ! 
    768          CALL lbc_lnk_multi( 'icedyn_rhg_evp', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, ztaux_ai, 'U', -1.0_wp, ztauy_ai, 'V', -1.0_wp, & 
    769             &                                  ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 
     768         CALL lbc_lnk( 'icedyn_rhg_evp', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, & 
     769            &                            ztaux_ai, 'U', -1.0_wp, ztauy_ai, 'V', -1.0_wp, & 
     770            &                            ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 
    770771         ! 
    771772         CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) 
    … …  
    851852         & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN 
    852853         ! 
    853          CALL lbc_lnk_multi( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & 
    854             &                                  zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) 
     854         CALL lbc_lnk( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & 
     855            &                            zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) 
    855856 
    856857         CALL iom_put( 'dssh_dx' , zspgU * zmsk00 )   ! Sea-surface tilt term in force balance (x) 
    … …  
    884885         END_2D 
    885886 
    886          CALL lbc_lnk_multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & 
    887             &                                  zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & 
    888             &                                  zdiag_xatrp    , 'U', -1.0_wp, zdiag_yatrp    , 'V', -1.0_wp ) 
     887         CALL lbc_lnk( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & 
     888            &                            zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & 
     889            &                            zdiag_xatrp    , 'U', -1.0_wp, zdiag_yatrp    , 'V', -1.0_wp ) 
    889890 
    890891         CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice )   ! X-component of sea-ice mass transport (kg/s) 

  • NEMO/trunk/src/ICE/icedyn_rhg_vp.F90

    r14072 r14433  
    461461 
    462462         CALL lbc_lnk( 'icedyn_rhg_vp', zds, 'F', 1. ) ! MV TEST could be un-necessary according to Gurvan 
    463          CALL iom_put( 'zds'        , zds      )   ! MV DEBUG 
     463         CALL iom_put( 'zds'          , zds      )   ! MV DEBUG 
    464464 
    465465         IF( lwp )   WRITE(numout,*) ' outer loop  1a i_out : ', i_out 
    … …  
    506506         END DO 
    507507          
    508          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zp_deltastar_t , 'T', 1. , zzt , 'T', 1., zet, 'T', 1. ) 
     508         CALL lbc_lnk( 'icedyn_rhg_vp', zp_deltastar_t , 'T', 1. , zzt , 'T', 1., zet, 'T', 1. ) 
    509509 
    510510         CALL iom_put( 'zzt'        , zzt      )   ! MV DEBUG 
    … …  
    527527          
    528528         CALL lbc_lnk( 'icedyn_rhg_vp', zef, 'F', 1. ) 
    529          CALL iom_put( 'zef'           , zef            ) ! MV DEBUG 
     529         CALL iom_put( 'zef'          , zef            ) ! MV DEBUG 
    530530         IF( lwp )   WRITE(numout,*) ' outer loop  1c i_out : ', i_out 
    531531 
    … …  
    567567         IF( lwp )   WRITE(numout,*) ' outer loop  1d i_out : ', i_out 
    568568          
    569          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zCwU ,  'U', -1., zCwV, 'V', -1. ) 
    570          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zCorU,  'U', -1., zCorV, 'V', -1. ) 
     569         CALL lbc_lnk( 'icedyn_rhg_vp', zCwU ,  'U', -1., zCwV, 'V', -1. ) 
     570         CALL lbc_lnk( 'icedyn_rhg_vp', zCorU,  'U', -1., zCorV, 'V', -1. ) 
    571571 
    572572         CALL iom_put( 'zCwU'          , zCwU           ) ! MV DEBUG 
    … …  
    674674         END DO 
    675675          
    676          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zrhsu, 'U', -1., zrhsv, 'V',  -1.) 
    677          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zmU_t, 'U', -1., zmV_t, 'V',  -1.) 
    678          CALL lbc_lnk_multi( 'icedyn_rhg_vp', ztaux_oi_rhsu, 'U', -1., ztauy_oi_rhsv, 'V',  -1.) 
     676         CALL lbc_lnk( 'icedyn_rhg_vp', zrhsu, 'U', -1., zrhsv, 'V',  -1.) 
     677         CALL lbc_lnk( 'icedyn_rhg_vp', zmU_t, 'U', -1., zmV_t, 'V',  -1.) 
     678         CALL lbc_lnk( 'icedyn_rhg_vp', ztaux_oi_rhsu, 'U', -1., ztauy_oi_rhsv, 'V',  -1.) 
    679679 
    680680         CALL iom_put( 'zmU_t'         , zmU_t          ) ! MV DEBUG 
    … …  
    779779         END DO 
    780780 
    781          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zAU  , 'U', 1., zAV  , 'V',  1. ) 
    782          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zBU  , 'U', 1., zBV  , 'V',  1. ) 
    783          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zCU  , 'U', 1., zCV  , 'V',  1. ) 
    784          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zDU  , 'U', 1., zDV  , 'V',  1. ) 
    785          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zEU  , 'U', 1., zEV  , 'V',  1. ) 
     781         CALL lbc_lnk( 'icedyn_rhg_vp', zAU  , 'U', 1., zAV  , 'V',  1. ) 
     782         CALL lbc_lnk( 'icedyn_rhg_vp', zBU  , 'U', 1., zBV  , 'V',  1. ) 
     783         CALL lbc_lnk( 'icedyn_rhg_vp', zCU  , 'U', 1., zCV  , 'V',  1. ) 
     784         CALL lbc_lnk( 'icedyn_rhg_vp', zDU  , 'U', 1., zDV  , 'V',  1. ) 
     785         CALL lbc_lnk( 'icedyn_rhg_vp', zEU  , 'U', 1., zEV  , 'V',  1. ) 
    786786                
    787787         CALL iom_put( 'zAU'           , zAU            ) ! MV DEBUG 
    … …  
    885885                     END DO 
    886886 
    887                      CALL lbc_lnk_multi( 'icedyn_rhg_vp', zFU_prime, 'U',  1., zBU_prime, 'U', 1. ) 
     887                     CALL lbc_lnk( 'icedyn_rhg_vp', zFU_prime, 'U',  1., zBU_prime, 'U', 1. ) 
    888888  
    889889                     !----------------------------- 
    … …  
    965965                     END DO 
    966966 
    967                      CALL lbc_lnk_multi( 'icedyn_rhg_vp', zFV, 'V',  1.) 
     967                     CALL lbc_lnk( 'icedyn_rhg_vp', zFV, 'V',  1.) 
    968968                      
    969969                     !--------------- 
    … …  
    983983                     END DO 
    984984 
    985                      CALL lbc_lnk_multi( 'icedyn_rhg_vp', zFV_prime, 'V',  1., zBV_prime, 'V', 1. ) 
     985                     CALL lbc_lnk( 'icedyn_rhg_vp', zFV_prime, 'V',  1., zBV_prime, 'V', 1. ) 
    986986                      
    987987                     !----------------------------- 
    … …  
    10201020               ENDIF !   ll_v_iterate 
    10211021 
    1022                CALL lbc_lnk_multi( 'icedyn_rhg_vp', u_ice, 'U', -1., v_ice, 'V', -1. ) 
     1022               CALL lbc_lnk( 'icedyn_rhg_vp', u_ice, 'U', -1., v_ice, 'V', -1. ) 
    10231023                               
    10241024               !-------------------------------------------------------------------------------------- 
    … …  
    11101110      IF ( lwp ) WRITE(numout,*) ' We are out of outer loop ' 
    11111111 
    1112       CALL lbc_lnk_multi( 'icedyn_rhg_vp', zFU  , 'U',  1., zFV  , 'V',  1. ) 
    1113       CALL lbc_lnk_multi( 'icedyn_rhg_vp', zBU_prime  , 'U',  1., zBV_prime  , 'V',  1. ) 
    1114       CALL lbc_lnk_multi( 'icedyn_rhg_vp', zFU_prime  , 'U',  1., zFV_prime  , 'V',  1. ) 
    1115       CALL lbc_lnk_multi( 'icedyn_rhg_vp', zCU_prime  , 'U',  1., zCV_prime  , 'V',  1. ) 
     1112      CALL lbc_lnk( 'icedyn_rhg_vp', zFU  , 'U',  1., zFV  , 'V',  1. ) 
     1113      CALL lbc_lnk( 'icedyn_rhg_vp', zBU_prime  , 'U',  1., zBV_prime  , 'V',  1. ) 
     1114      CALL lbc_lnk( 'icedyn_rhg_vp', zFU_prime  , 'U',  1., zFV_prime  , 'V',  1. ) 
     1115      CALL lbc_lnk( 'icedyn_rhg_vp', zCU_prime  , 'U',  1., zCV_prime  , 'V',  1. ) 
    11161116 
    11171117      CALL iom_put( 'zFU'           , zFU            ) ! MV DEBUG 
    … …  
    11251125      CALL iom_put( 'zFV_prime'     , zFV_prime      ) ! MV DEBUG 
    11261126 
    1127       CALL lbc_lnk_multi( 'icedyn_rhg_vp', u_ice, 'U', -1., v_ice, 'V', -1. ) 
     1127      CALL lbc_lnk( 'icedyn_rhg_vp', u_ice, 'U', -1., v_ice, 'V', -1. ) 
    11281128 
    11291129      IF ( lwp ) WRITE(numout,*) ' We are about to output uice_dbg ' 
    … …  
    11611161      END DO 
    11621162 
    1163       CALL lbc_lnk_multi( 'icedyn_rhg_vp', u_ice, 'U', -1., v_ice, 'V', -1. ) 
     1163      CALL lbc_lnk( 'icedyn_rhg_vp', u_ice, 'U', -1., v_ice, 'V', -1. ) 
    11641164 
    11651165      IF ( lwp ) WRITE(numout,*) ' Velocity replaced ' 
    … …  
    12221222      IF ( lwp ) WRITE(numout,*) ' Deformation recalculated ' 
    12231223       
    1224       CALL lbc_lnk_multi( 'icedyn_rhg_vp', pshear_i, 'T', 1., pdivu_i, 'T', 1., pdelta_i, 'T', 1. ) 
     1224      CALL lbc_lnk( 'icedyn_rhg_vp', pshear_i, 'T', 1., pdivu_i, 'T', 1., pdelta_i, 'T', 1. ) 
    12251225       
    12261226      !------------------------------------------------------------------------------! 
    … …  
    12491249         END DO 
    12501250 
    1251          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zs1, 'T', 1., zs2, 'T', 1., zs12, 'T', 1. ) 
     1251         CALL lbc_lnk( 'icedyn_rhg_vp', zs1, 'T', 1., zs2, 'T', 1., zs12, 'T', 1. ) 
    12521252       
    12531253      ENDIF 
    … …  
    13071307          
    13081308         ! 
    1309          CALL lbc_lnk_multi( 'icedyn_rhg_vp', ztaux_oi, 'U', -1., ztauy_oi, 'V', -1., ztaux_ai, 'U', -1., ztauy_ai, 'V', -1. ) !, & 
    1310 !            &                                 ztaux_bi, 'U', -1., ztauy_bi, 'V', -1. ) 
     1309         CALL lbc_lnk( 'icedyn_rhg_vp', ztaux_oi, 'U', -1., ztauy_oi, 'V', -1., ztaux_ai, 'U', -1., ztauy_ai, 'V', -1. ) !, & 
     1310!            &                           ztaux_bi, 'U', -1., ztauy_bi, 'V', -1. ) 
    13111311         ! 
    13121312         CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) 
    … …  
    13481348         END DO 
    13491349 
    1350          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zsig_I, 'T', 1., zsig_II, 'T', 1.) 
     1350         CALL lbc_lnk( 'icedyn_rhg_vp', zsig_I, 'T', 1., zsig_II, 'T', 1.) 
    13511351          
    13521352         IF( iom_use('normstr') )   CALL iom_put( 'normstr' ,   zsig_I(:,:)  * zmsk00(:,:) ) ! Normal stress 
    … …  
    13931393         IF ( lwp ) WRITE(numout,*) 'Some shitty stress work done' 
    13941394         ! 
    1395          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zsig1_p, 'T', 1., zsig2_p, 'T', 1.) 
     1395         CALL lbc_lnk( 'icedyn_rhg_vp', zsig1_p, 'T', 1., zsig2_p, 'T', 1.) 
    13961396         !       
    13971397         IF ( lwp ) WRITE(numout,*) ' Beauaaaarflblbllll ' 
    … …  
    14231423         END DO 
    14241424         ! 
    1425          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zspgU, 'U', -1., zspgV, 'V', -1., & 
    1426             &                                 zCorU, 'U', -1., zCorV, 'V', -1. ) 
     1425         CALL lbc_lnk( 'icedyn_rhg_vp', zspgU, 'U', -1., zspgV, 'V', -1., & 
     1426            &                           zCorU, 'U', -1., zCorV, 'V', -1. ) 
    14271427         ! 
    14281428         CALL iom_put( 'dssh_dx' , zspgU * zmsk00 )   ! Sea-surface tilt term in force balance (x) 
    … …  
    14531453         END DO 
    14541454             
    1455          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zfU, 'U', -1., zfV, 'V', -1. ) 
     1455         CALL lbc_lnk( 'icedyn_rhg_vp', zfU, 'U', -1., zfV, 'V', -1. ) 
    14561456          
    14571457         CALL iom_put( 'intstrx' , zfU   * zmsk00 )   ! Internal force term in force balance (x) 
    … …  
    14851485         END DO 
    14861486 
    1487          CALL lbc_lnk_multi( 'icedyn_rhg_vp', zdiag_xmtrp_ice, 'U', -1., zdiag_ymtrp_ice, 'V', -1., & 
    1488             &                                 zdiag_xmtrp_snw, 'U', -1., zdiag_ymtrp_snw, 'V', -1., & 
    1489             &                                 zdiag_xatrp    , 'U', -1., zdiag_yatrp    , 'V', -1. ) 
     1487         CALL lbc_lnk( 'icedyn_rhg_vp', zdiag_xmtrp_ice, 'U', -1., zdiag_ymtrp_ice, 'V', -1., & 
     1488            &                           zdiag_xmtrp_snw, 'U', -1., zdiag_ymtrp_snw, 'V', -1., & 
     1489            &                           zdiag_xatrp    , 'U', -1., zdiag_yatrp    , 'V', -1. ) 
    14901490 
    14911491         CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice )   ! X-component of sea-ice mass transport (kg/s) 

  • NEMO/trunk/src/ICE/icesbc.F90

    r14072 r14433  
    8787            vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 
    8888         END_2D 
    89          CALL lbc_lnk_multi( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp ) 
     89         CALL lbc_lnk( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp ) 
    9090      ENDIF 
    9191      ! 

  • NEMO/trunk/src/ICE/icethd.F90

    r14072 r14433  
    136136         END_2D 
    137137      ENDIF 
    138       CALL lbc_lnk_multi( 'icethd', zfric, 'T',  1.0_wp, zvel, 'T', 1.0_wp ) 
     138      CALL lbc_lnk( 'icethd', zfric, 'T',  1.0_wp, zvel, 'T', 1.0_wp ) 
    139139      ! 
    140140      !--------------------------------------------------------------------! 

  • NEMO/trunk/src/ICE/icethd_do.F90

    r13601 r14433  
    193193         END_2D 
    194194         !  
    195          CALL lbc_lnk_multi( 'icethd_do', zvrel, 'T', 1.0_wp, ht_i_new, 'T', 1.0_wp  ) 
     195         CALL lbc_lnk( 'icethd_do', zvrel, 'T', 1.0_wp, ht_i_new, 'T', 1.0_wp  ) 
    196196 
    197197      ENDIF 

  • NEMO/trunk/src/ICE/iceupdate.F90

    r14072 r14433  
    345345            tmod_io(ji,jj) = zrhoco * SQRT( zmodt )          ! rhoco * |U_ice-U_oce| at T-point 
    346346         END_2D 
    347          CALL lbc_lnk_multi( 'iceupdate', taum, 'T', 1.0_wp, tmod_io, 'T', 1.0_wp ) 
     347         CALL lbc_lnk( 'iceupdate', taum, 'T', 1.0_wp, tmod_io, 'T', 1.0_wp ) 
    348348         ! 
    349349         utau_oce(:,:) = utau(:,:)                    !* save the air-ocean stresses at ice time-step 
    … …  
    374374         vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice 
    375375      END_2D 
    376       CALL lbc_lnk_multi( 'iceupdate', utau, 'U', -1.0_wp, vtau, 'V', -1.0_wp )   ! lateral boundary condition 
     376      CALL lbc_lnk( 'iceupdate', utau, 'U', -1.0_wp, vtau, 'V', -1.0_wp )   ! lateral boundary condition 
    377377      ! 
    378378      IF( ln_timing )   CALL timing_stop('ice_update') 

  • NEMO/trunk/src/NST/agrif_oce_interp.F90

    r14227 r14433  
    109109      vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:)  
    110110 
    111       CALL lbc_lnk_multi( 'agrif_istate_oce', uu(:,:,:  ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp ) 
     111      CALL lbc_lnk( 'agrif_istate_oce', uu(:,:,:  ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp ) 
    112112      CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T',  1.0_wp ) 
    113113 

  • NEMO/trunk/src/NST/agrif_oce_sponge.F90

    r14227 r14433  
    236236      END_2D 
    237237       
    238       CALL lbc_lnk_multi( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp, fspt, 'T', 1._wp, fspf, 'F', 1._wp ) 
     238      CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp, fspt, 'T', 1._wp, fspf, 'F', 1._wp ) 
    239239      ! 
    240240      ! Remove vertical interpolation where not needed: 
    … …  
    368368         fspf_2d(ji,jj) = ztabramp(ji,jj) * ssvmask(ji,jj) * ssvmask(ji,jj+1) 
    369369         END_2D 
    370       CALL lbc_lnk_multi( 'agrif_Sponge_2d', fspu_2d, 'U', 1._wp, fspv_2d, 'V', 1._wp, fspt_2d, 'T', 1._wp, fspf_2d, 'F', 1._wp ) 
     370      CALL lbc_lnk( 'agrif_Sponge_2d', fspu_2d, 'U', 1._wp, fspv_2d, 'V', 1._wp, fspt_2d, 'T', 1._wp, fspf_2d, 'F', 1._wp ) 
    371371      ! 
    372372#endif 

  • NEMO/trunk/src/NST/agrif_user.F90

    r14229 r14433  
    6363! In case of East-West periodicity, prevent AGRIF interpolation at east and west boundaries 
    6464! The procnames will not be called at these boundaries 
    65       IF (jperio == 1) THEN 
     65      IF (l_Iperio) THEN 
    6666         CALL Agrif_Set_NearCommonBorderX(.TRUE.) 
    6767         CALL Agrif_Set_DistantCommonBorderX(.TRUE.) 
    … …  
    209209      ENDIF 
    210210      ! 
    211       CALL lbc_lnk_multi( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp, hv0_parent, 'V', 1.0_wp ) 
     211      CALL lbc_lnk( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp, hv0_parent, 'V', 1.0_wp ) 
    212212      DO_2D( 0, 0, 0, 0 ) 
    213213         zk(ji,jj) = REAL( mbku_parent(ji,jj), wp ) 
    … …  
    251251         ENDIF 
    252252 
    253          CALL lbc_lnk_multi( 'Agrif_Init_Domain', e3u0_parent, 'U', 1.0_wp, e3v0_parent, 'V', 1.0_wp ) 
     253         CALL lbc_lnk( 'Agrif_Init_Domain', e3u0_parent, 'U', 1.0_wp, e3v0_parent, 'V', 1.0_wp ) 
    254254      ENDIF 
    255255 
    … …  
    872872      nbghostcells_y_n = nbghostcells 
    873873      ! 
    874       IF(   jperio == 1  )   nbghostcells_x   = 0 
     874      IF(    l_Iperio    )   nbghostcells_x   = 0 
    875875      IF( .NOT. lk_south )   nbghostcells_y_s = 0 
    876876      IF( .NOT. lk_north )   nbghostcells_y_n = 0 

  • 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