Changeset 14448
- Timestamp:
- 2021-02-12T09:57:09+01:00 (3 years ago)
- Location:
- NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO
- Files:
-
- 5 deleted
- 167 edited
- 3 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/INSTALL.rst
r14239 r14448 5 5 .. todo:: 6 6 7 7 TBD 8 8 9 9 .. contents:: … … 122 122 .. code:: console 123 123 124 $ svn co https://forge.ipsl.jussieu.fr/nemo/svn/NEMO/ releases/r4.0/r4.0.4124 $ svn co https://forge.ipsl.jussieu.fr/nemo/svn/NEMO/trunk 125 125 126 126 Description of 1\ :sup:`st` level tree structure -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/README.rst
r14113 r14448 62 62 |NEMO-OCE| |DOI man OCE|_ |DOI qsg| 63 63 |NEMO-ICE| |DOI man ICE| 64 |NEMO- TOP| |DOI man TOP|64 |NEMO-MBG| |DOI man MBG| 65 65 ============ ================== =================== 66 66 -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/cfgs/C1D_PAPA/MY_SRC/usrdef_nam.F90
r12377 r14448 39 39 CONTAINS 40 40 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 ) 42 42 !!---------------------------------------------------------------------- 43 43 !! *** ROUTINE dom_nam *** … … 51 51 !! ** input : - namusr_def namelist found in namelist_cfg 52 52 !!---------------------------------------------------------------------- 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 57 59 ! 58 60 INTEGER :: ios ! Local integer … … 74 76 kpk = 75 75 77 ! ! 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 = '-' 77 80 ! 78 81 ! ! control print … … 90 93 WRITE(numout,*) ' jpjglo = ', kpj 91 94 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,*) ' ' 94 96 ENDIF 95 97 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/cfgs/README.rst
r11743 r14448 240 240 The vertical eddy viscosity and diffusivity coefficients are increased to 1 m\ :sup:`2`/s in 241 241 case of static instability. 242 :time step: is 5 760sec (1h36') so that there is 15time steps in one day.242 :time step: is 5400sec (1h30') so that there is 16 time steps in one day. 243 243 244 244 ORCA2_OFF_PISCES -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/cfgs/SHARED/namelist_ref
r14416 r14448 644 644 rn_test_box = 108.0, 116.0, -66.0, -58.0 645 645 ln_use_calving = .false. ! Use calving data even when nn_test_icebergs > 0 646 rn_speed_limit = 0. ! CFL speed limit for a berg 646 rn_speed_limit = 0. ! CFL speed limit for a berg (safe value is 0.4, see #2581) 647 647 ! 648 648 ln_M2016 = .false. ! use Merino et al. (2016) modification (use of 3d ocean data instead of only sea surface data) … … 1498 1498 jpnj = 0 ! number of processors following j (set automatically if < 1), see also ln_listonly = T 1499 1499 nn_hls = 1 ! halo width (applies to both rows and columns) 1500 nn_comm = 1 ! comm choice 1500 1501 / 1501 1502 !----------------------------------------------------------------------- -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/doc/NEMO_manual_state.txt
r13461 r14448 15 15 chap_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} 16 16 chap_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{jp erio} 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{jp erio} 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}17 chap_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} 18 chap_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} 19 19 chap_conservation.tex: key{\_} 20 20 annex_iso.tex: key{trabbl} key{traldf\_eiv} np{ln\_traldf\_eiv} np{ln\_traldf\_gdia} -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/doc/latex/NEMO/subfiles/chap_DOM.tex
r14257 r14448 377 377 in which case \np{cn_cfg}{cn\_cfg} and \np{nn_cfg}{nn\_cfg} are set from these values accordingly). 378 378 379 The global lateral boundary condition type is selected from 8 options using parameter \texttt{jperio}.379 The 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}. 380 380 See \autoref{sec:LBC_jperio} for details on the available options and 381 the corresponding values for \texttt{ jperio}.381 the corresponding values for \texttt{l\_Iperio}, \texttt{l\_Jperio}, \texttt{l\_NFold} and \texttt{c\_NFtype}. 382 382 383 383 %% ================================================================================================= … … 394 394 395 395 \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 */ 396 integer Ni0glo, NjOglo, jpkglo /* global domain sizes (without MPI halos) */ 397 logical l\_Iperio, l\_Jperio /* lateral global domain b.c.: i- j-periodicity */ 398 logical l\_NFold /* lateral global domain b.c.: North Pole folding */ 399 char(1) c\_NFtype /* type of North pole Folding: T or F point */ 400 real glamt, glamu, glamv, glamf /* geographic longitude (t,u,v and f points respectively) */ 401 real gphit, gphiu, gphiv, gphif /* geographic latitude */ 402 real e1t, e1u, e1v, e1f /* horizontal scale factors */ 403 real e2t, e2u, e2v, e2f /* horizontal scale factors */ 402 404 \end{clines} 403 405 -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/doc/latex/NEMO/subfiles/chap_LBC.tex
r14257 r14448 159 159 160 160 %% ================================================================================================= 161 \section{Model domain boundary condition (\forcode{jperio})}161 \section{Model domain boundary condition} 162 162 \label{sec:LBC_jperio} 163 163 … … 168 168 169 169 %% ================================================================================================= 170 \subsection{Closed, cyclic (\forcode{ jperio={0,1,2,7}})}170 \subsection{Closed, cyclic (\forcode{l\_Iperio,l\_jperio})} 171 171 \label{subsec:LBC_jperio012} 172 172 173 173 The choice of closed or cyclic model domain boundary condition is made by 174 setting \forcode{ jperio} to 0, 1, 2 or 7in namelist \nam{cfg}{cfg}.174 setting \forcode{l\_Iperio,l\_jperio} to true or false in namelist \nam{cfg}{cfg}. 175 175 Each time such a boundary condition is needed, it is set by a call to routine \mdl{lbclnk}. 176 176 The computation of momentum and tracer trends proceeds from $i=2$ to $i=jpi-1$ and from $j=2$ to $j=jpj-1$, … … 181 181 \begin{description} 182 182 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: 184 184 first and last rows and columns are set to zero. 185 185 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 to186 \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 187 187 the value of the last-but-one column and the last column to the value of the second one 188 188 (\autoref{fig:LBC_jperio}-a). 189 189 Whatever flows out of the eastern (western) end of the basin enters the western (eastern) end. 190 190 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 to191 \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 192 192 the value of the last-but-one row and the last row to the value of the second one 193 193 (\autoref{fig:LBC_jperio}-a). 194 194 Whatever flows out of the northern (southern) end of the basin enters the southern (northern) end. 195 195 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. 197 197 198 198 \end{description} … … 207 207 208 208 %% ================================================================================================= 209 \subsection{North-fold (\forcode{ jperio={3,6}})}209 \subsection{North-fold (\forcode{l\_NFold = .true.})} 210 210 \label{subsec:LBC_north_fold} 211 211 … … 220 220 \includegraphics[width=0.66\textwidth]{LBC_North_Fold_T} 221 221 \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'$), 223 223 as used in ORCA 2\deg, 1/4\deg and 1/12\deg. 224 224 Pink shaded area corresponds to the inner domain mask (see text).} -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/doc/rst/source/conf.py
r14359 r14448 43 43 # General information about the project. 44 44 project = u'NEMO' 45 copyright = u'20 19, NEMO Consortium'45 copyright = u'2020, NEMO Consortium' 46 46 47 47 # The version info for the project you're documenting, acts as replacement for … … 50 50 # 51 51 # The short X.Y version. 52 version = 'tr k'52 version = 'trunk' 53 53 # The full version, including alpha/beta/rc tags. 54 54 release = 'trunk' -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/doc/rst/source/guide.rst
r13244 r14448 16 16 .. toctree:: 17 17 :hidden: 18 .. todos:: 18 19 todos 19 20 20 21 .. Only displayed with 'make drafthtml' -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ABL/ablmod.F90
r14239 r14448 534 534 ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 535 535 ! 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... 538 538 ! 539 539 #if defined key_xios … … 600 600 END_2D 601 601 ! 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 ) 603 603 ! 604 604 ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) … … 625 625 END_2D 626 626 ! 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 ) 628 628 629 629 CALL iom_put( "taum_oce", ptaum ) … … 645 645 & * ( 0.5_wp * ( v_abl(ji,jj+1,2,nt_a) + v_abl(ji,jj,2,nt_a) ) - pssv_ice(ji,jj) ) 646 646 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 ) 648 648 ! 649 649 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=ptaui_ice , clinfo1=' abl_stp: putaui : ' & … … 664 664 & * ( zztmp2 - pssv_ice(ji,jj) ) 665 665 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 ) 667 667 ! 668 668 IF(sn_cfctl%l_prtctl) THEN -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icecor.F90
r13641 r14448 116 116 ENDIF 117 117 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 ) 119 119 ENDIF 120 120 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icedyn_adv_pra.F90
r14215 r14448 115 115 CALL icemax3D( ph_ip, zhip_max) 116 116 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 ) 118 118 ! 119 119 ! enthalpies … … 265 265 ! --- Lateral boundary conditions --- ! 266 266 ! 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 volume268 & 269 & 270 & 271 CALL lbc_lnk _multi( 'icedyn_adv_pra', z0smi , 'T', 1._wp, sxsal , 'T', -1._wp, sysal , 'T', -1._wp & ! ice salinity272 & 273 & 274 & 275 CALL lbc_lnk _multi( 'icedyn_adv_pra', z0oi , 'T', 1._wp, sxage , 'T', -1._wp, syage , 'T', -1._wp & ! ice age276 & 277 CALL lbc_lnk _multi( 'icedyn_adv_pra', z0es , 'T', 1._wp, sxc0 , 'T', -1._wp, syc0 , 'T', -1._wp & ! snw enthalpy278 & 279 CALL lbc_lnk _multi( 'icedyn_adv_pra', z0ei , 'T', 1._wp, sxe , 'T', -1._wp, sye , 'T', -1._wp & ! ice enthalpy280 & 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 ) 281 281 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 fraction283 & 284 & 285 & 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 ) 286 286 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 volume288 & 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 ) 289 289 ENDIF 290 290 ENDIF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icedyn_adv_umx.F90
r14215 r14448 119 119 CALL icemax3D( ph_ip, zhip_max) 120 120 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 ) 122 122 ! 123 123 ! enthalpies … … 360 360 ! --- Lateral boundary conditions --- ! 361 361 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 & 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 ) 364 364 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 & 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 ) 367 367 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 ) 369 369 ENDIF 370 370 CALL lbc_lnk( 'icedyn_adv_umx', pe_i, 'T', 1._wp ) … … 1169 1169 END_2D 1170 1170 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 ) 1172 1172 1173 1173 DO jl = 1, jpl … … 1191 1191 END_2D 1192 1192 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. 1194 1194 1195 1195 ENDIF … … 1248 1248 END_2D 1249 1249 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) 1251 1251 1252 1252 -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icedyn_rhg_eap.F90
r14120 r14448 350 350 351 351 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 ) 353 353 ! 354 354 ! !== Landfast ice parameterization ==! … … 488 488 zs2(ji,jj) = ( zs2(ji,jj) * zalph1 + zstressmtmp ) * z1_alph1 489 489 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) 491 491 492 492 ! Save beta at T-points for further computations … … 516 516 517 517 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 ) 519 519 520 520 ! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- ! … … 810 810 811 811 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 & 814 & 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 ) 815 815 816 816 ! --- Store the stress tensor for the next time step --- ! … … 827 827 & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN 828 828 ! 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 & 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 ) 831 831 ! 832 832 CALL iom_put( 'utau_oi' , ztaux_oi * aimsk00 ) … … 912 912 IF( iom_use('yield11') .OR. iom_use('yield12') .OR. iom_use('yield22')) THEN 913 913 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 ) 915 915 916 916 CALL iom_put( 'yield11', zyield11 * aimsk00 ) … … 929 929 & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN 930 930 ! 931 CALL lbc_lnk _multi( 'icedyn_rhg_eap', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, &932 & 933 & 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 ) 934 934 935 935 CALL iom_put( 'dssh_dx' , zspgU * aimsk00 ) ! Sea-surface tilt term in force balance (x) … … 963 963 END_2D 964 964 965 CALL lbc_lnk _multi( 'icedyn_rhg_eap', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, &966 & 967 & 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 ) 968 968 969 969 CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icedyn_rhg_evp.F90
r14072 r14448 316 316 317 317 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 ) 319 319 ! 320 320 ! !== Landfast ice parameterization ==! … … 750 750 751 751 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 & 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 ) 754 754 755 755 ! --- Store the stress tensor for the next time step --- ! … … 766 766 & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN 767 767 ! 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 ) 770 771 ! 771 772 CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) … … 851 852 & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN 852 853 ! 853 CALL lbc_lnk _multi( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, &854 & 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 ) 855 856 856 857 CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x) … … 884 885 END_2D 885 886 886 CALL lbc_lnk _multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, &887 & 888 & 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 ) 889 890 890 891 CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icedyn_rhg_vp.F90
r14072 r14448 461 461 462 462 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 DEBUG463 CALL iom_put( 'zds' , zds ) ! MV DEBUG 464 464 465 465 IF( lwp ) WRITE(numout,*) ' outer loop 1a i_out : ', i_out … … 506 506 END DO 507 507 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. ) 509 509 510 510 CALL iom_put( 'zzt' , zzt ) ! MV DEBUG … … 527 527 528 528 CALL lbc_lnk( 'icedyn_rhg_vp', zef, 'F', 1. ) 529 CALL iom_put( 'zef' 529 CALL iom_put( 'zef' , zef ) ! MV DEBUG 530 530 IF( lwp ) WRITE(numout,*) ' outer loop 1c i_out : ', i_out 531 531 … … 567 567 IF( lwp ) WRITE(numout,*) ' outer loop 1d i_out : ', i_out 568 568 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. ) 571 571 572 572 CALL iom_put( 'zCwU' , zCwU ) ! MV DEBUG … … 674 674 END DO 675 675 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.) 679 679 680 680 CALL iom_put( 'zmU_t' , zmU_t ) ! MV DEBUG … … 779 779 END DO 780 780 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. ) 786 786 787 787 CALL iom_put( 'zAU' , zAU ) ! MV DEBUG … … 885 885 END DO 886 886 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. ) 888 888 889 889 !----------------------------- … … 965 965 END DO 966 966 967 CALL lbc_lnk _multi( 'icedyn_rhg_vp', zFV, 'V', 1.)967 CALL lbc_lnk( 'icedyn_rhg_vp', zFV, 'V', 1.) 968 968 969 969 !--------------- … … 983 983 END DO 984 984 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. ) 986 986 987 987 !----------------------------- … … 1020 1020 ENDIF ! ll_v_iterate 1021 1021 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. ) 1023 1023 1024 1024 !-------------------------------------------------------------------------------------- … … 1110 1110 IF ( lwp ) WRITE(numout,*) ' We are out of outer loop ' 1111 1111 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. ) 1116 1116 1117 1117 CALL iom_put( 'zFU' , zFU ) ! MV DEBUG … … 1125 1125 CALL iom_put( 'zFV_prime' , zFV_prime ) ! MV DEBUG 1126 1126 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. ) 1128 1128 1129 1129 IF ( lwp ) WRITE(numout,*) ' We are about to output uice_dbg ' … … 1161 1161 END DO 1162 1162 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. ) 1164 1164 1165 1165 IF ( lwp ) WRITE(numout,*) ' Velocity replaced ' … … 1222 1222 IF ( lwp ) WRITE(numout,*) ' Deformation recalculated ' 1223 1223 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. ) 1225 1225 1226 1226 !------------------------------------------------------------------------------! … … 1249 1249 END DO 1250 1250 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. ) 1252 1252 1253 1253 ENDIF … … 1307 1307 1308 1308 ! 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 ! & 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. ) 1311 1311 ! 1312 1312 CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) … … 1348 1348 END DO 1349 1349 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.) 1351 1351 1352 1352 IF( iom_use('normstr') ) CALL iom_put( 'normstr' , zsig_I(:,:) * zmsk00(:,:) ) ! Normal stress … … 1393 1393 IF ( lwp ) WRITE(numout,*) 'Some shitty stress work done' 1394 1394 ! 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.) 1396 1396 ! 1397 1397 IF ( lwp ) WRITE(numout,*) ' Beauaaaarflblbllll ' … … 1423 1423 END DO 1424 1424 ! 1425 CALL lbc_lnk _multi( 'icedyn_rhg_vp', zspgU, 'U', -1., zspgV, 'V', -1., &1426 & 1425 CALL lbc_lnk( 'icedyn_rhg_vp', zspgU, 'U', -1., zspgV, 'V', -1., & 1426 & zCorU, 'U', -1., zCorV, 'V', -1. ) 1427 1427 ! 1428 1428 CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x) … … 1453 1453 END DO 1454 1454 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. ) 1456 1456 1457 1457 CALL iom_put( 'intstrx' , zfU * zmsk00 ) ! Internal force term in force balance (x) … … 1485 1485 END DO 1486 1486 1487 CALL lbc_lnk _multi( 'icedyn_rhg_vp', zdiag_xmtrp_ice, 'U', -1., zdiag_ymtrp_ice, 'V', -1., &1488 & 1489 & 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. ) 1490 1490 1491 1491 CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icesbc.F90
r14072 r14448 87 87 vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 88 88 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 ) 90 90 ENDIF 91 91 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icethd.F90
r14072 r14448 136 136 END_2D 137 137 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 ) 139 139 ! 140 140 !--------------------------------------------------------------------! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/icethd_do.F90
r13601 r14448 193 193 END_2D 194 194 ! 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 ) 196 196 197 197 ENDIF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/ICE/iceupdate.F90
r14072 r14448 345 345 tmod_io(ji,jj) = zrhoco * SQRT( zmodt ) ! rhoco * |U_ice-U_oce| at T-point 346 346 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 ) 348 348 ! 349 349 utau_oce(:,:) = utau(:,:) !* save the air-ocean stresses at ice time-step … … 374 374 vtau(ji,jj) = ( 1._wp - zat_v ) * vtau_oce(ji,jj) + zat_v * zvtau_ice 375 375 END_2D 376 CALL lbc_lnk _multi( 'iceupdate', utau, 'U', -1.0_wp, vtau, 'V', -1.0_wp ) ! lateral boundary condition376 CALL lbc_lnk( 'iceupdate', utau, 'U', -1.0_wp, vtau, 'V', -1.0_wp ) ! lateral boundary condition 377 377 ! 378 378 IF( ln_timing ) CALL timing_stop('ice_update') -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/NST/agrif_oce_interp.F90
r14227 r14448 109 109 vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:) 110 110 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 ) 112 112 CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T', 1.0_wp ) 113 113 -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/NST/agrif_oce_sponge.F90
r14227 r14448 236 236 END_2D 237 237 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 ) 239 239 ! 240 240 ! Remove vertical interpolation where not needed: … … 368 368 fspf_2d(ji,jj) = ztabramp(ji,jj) * ssvmask(ji,jj) * ssvmask(ji,jj+1) 369 369 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 ) 371 371 ! 372 372 #endif -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/NST/agrif_user.F90
r14229 r14448 63 63 ! In case of East-West periodicity, prevent AGRIF interpolation at east and west boundaries 64 64 ! The procnames will not be called at these boundaries 65 IF ( jperio == 1) THEN65 IF (l_Iperio) THEN 66 66 CALL Agrif_Set_NearCommonBorderX(.TRUE.) 67 67 CALL Agrif_Set_DistantCommonBorderX(.TRUE.) … … 209 209 ENDIF 210 210 ! 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 ) 212 212 DO_2D( 0, 0, 0, 0 ) 213 213 zk(ji,jj) = REAL( mbku_parent(ji,jj), wp ) … … 251 251 ENDIF 252 252 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 ) 254 254 ENDIF 255 255 … … 872 872 nbghostcells_y_n = nbghostcells 873 873 ! 874 IF( jperio == 1) nbghostcells_x = 0874 IF( l_Iperio ) nbghostcells_x = 0 875 875 IF( .NOT. lk_south ) nbghostcells_y_s = 0 876 876 IF( .NOT. lk_north ) nbghostcells_y_n = 0 -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/NST/vremap.F90
r14092 r14448 1 # undefPPR_LIB /* USE PPR library */1 #define PPR_LIB /* USE PPR library */ 2 2 MODULE vremap 3 3 !$AGRIF_DO_NOT_TREAT -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/BDY/bdydyn2d.F90
r13226 r14448 18 18 USE bdylib ! BDY library routines 19 19 USE phycst ! physical constants 20 USE lib_mpp, ONLY: jpfillnothing 20 21 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 21 22 USE wet_dry ! Use wet dry to get reference ssh level -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/BDY/bdydyn3d.F90
r13226 r14448 15 15 USE bdy_oce ! ocean open boundary conditions 16 16 USE bdylib ! for orlanski library routines 17 USE lib_mpp, ONLY: jpfillnothing 17 18 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 18 19 USE in_out_manager ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/BDY/bdyice.F90
r13601 r14448 92 92 IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction 93 93 ! 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 & 96 & 97 & 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 ) 98 98 ! 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 ) 101 101 END IF 102 102 END DO ! ir -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/BDY/bdyini.F90
r13541 r14448 166 166 ! Check and write out namelist parameters 167 167 ! ----------------------------------------- 168 IF( jperio /= 0 ) CALL ctl_stop( 'bdy_segs: Cyclic or symmetric,', & 169 & ' and general open boundary condition are not compatible' ) 170 168 171 169 IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy 172 170 … … 575 573 ! check if point has to be sent to a neighbour 576 574 ! 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. 578 576 ! 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. 580 578 ! 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. 582 580 ! 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. 584 582 ! 585 583 ! check if point has to be received from a neighbour 586 584 ! 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. 588 586 ! 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. 590 588 ! 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. 592 590 ! 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. 594 592 ! 595 593 END DO … … 654 652 END DO 655 653 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. 657 655 658 656 ! bdy masks are now set to zero on rim 0 points: … … 739 737 ! <-- (o exterior) --> 740 738 ! (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. 746 744 ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo 747 745 ! :¨¨¨¨¨|¨¨--> | | <--¨¨|¨¨¨¨¨: 748 746 ! : | x:o | neighbour limited by ... would need o | o:x | : 749 747 ! :.....|_._:_____| (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. 756 754 ! 757 755 ! search neighbour in the north/south direction … … 760 758 ! | |___x___| OR | | x | 761 759 ! 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. 766 764 ! Check if neighbour has its rim parallel to its mpi subdomain _________ border and next to its halo 767 765 ! ^ | o | : : 768 766 ! | |¨¨¨¨x¨¨¨¨| neighbour limited by ... would need o | |....x....| 769 767 ! :_________: (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. 776 774 END DO 777 775 END DO -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/BDY/bdytra.F90
r14072 r14448 18 18 ! 19 19 USE in_out_manager ! I/O manager 20 USE lib_mpp, ONLY: jpfillnothing 20 21 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 21 22 USE lib_mpp, ONLY: ctl_stop -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/CRS/crs.F90
r13286 r14448 32 32 INTEGER :: jpi_crsm1, jpj_crsm1 !: loop indices 33 33 INTEGER :: jpiglo_crsm1, jpjglo_crsm1 !: loop indices 34 INTEGER :: nperio_full, nperio_crs !: jperio of parent and coarse grids35 INTEGER :: npolj_full, npolj_crs !: north fold mark34 !!$ INTEGER :: nperio_full, nperio_crs !: jperio of parent and coarse grids 35 !!$ INTEGER :: npolj_full, npolj_crs !: north fold mark 36 36 INTEGER :: jpiglo_full, jpjglo_full !: jpiglo / jpjglo 37 37 INTEGER :: npiglo, npjglo !: jpjglo … … 46 46 INTEGER :: nimpp_full, njmpp_full !: global position of point (1,1) of subdomain on parent grid 47 47 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 69 49 INTEGER, DIMENSION(:), ALLOCATABLE :: mis_crs, mie_crs, mis2_crs, mie2_crs ! starting and ending i-indices of parent subset 70 50 INTEGER, DIMENSION(:), ALLOCATABLE :: mjs_crs, mje_crs, mjs2_crs, mje2_crs ! starting and ending j-indices of parent subset … … 72 52 INTEGER, DIMENSION(:), ALLOCATABLE :: mi0_crs, mi1_crs, mj0_crs, mj1_crs 73 53 INTEGER :: mxbinctr, mybinctr ! central point in grid box 74 INTEGER, DIMENSION(:), ALLOCATABLE :: jpiall_crs, jpiall_full !: dimensions of every subdomain75 INTEGER, DIMENSION(:), ALLOCATABLE :: nis0all_crs, nis0all_full !: first, last indoor index for each i-domain76 INTEGER, DIMENSION(:), ALLOCATABLE :: nie0all_crs, nie0all_full !: first, last indoor index for each j-domain77 INTEGER, DIMENSION(:), ALLOCATABLE :: nimppt_crs, nimppt_full !: first, last indoor index for each j-domain78 INTEGER, DIMENSION(:), ALLOCATABLE :: jpjall_crs, jpjall_full !: dimensions of every subdomain79 INTEGER, DIMENSION(:), ALLOCATABLE :: njs0all_crs, njs0all_full !: first, last indoor index for each i-domain80 INTEGER, DIMENSION(:), ALLOCATABLE :: nje0all_crs, nje0all_full !: first, last indoor index for each j-domain81 INTEGER, DIMENSION(:), ALLOCATABLE :: njmppt_crs, njmppt_full !: first, last indoor index for each j-domain54 !!$ 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 82 62 83 63 … … 231 211 & hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) ) 232 212 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) ) 237 217 238 218 crs_dom_alloc = MAXVAL(ierr) … … 269 249 jpim1 = jpim1_full 270 250 jpjm1 = jpjm1_full 271 jperio = nperio_full272 273 npolj = npolj_full251 !!$ jperio = nperio_full 252 253 !!$ npolj = npolj_full 274 254 jpiglo = jpiglo_full 275 255 jpjglo = jpjglo_full … … 284 264 njmpp = njmpp_full 285 265 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 (:) 294 274 295 275 END SUBROUTINE dom_grid_glo … … 308 288 jpim1 = jpi_crsm1 309 289 jpjm1 = jpj_crsm1 310 jperio = nperio_crs311 312 npolj = npolj_crs290 !!$ jperio = nperio_crs 291 292 !!$ npolj = npolj_crs 313 293 jpiglo = jpiglo_crs 314 294 jpjglo = jpjglo_crs … … 324 304 njmpp = njmpp_crs 325 305 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 (:) 334 314 ! 335 315 END SUBROUTINE dom_grid_crs -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/CRS/crsdom.F90
r14275 r14448 30 30 !! Original. May 2012. (J. Simeon, C. Calone, G. Madec, C. Ethe) 31 31 !!=================================================================== 32 USE dom_oce ! ocean space and time domain and to get jperio32 USE dom_oce ! ocean space and time domain 33 33 USE crs ! domain for coarse grid 34 34 ! … … 1877 1877 1878 1878 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 points1880 jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 21881 ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj1882 ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 31883 jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 31884 jpiglo_crsm1 = jpiglo_crs - 11885 jpjglo_crsm1 = jpjglo_crs - 11886 1887 jpi_crs = ( jpiglo_crs - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls1888 jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls1889 1890 IF( noso < 0 ) jpj_crs = jpj_crs + 1 ! add a local band on southern processors1891 1892 jpi_crsm1 = jpi_crs - 11893 jpj_crsm1 = jpj_crs - 11894 nperio_crs = jperio1895 npolj_crs = npolj1896 1897 ierr = crs_dom_alloc() ! allocate most coarse grid arrays1898 1899 ! 2.a Define processor domain1900 IF( .NOT. lk_mpp ) THEN1901 nimpp_crs = 11902 njmpp_crs = 11903 Nis0_crs = 11904 Njs0_crs = 11905 Nie0_crs = jpi_crs1906 Nje0_crs = jpj_crs1907 ELSE1908 ! Initialisation of most local variables -1909 nimpp_crs = 11910 njmpp_crs = 11911 Nis0_crs = 11912 Njs0_crs = 11913 Nie0_crs = jpi_crs1914 Nje0_crs = jpj_crs1915 1916 ! Calculs suivant une découpage en j1917 DO jn = 1, jpnij, jpni1918 IF( jn < ( jpnij - jpni + 1 ) ) THEN1919 nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) &1920 & - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) )1921 ELSE1922 nje0all_crs(jn) = AINT( REAL( nje0all(jn) / nn_facty, wp ) ) + 11923 ENDIF1924 IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 11925 SELECT CASE( ibonjt(jn) )1926 CASE ( -1 )1927 IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 11928 jpjall_crs (jn) = nje0all_crs(jn) + nn_hls1929 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) + 11935 nje0all_crs(jn) = nje0all_crs(jn) + nn_hls1936 jpjall_crs (jn) = nje0all_crs(jn) + nn_hls1937 1938 CASE ( 1, 2 )1939 1940 nje0all_crs(jn) = nje0all_crs(jn) + nn_hls1941 jpjall_crs (jn) = nje0all_crs(jn)1942 njs0all_crs(jn) = njs0all(jn)1943 1944 CASE DEFAULT1945 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' )1946 END SELECT1947 IF( jpjall_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 11948 1949 IF(njs0all_crs(jn) == 1 ) THEN1950 njmppt_crs(jn) = 11951 ELSE1952 njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) )1953 ENDIF1954 1955 DO jj = jn + 1, jn + jpni - 11956 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 ENDDO1961 ENDDO1962 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 i1968 DO jn = 1, jpni1969 IF( jn == 1 ) THEN1970 nie0all_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + jpiall(jn ) ) / nn_factx, wp) )1971 ELSE1972 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 ENDIF1975 1976 SELECT CASE( ibonit(jn) )1977 CASE ( -1 )1978 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls1979 jpiall_crs (jn) = nie0all_crs(jn) + nn_hls1980 nis0all_crs(jn) = nis0all(jn)1981 1982 CASE ( 0 )1983 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls1984 jpiall_crs (jn) = nie0all_crs(jn) + nn_hls1985 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) + 11989 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls1990 jpiall_crs (jn) = nie0all_crs(jn)1991 nis0all_crs(jn) = nis0all(jn)1992 1993 CASE DEFAULT1994 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' )1995 END SELECT1996 1997 nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 11998 DO jj = jn + jpni , jpnij, jpni1999 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 ENDDO2004 ENDDO2005 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_crs2012 mig_crs(ji) = ji + nimpp_crs - 12013 ENDDO2014 DO jj = 1, jpj_crs2015 mjg_crs(jj) = jj + njmpp_crs - 1!2016 ENDDO2017 2018 DO ji = 1, jpiglo_crs2019 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 ENDDO2022 2023 DO jj = 1, jpjglo_crs2024 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 ENDDO2027 2028 ENDIF2029 2030 ! Save the parent grid information2031 jpi_full = jpi2032 jpj_full = jpj2033 jpim1_full = jpim12034 jpjm1_full = jpjm12035 nperio_full = jperio2036 2037 npolj_full = npolj2038 jpiglo_full = jpiglo2039 jpjglo_full = jpjglo2040 2041 jpj_full = jpj2042 jpi_full = jpi2043 Nis0_full = Nis02044 Njs0_full = Njs02045 Nie0_full = Nie02046 Nje0_full = Nje02047 nimpp_full = nimpp2048 njmpp_full = njmpp2049 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 (:) 2058 2058 2059 2059 CALL dom_grid_crs !swich de grille … … 2097 2097 IF ( nresty == 0 ) THEN 2098 2098 mybinctr = mybinctr - 1 2099 IF ( jperio == 3 .OR. jperio == 4 ) nperio_crs = jperio + 22100 IF ( jperio == 5 .OR. jperio == 6 ) nperio_crs = jperio - 22101 2102 IF ( npolj == 3 ) npolj_crs = 52103 IF ( npolj == 5 ) npolj_crs = 32099 !!$ 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 2104 2104 ENDIF 2105 2105 … … 2117 2117 CASE ( 0 ) 2118 2118 2119 SELECT CASE ( jperio )2120 2121 2122 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold2123 2124 DO ji = 2, jpiglo_crsm12125 ijie = ( ji * nn_factx ) - nn_factx !cc2126 ijis = ijie - nn_factx + 12127 mis2_crs(ji) = ijis2128 mie2_crs(ji) = ijie2129 ENDDO2130 IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 22131 2132 ! Handle first the northernmost bin2133 IF ( nn_facty == 2 ) THEN ; ijjgloT = jpjglo - 12134 ELSE ; ijjgloT = jpjglo2135 ENDIF2136 2137 DO jj = 2, jpjglo_crs2138 ijje = ijjgloT - nn_facty * ( jj - 3 )2139 ijjs = ijje - nn_facty + 12140 mjs2_crs(jpjglo_crs-jj+2) = ijjs2141 mje2_crs(jpjglo_crs-jj+2) = ijje2142 ENDDO2143 2144 CASE ( 2 )2145 WRITE(numout,*) 'crs_init, jperio=2 not supported'2146 2147 CASE ( 5, 6 ) ! F-pivot at North Fold2148 2149 DO ji = 2, jpiglo_crsm12150 ijie = ( ji * nn_factx ) - nn_factx2151 ijis = ijie - nn_factx + 12152 mis2_crs(ji) = ijis2153 mie2_crs(ji) = ijie2154 ENDDO2155 IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo - 22156 2157 ! Treat the northernmost bin separately.2158 jj = 22159 ijje = jpj - nn_facty * ( jj - 2 )2160 IF ( nn_facty == 3 ) THEN ; ijjs = ijje - 12161 ELSE ; ijjs = ijje - nn_facty + 12162 ENDIF2163 mjs2_crs(jpj_crs-jj+1) = ijjs2164 mje2_crs(jpj_crs-jj+1) = ijje2165 2166 ! Now bin the rest, any remainder at the south is lumped in the southern bin2167 DO jj = 3, jpjglo_crsm12168 ijje = jpjglo - nn_facty * ( jj - 2 )2169 ijjs = ijje - nn_facty + 12170 IF ( ijjs <= nn_facty ) ijjs = 22171 mjs2_crs(jpj_crs-jj+1) = ijjs2172 mje2_crs(jpj_crs-jj+1) = ijje2173 ENDDO2174 2175 CASE DEFAULT2176 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported'2177 2178 END SELECT2119 !!$ 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 2179 2179 2180 2180 CASE (1 ) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/CRS/crslbclnk.F90
r11536 r14448 50 50 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 51 51 ! 52 CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, kfillmode ,pfillval )52 CALL lbc_lnk( 'crslbclnk', pt3d1, cd_type1, psgn, kfillmode = kfillmode, pfillval = pfillval ) 53 53 ! 54 54 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain … … 80 80 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 81 81 ! 82 CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, kfillmode ,pfillval )82 CALL lbc_lnk( 'crslbclnk', pt2d, cd_type, psgn, kfillmode = kfillmode, pfillval = pfillval ) 83 83 ! 84 84 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DIA/diacfl.F90
r13497 r14448 61 61 IF( ln_timing ) CALL timing_start('dia_cfl') 62 62 ! 63 llmsk( 1:Nis1,:,:) = .FALSE.! exclude halos from the checked region64 llmsk(Nie 1:jpi,:,:) = .FALSE.65 llmsk(:, 1:Njs1,:) = .FALSE.66 llmsk(:,Nje 1: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. 67 67 ! 68 68 DO_3D( 0, 0, 0, 0, 1, jpk ) ! calculate Courant numbers -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DOM/dom_oce.F90
r14275 r14448 65 65 !! space domain parameters 66 66 !!---------------------------------------------------------------------- 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 75 70 76 71 ! Tiling namelist … … 85 80 86 81 ! !: 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... 103 85 104 86 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain, including halos (jpiglo), i-index … … 110 92 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global, including halos (jpjglo) ==> local domain j-index 111 93 ! !: (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 processor113 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence114 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: jpiall, jpjall !: dimensions of all subdomain115 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nis0all, njs0all !: first, last indoor index for all i-subdomain116 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nie0all, nje0all !: first, last indoor index for all j-subdomain117 94 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nfimpp, nfproc, nfjpi 118 95 -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DOM/domain.F90
r14255 r14448 113 113 WRITE(numout,*) ' jpnj : ', jpnj, ' nn_hls : ', nn_hls 114 114 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 128 120 WRITE(numout,*) ' Ocean model configuration used:' 129 WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg121 WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg 130 122 ENDIF 131 123 … … 622 614 623 615 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 ) 625 617 !!---------------------------------------------------------------------- 626 618 !! *** ROUTINE domain_cfg *** … … 630 622 !! ** Method : read the cn_domcfg NetCDF file 631 623 !!---------------------------------------------------------------------- 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 638 633 REAL(wp) :: zorca_res ! local scalars 639 634 REAL(wp) :: zperio ! - - … … 649 644 CALL iom_open( cn_domcfg, inum ) 650 645 ! 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 662 660 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 ! 676 664 idvar = iom_varid( inum, 'e3t_0', kdimsz = idimsz ) ! use e3t_0, that must exist, to get jp(ijk)glo 677 665 kpi = idimsz(1) 678 666 kpj = idimsz(2) 679 667 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 ! 681 690 CALL iom_close( inum ) 682 691 ! 683 692 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 685 697 WRITE(numout,*) ' Ni0glo = ', kpi 686 698 WRITE(numout,*) ' Nj0glo = ', kpj 687 699 WRITE(numout,*) ' jpkglo = ', kpk 688 WRITE(numout,*) ' type of global domain lateral boundary jperio = ', kperio689 700 ENDIF 690 701 ! … … 724 735 CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE. ) 725 736 ! 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 ) 731 741 ! 732 742 ! !== domain characteristics ==! 733 743 ! 734 744 ! ! 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 737 750 ! ! 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 742 755 ! ! 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/) ) ) 744 757 ! 745 758 ! !== horizontal mesh ! … … 794 807 CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 ) 795 808 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 ! ! ============================ ! 804 812 CALL iom_close( inum ) 805 813 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DOM/dommsk.F90
r14215 r14448 162 162 & * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk) 163 163 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 conditions164 CALL lbc_lnk( 'dommsk', umask, 'U', 1.0_wp, vmask, 'V', 1.0_wp, fmask, 'F', 1.0_wp ) ! Lateral boundary conditions 165 165 166 166 ! Ocean/land mask at wu-, wv- and w points (computed from tmask) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DOM/domqco.F90
r14179 r14448 170 170 ! 171 171 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 ) 173 173 ! 174 174 ! … … 194 194 #endif 195 195 ! ! 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 ) 197 197 ! 198 198 ENDIF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DOM/domvvl.F90
r14140 r14448 423 423 ! ! d - thickness diffusion transport: boundary conditions 424 424 ! (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) 426 426 ! 4 - Time stepping of baroclinic scale factors 427 427 ! --------------------------------------------- … … 436 436 END_3D 437 437 ! 438 llmsk( 1:Nis1,:,:) = .FALSE. ! exclude halos from the checked region439 llmsk(Nie 1:jpi,:,:) = .FALSE.440 llmsk(:, 1:Njs1,:) = .FALSE.441 llmsk(:,Nje 1: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. 442 442 ! 443 443 llmsk(Nis0:Nie0,Njs0:Nje0,:) = tmask(Nis0:Nie0,Njs0:Nje0,:) == 1._wp ! define only the inner domain -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DOM/domwri.F90
r13295 r14448 58 58 CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) 59 59 INTEGER :: ji, jj, jk ! dummy loop indices 60 INTEGER :: izco, izps, isco, icav61 !62 60 REAL(wp), DIMENSION(jpi,jpj) :: zprt, zprw ! 2D workspace 63 61 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepu, zdepv ! 3D workspace … … 74 72 ! ! ============================ 75 73 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 ) 78 82 ! ! 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' ) 85 86 ! ! 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/) ) ) 89 88 ! ! masks 90 89 CALL iom_rstput( 0, 0, inum, 'tmask', tmask, ktype = jp_i1 ) ! ! land-sea mask -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DOM/domzgr.F90
r13295 r14448 115 115 ! 116 116 zmsk(:,:) = 1._wp ! default: no closed boundaries 117 IF( jperio == 0 .OR. jperio == 2 .OR. jperio == 3 .OR. jperio == 5 ) THEN ! E-W closed117 IF( .NOT. l_Iperio ) THEN ! E-W closed: 118 118 zmsk( mi0( 1+nn_hls):mi1( 1+nn_hls),:) = 0._wp ! first column of inner global domain at 0 119 119 zmsk( mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls),:) = 0._wp ! last column of inner global domain at 0 120 120 ENDIF 121 IF( .NOT. ( jperio == 2 .OR. jperio == 7 ) ) THEN ! S closed121 IF( .NOT. l_Jperio ) THEN ! S closed: 122 122 zmsk(:,mj0( 1+nn_hls):mj1( 1+nn_hls) ) = 0._wp ! first line of inner global domain at 0 123 123 ENDIF 124 IF( jperio == 0 .OR. jperio == 1 ) THEN ! N closed124 IF( .NOT. ( l_Jperio .OR. l_NFold ) ) THEN ! N closed: 125 125 zmsk(:,mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls) ) = 0._wp ! last line of inner global domain at 0 126 126 ENDIF … … 225 225 ! 226 226 INTEGER :: jk ! dummy loop index 227 INTEGER :: inum ! local logical unit227 INTEGER :: inum, iatt 228 228 REAL(WP) :: z_zco, z_zps, z_sco, z_cav 229 229 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 230 CHARACTER(len=7) :: catt ! 'zco', 'zps, 'sco' or 'UNKNOWN' 230 231 !!---------------------------------------------------------------------- 231 232 ! … … 239 240 ! 240 241 ! !* 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. 248 246 ! !* 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 ------- 251 260 ! 252 261 ! !* vertical scale factors -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DYN/dynadv_ubs.F90
r13497 r14448 124 124 END_2D 125 125 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 ) 130 130 ! 131 131 ! ! ====================== ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DYN/dynatf.F90
r14224 r14448 169 169 # endif 170 170 ! 171 CALL lbc_lnk _multi( 'dynatf', puu(:,:,:,Kaa), 'U', -1.0_wp, pvv(:,:,:,Kaa), 'V', -1.0_wp ) !* local domain boundaries171 CALL lbc_lnk( 'dynatf', puu(:,:,:,Kaa), 'U', -1.0_wp, pvv(:,:,:,Kaa), 'V', -1.0_wp ) !* local domain boundaries 172 172 ! 173 173 ! !* BDY open boundaries -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DYN/dynhpg.F90
r14227 r14448 462 462 END IF 463 463 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 ) 465 465 END IF 466 466 ! … … 689 689 END IF 690 690 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 ) 692 692 END IF 693 693 … … 793 793 END_3D 794 794 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. ) 796 796 797 797 !------------------------------------------------------------------------- … … 1043 1043 ENDIF 1044 1044 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 ) 1046 1046 ENDIF 1047 1047 … … 1113 1113 END_2D 1114 1114 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 ) 1116 1116 1117 1117 DO_2D( 0, 0, 0, 0 ) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DYN/dynldf_iso.F90
r14215 r14448 135 135 END_3D 136 136 ! 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 ) 138 138 ! 139 139 ENDIF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DYN/dynldf_lap_blp.F90
r14053 r14448 185 185 CALL dyn_ldf_lap( kt, Kbb, Kmm, pu, pv, zulap, zvlap, 1 ) ! rotated laplacian applied to pt (output in zlap,Kbb) 186 186 ! 187 CALL lbc_lnk _multi( 'dynldf_lap_blp', zulap, 'U', -1.0_wp, zvlap, 'V', -1.0_wp ) ! Lateral boundary conditions187 CALL lbc_lnk( 'dynldf_lap_blp', zulap, 'U', -1.0_wp, zvlap, 'V', -1.0_wp ) ! Lateral boundary conditions 188 188 ! 189 189 CALL dyn_ldf_lap( kt, Kbb, Kmm, zulap, zvlap, pu_rhs, pv_rhs, 2 ) ! rotated laplacian applied to zlap (output in pt(:,:,:,:,Krhs)) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DYN/dynspg_ts.F90
r14225 r14448 524 524 END_2D 525 525 ! 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 ) 527 527 ! 528 528 ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) … … 677 677 ! 678 678 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 & 681 & 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 ) 682 682 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 ) 684 684 ENDIF 685 685 ! ! open boundaries … … 775 775 END_2D 776 776 #endif 777 CALL lbc_lnk _multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions777 CALL lbc_lnk( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions 778 778 ! 779 779 DO jk=1,jpkm1 -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DYN/dynvor.F90
r14233 r14448 940 940 dj_e1v_2(ji,jj) = ( e1v(ji,jj) - e1v(ji ,jj-1) ) * 0.5_wp 941 941 END_2D 942 CALL lbc_lnk _multi( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp ) ! Lateral boundary conditions942 CALL lbc_lnk( 'dynvor', di_e2u_2, 'T', -1.0_wp , dj_e1v_2, 'T', -1.0_wp ) ! Lateral boundary conditions 943 943 ! 944 944 CASE DEFAULT !* F-point metric term : pre-compute di(e2u)/(2*e1e2f) and dj(e1v)/(2*e1e2f) … … 948 948 dj_e1u_2e1e2f(ji,jj) = ( e1u(ji ,jj+1) - e1u(ji,jj) ) * 0.5 * r1_e1e2f(ji,jj) 949 949 END_2D 950 CALL lbc_lnk _multi( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp ) ! Lateral boundary conditions950 CALL lbc_lnk( 'dynvor', di_e2v_2e1e2f, 'F', -1.0_wp , dj_e1u_2e1e2f, 'F', -1.0_wp ) ! Lateral boundary conditions 951 951 END SELECT 952 952 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/DYN/wet_dry.F90
r13558 r14448 241 241 ENDIF 242 242 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 ) 244 244 ! 245 245 CALL mpp_max('wet_dry', jflag) !max over the global domain … … 257 257 ! 258 258 !!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 ) 261 261 !!gm 262 262 ! … … 366 366 END_2D 367 367 ! 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 ) 369 369 ! 370 370 CALL mpp_max('wet_dry', jflag) !max over the global domain … … 378 378 ! 379 379 !!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 ) 381 381 !!gm end 382 382 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ICB/icbdia.F90
r10570 r14448 86 86 INTEGER :: nbergs_start, nbergs_end, nbergs_calved 87 87 INTEGER :: nbergs_melted 88 INTEGER :: nspeeding_tickets 88 INTEGER :: nspeeding_tickets, nspeeding_tickets_all 89 89 INTEGER , DIMENSION(nclasses) :: nbergs_calved_by_class 90 90 … … 125 125 nbergs_calved_by_class(:) = 0 126 126 nspeeding_tickets = 0 127 nspeeding_tickets_all = 0 127 128 stored_heat_end = 0._wp 128 129 floating_heat_end = 0._wp … … 271 272 CALL mpp_sum( 'icbdia', nsumbuf(1:nclasses+4), nclasses+4 ) 272 273 ! 273 nbergs_end = nsumbuf(1)274 nbergs_calved = nsumbuf(2)275 nbergs_melted = nsumbuf(3)276 nspeeding_tickets = nsumbuf(4)274 nbergs_end = nsumbuf(1) 275 nbergs_calved = nsumbuf(2) 276 nbergs_melted = nsumbuf(3) 277 nspeeding_tickets_all = nsumbuf(4) 277 278 DO ik = 1,nclasses 278 279 nbergs_calved_by_class(ik)= nsumbuf(4+ik) … … 329 330 IF (nn_verbose_level > 0) THEN 330 331 WRITE( numicb, '("calved by class = ",i6,20(",",i6))') (nbergs_calved_by_class(ik),ik=1,nclasses) 331 IF( nspeeding_tickets > 0 ) WRITE( numicb, '("speeding tickets issued = ",i6)') nspeeding_tickets 332 IF( nspeeding_tickets_all > 0 ) THEN 333 WRITE( numicb, '("speeding tickets issued (this domain) = ",i6)') nspeeding_tickets 334 WRITE( numicb, '("speeding tickets issued (all domains) = ",i6)') nspeeding_tickets_all 335 END IF 332 336 ENDIF 333 337 ! … … 338 342 nbergs_calved_by_class(:) = 0 339 343 nspeeding_tickets = 0 344 nspeeding_tickets_all = 0 340 345 stored_heat_start = stored_heat_end 341 346 floating_heat_start = floating_heat_end -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ICB/icbdyn.F90
r14030 r14448 85 85 86 86 ! !** A1 = A(X1,V1) 87 CALL icb_accel( berg , zxi1, ze1, zuvel1, zuvel1, zax1, &88 & zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2 )87 CALL icb_accel( kt, berg , zxi1, ze1, zuvel1, zuvel1, zax1, & 88 & zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2, 0.5_wp ) 89 89 ! 90 90 zu1 = zuvel1 / ze1 !** V1 in d(i,j)/dt … … 102 102 103 103 ! !** A2 = A(X2,V2) 104 CALL icb_accel( berg , zxi2, ze1, zuvel2, zuvel1, zax2, &105 & zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2 )104 CALL icb_accel( kt, berg , zxi2, ze1, zuvel2, zuvel1, zax2, & 105 & zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2, 0.5_wp ) 106 106 ! 107 107 zu2 = zuvel2 / ze1 !** V2 in d(i,j)/dt … … 114 114 zyj3 = zyj1 + zdt_2 * zv2 ; zvvel3 = zvvel1 + zdt_2 * zay2 115 115 ! 116 CALL icb_ground( berg, zxi3, zxi1, zu 3, &117 & zyj3, zyj1, zv 3, ll_bounced )116 CALL icb_ground( berg, zxi3, zxi1, zu2, & 117 & zyj3, zyj1, zv2, ll_bounced ) 118 118 119 119 ! !** A3 = A(X3,V3) 120 CALL icb_accel( berg , zxi3, ze1, zuvel3, zuvel1, zax3, &121 & zyj3, ze2, zvvel3, zvvel1, zay3, zdt )120 CALL icb_accel( kt, berg , zxi3, ze1, zuvel3, zuvel1, zax3, & 121 & zyj3, ze2, zvvel3, zvvel1, zay3, zdt, 1._wp ) 122 122 ! 123 123 zu3 = zuvel3 / ze1 !** V3 in d(i,j)/dt … … 130 130 zyj4 = zyj1 + zdt * zv3 ; zvvel4 = zvvel1 + zdt * zay3 131 131 132 CALL icb_ground( berg, zxi4, zxi1, zu 4, &133 & zyj4, zyj1, zv 4, ll_bounced )132 CALL icb_ground( berg, zxi4, zxi1, zu3, & 133 & zyj4, zyj1, zv3, ll_bounced ) 134 134 135 135 ! !** A4 = A(X4,V4) 136 CALL icb_accel( berg , zxi4, ze1, zuvel4, zuvel1, zax4, &137 & zyj4, ze2, zvvel4, zvvel1, zay4, zdt )136 CALL icb_accel( kt, berg , zxi4, ze1, zuvel4, zuvel1, zax4, & 137 & zyj4, ze2, zvvel4, zvvel1, zay4, zdt, 1._wp ) 138 138 139 139 zu4 = zuvel4 / ze1 !** V4 in d(i,j)/dt … … 255 255 256 256 257 SUBROUTINE icb_accel( berg , pxi, pe1, puvel, puvel0, pax,&258 & pyj, pe2, pvvel, pvvel0, pay, pdt)257 SUBROUTINE icb_accel( kt, berg , pxi, pe1, puvel, puvel0, pax, & 258 & pyj, pe2, pvvel, pvvel0, pay, pdt, pcfl_scale ) 259 259 !!---------------------------------------------------------------------- 260 260 !! *** ROUTINE icb_accel *** … … 265 265 !!---------------------------------------------------------------------- 266 266 TYPE(iceberg ), POINTER, INTENT(in ) :: berg ! berg 267 INTEGER , INTENT(in ) :: kt ! time step 268 REAL(wp) , INTENT(in ) :: pcfl_scale 267 269 REAL(wp) , INTENT(in ) :: pxi , pyj ! berg position in (i,j) referential 268 270 REAL(wp) , INTENT(in ) :: puvel , pvvel ! berg velocity [m/s] … … 404 406 zspeed = SQRT( zuveln*zuveln + zvveln*zvveln ) ! Speed of berg 405 407 IF( zspeed > 0._wp ) THEN 406 zloc_dx = MIN( pe1, pe2 ) ! minimum grid spacing 407 zspeed_new = zloc_dx / pdt * rn_speed_limit ! Speed limit as a factor of dx / dt 408 zloc_dx = MIN( pe1, pe2 ) ! minimum grid spacing 409 ! cfl scale is function of the RK4 step 410 zspeed_new = zloc_dx / pdt * rn_speed_limit * pcfl_scale ! Speed limit as a factor of dx / dt 408 411 IF( zspeed_new < zspeed ) THEN 409 zuveln = zuveln * ( zspeed_new / zspeed ) ! Scale velocity to reduce speed 410 zvveln = zvveln * ( zspeed_new / zspeed ) ! without changing the direction 412 zuveln = zuveln * ( zspeed_new / zspeed ) ! Scale velocity to reduce speed 413 zvveln = zvveln * ( zspeed_new / zspeed ) ! without changing the direction 414 pax = (zuveln - puvel0)/pdt 415 pay = (zvveln - pvvel0)/pdt 416 ! 417 ! print speeding ticket 418 IF (nn_verbose_level > 0) THEN 419 WRITE(numicb, 9200) 'icb speeding : ',kt, nknberg, zspeed, & 420 & pxi, pyj, zuo, zvo, zua, zva, zui, zvi 421 9200 FORMAT(a,i9,i6,f9.2,1x,4(1x,2f9.2)) 422 END IF 423 ! 411 424 CALL icb_dia_speed() 412 425 ENDIF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ICB/icbini.F90
r14030 r14448 189 189 190 190 ! north fold 191 IF( npolj > 0) THEN191 IF( l_IdoNFold ) THEN 192 192 ! 193 193 ! icebergs in row nicbej+1 get passed across fold … … 235 235 WRITE(numicb,*) "j point" 236 236 WRITE(numicb,*) (INT(src_calving(ji,jj)), jj=1,jpj) 237 IF( npolj > 0) THEN237 IF( l_IdoNFold ) THEN 238 238 WRITE(numicb,*) 'north fold destination points ' 239 239 WRITE(numicb,*) nicbfldpts -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ICB/icblbc.F90
r14229 r14448 105 105 IF( l_Jperio) CALL ctl_stop(' north-south periodicity not implemented for icebergs') 106 106 ! north fold 107 IF( npolj /= 0) CALL icb_lbc_nfld()107 IF( l_IdoNFold ) CALL icb_lbc_nfld() 108 108 ! 109 109 END SUBROUTINE icb_lbc … … 179 179 ipe_W = -1 180 180 ipe_E = -1 181 IF( nbondi .EQ. 0 .OR. nbondi .EQ. 1) ipe_W = nowe182 IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea183 IF( nbondj .EQ. 0 .OR. nbondj .EQ. 1) ipe_S = noso184 IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono181 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) 185 185 ! 186 186 ! at northern line of processors with north fold handle bergs differently 187 IF( npolj > 0 )ipe_N = -1187 IF( l_IdoNFold ) ipe_N = -1 188 188 189 189 ! if there's only one processor in x direction then don't let mpp try to handle periodicity … … 200 200 WRITE(numicb,*) 'processor nimpp : ', nimpp 201 201 WRITE(numicb,*) 'processor njmpp : ', njmpp 202 WRITE(numicb,*) 'processor nbondi: ', nbondi203 WRITE(numicb,*) 'processor nbondj: ', nbondj204 202 CALL flush( numicb ) 205 203 ENDIF … … 271 269 ! pattern here is copied from lib_mpp code 272 270 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 298 282 IF( nn_verbose_level >= 3) THEN 299 283 WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e 300 284 CALL flush(numicb) 301 285 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 360 313 361 314 ! Find number of bergs that headed north/south … … 400 353 ! send bergs north 401 354 ! 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 491 399 IF( nn_verbose_level > 0 ) THEN 492 400 ! compare the number of icebergs on this processor from the start to the end … … 527 435 ! deal with north fold if we necessary when there is more than one top row processor 528 436 ! 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( ) 530 438 531 439 IF( nn_verbose_level > 0 ) THEN -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ICB/icbutl.F90
r14118 r14448 320 320 ! 321 321 IF ( ierr > 0 ) THEN 322 WRITE(numout,*) 'bottom left corner T point out of bound' 323 WRITE(numout,*) pi, kii, mig( 1 ), mig(jpi) 324 WRITE(numout,*) pj, kij, mjg( 1 ), mjg(jpj) 325 WRITE(numout,*) pmsk 326 CALL ctl_stop('STOP','icb_utl_bilin_h: an icebergs coordinates is out of valid range (out of bound error)') 322 WRITE(numicb,*) 'bottom left corner T point out of bound' 323 WRITE(numicb,*) pi, kii, mig( 1 ), mig(jpi) 324 WRITE(numicb,*) pj, kij, mjg( 1 ), mjg(jpj) 325 WRITE(numicb,*) pmsk 326 CALL FLUSH(numicb) 327 CALL ctl_stop('STOP','icb_utl_bilin_e: an icebergs coordinates is out of valid range (out of bound error).' , & 328 & 'This can be fixed using rn_speed_limit=0.4 in &namberg.' , & 329 & 'More details in the corresponding iceberg.stat file (nn_verbose_level > 0).' ) 327 330 END IF 328 331 END IF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/IOM/iom_nf90.F90
r14072 r14448 443 443 IF(PRESENT(cdatt0d)) CALL iom_nf90_check(NF90_GET_ATT(if90id, ivarid, cdatt, values = cdatt0d), clinfo) 444 444 ELSE 445 CALL ctl_warn('iom_nf90_getatt: no attribute '//TRIM(cdatt)//' found')446 445 IF(PRESENT( katt0d)) katt0d = -999 447 446 IF(PRESENT( katt1d)) katt1d(:) = -999 448 447 IF(PRESENT( patt0d)) patt0d = -999._wp 449 448 IF(PRESENT( patt1d)) patt1d(:) = -999._wp 450 IF(PRESENT(cdatt0d)) cdatt0d = ' !'449 IF(PRESENT(cdatt0d)) cdatt0d = 'UNKNOWN' 451 450 ENDIF 452 451 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ISF/isfcav.F90
r14072 r14448 136 136 ! 137 137 ! 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) 139 139 ! 140 140 ! output fluxes -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ISF/isfcpl.F90
r14143 r14448 205 205 zssmask0(:,:) = zssmask_b(:,:) 206 206 ! 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 ) 208 208 ! 209 209 END DO … … 363 363 ztmask0(:,:,:) = ztmask1(:,:,:) 364 364 ! 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) 366 366 ! 367 367 END DO ! nn_drown … … 691 691 ! 692 692 ! 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 & 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) 695 695 ! 696 696 ! ssh correction (for dynspg_ts) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ISF/isfpar.F90
r13226 r14448 82 82 ! 83 83 ! 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) 85 85 ! 86 86 ! output fluxes -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lbc_nfd_ext_generic.h90
r13286 r14448 1 ! !== IN: ptab is an array ==!2 #define NAT_IN(k) cd_nat3 #define SGN_IN(k) psgn4 #define F_SIZE(ptab) 15 #if defined DIM_2d6 # define ARRAY_IN(i,j,k,l,f) ptab(i,j)7 # define K_SIZE(ptab) 18 # define L_SIZE(ptab) 19 #endif10 #if defined SINGLE_PRECISION11 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)12 # define PRECISION sp13 #else14 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)15 # define PRECISION dp16 #endif17 1 18 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj )2 SUBROUTINE lbc_nfd_ext_/**/PRECISION( ptab, cd_nat, psgn, kextj ) 19 3 !!---------------------------------------------------------------------- 20 INTEGER , INTENT(in ) :: kextj ! extra halo width at north fold, declared before its use in ARRAY_TYPE21 ARRAY_TYPE(:,1-kextj:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied22 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points23 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary4 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 24 8 ! 25 INTEGER :: ji, jj, j k, jl, jh, jf! dummy loop indices26 INTEGER :: ip i, ipj, ipk, ipl, ipf ! dimension of the input array9 INTEGER :: ji, jj, jh ! dummy loop indices 10 INTEGER :: ipj 27 11 INTEGER :: ijt, iju, ipjm1 28 12 !!---------------------------------------------------------------------- 29 !30 ipk = K_SIZE(ptab) ! 3rd dimension31 ipl = L_SIZE(ptab) ! 4th -32 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)33 !34 13 ! 35 14 SELECT CASE ( jpni ) … … 39 18 ! 40 19 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 41 120 42 !43 DO jf = 1, ipf ! Loop on the number of arrays to be treated44 !45 SELECT CASE ( npolj )46 !47 CASE ( 3 , 4 ) ! * North fold T-point pivot48 !49 SELECT CASE ( NAT_IN(jf) )50 CASE ( 'T' , 'W' ) ! T-, W-point51 DO jh = 0, kextj52 DO ji = 2, jpiglo53 ijt = jpiglo-ji+254 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)55 END DO56 ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-2-jh,:,:,jf)57 END DO58 DO ji = jpiglo/2+1, jpiglo59 ijt = jpiglo-ji+260 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf)61 END DO62 CASE ( 'U' ) ! U-point63 DO jh = 0, kextj64 DO ji = 2, jpiglo-165 iju = jpiglo-ji+166 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf)67 END DO68 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 DO71 DO ji = jpiglo/2, jpiglo-172 iju = jpiglo-ji+173 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf)74 END DO75 CASE ( 'V' ) ! V-point76 DO jh = 0, kextj77 DO ji = 2, jpiglo78 ijt = jpiglo-ji+279 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 DO82 ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-3-jh,:,:,jf)83 END DO84 CASE ( 'F' ) ! F-point85 DO jh = 0, kextj86 DO ji = 1, jpiglo-187 iju = jpiglo-ji+188 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 DO91 END DO92 DO jh = 0, kextj93 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 DO96 END SELECT97 !98 CASE ( 5 , 6 ) ! * North fold F-point pivot99 !100 SELECT CASE ( NAT_IN(jf) )101 CASE ( 'T' , 'W' ) ! T-, W-point102 DO jh = 0, kextj103 DO ji = 1, jpiglo104 ijt = jpiglo-ji+1105 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-1-jh,:,:,jf)106 END DO107 END DO108 CASE ( 'U' ) ! U-point109 DO jh = 0, kextj110 DO ji = 1, jpiglo-1111 iju = jpiglo-ji112 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-1-jh,:,:,jf)113 END DO114 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-1-jh,:,:,jf)115 END DO116 CASE ( 'V' ) ! V-point117 DO jh = 0, kextj118 DO ji = 1, jpiglo119 ijt = jpiglo-ji+1120 ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf)121 END DO122 END DO123 DO ji = jpiglo/2+1, jpiglo124 ijt = jpiglo-ji+1125 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf)126 END DO127 CASE ( 'F' ) ! F-point128 DO jh = 0, kextj129 DO ji = 1, jpiglo-1130 iju = jpiglo-ji131 ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf)132 END DO133 ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-2-jh,:,:,jf)134 END DO135 DO ji = jpiglo/2+1, jpiglo-1136 iju = jpiglo-ji137 ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf)138 END DO139 END SELECT140 !141 CASE DEFAULT ! * closed : the code probably never go through142 !143 SELECT CASE ( NAT_IN(jf) )144 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points145 ARRAY_IN(:, 1:1-kextj ,:,:,jf) = 0._wp146 ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp147 CASE ( 'F' ) ! F-point148 ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp149 END SELECT150 !151 END SELECT ! npolj152 !153 END DO154 !155 END SUBROUTINE ROUTINE_NFD156 157 #undef PRECISION158 #undef ARRAY_TYPE159 #undef ARRAY_IN160 #undef NAT_IN161 #undef SGN_IN162 #undef K_SIZE163 #undef L_SIZE164 #undef F_SIZE -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lbc_nfd_generic.h90
r13286 r14448 1 #if defined MULTI2 # define NAT_IN(k) cd_nat(k)3 # define SGN_IN(k) psgn(k)4 # define F_SIZE(ptab) kfld5 # if defined DIM_2d6 # if defined SINGLE_PRECISION7 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp),INTENT(inout)::ptab(f)8 # else9 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp),INTENT(inout)::ptab(f)10 # endif11 # 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) 114 # define L_SIZE(ptab) 115 # endif16 # if defined DIM_3d17 # if defined SINGLE_PRECISION18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp),INTENT(inout)::ptab(f)19 # else20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp),INTENT(inout)::ptab(f)21 # endif22 # 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) 126 # endif27 # if defined DIM_4d28 # if defined SINGLE_PRECISION29 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp),INTENT(inout)::ptab(f)30 # else31 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp),INTENT(inout)::ptab(f)32 # endif33 # 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 # endif38 #else39 ! !== IN: ptab is an array ==!40 # define NAT_IN(k) cd_nat41 # define SGN_IN(k) psgn42 # define F_SIZE(ptab) 143 # if defined DIM_2d44 # define ARRAY_IN(i,j,k,l,f) ptab(i,j)45 # define J_SIZE(ptab) SIZE(ptab,2)46 # define K_SIZE(ptab) 147 # define L_SIZE(ptab) 148 # endif49 # if defined DIM_3d50 # 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) 154 # endif55 # if defined DIM_4d56 # 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 # endif61 # if defined SINGLE_PRECISION62 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)63 # else64 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)65 # endif66 #endif67 1 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 83 8 ! 84 9 INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices 85 INTEGER :: 10 INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array 86 11 INTEGER :: ii1, ii2, ij1, ij2 87 12 !!---------------------------------------------------------------------- 88 13 ! 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 93 24 ! 94 25 DO jf = 1, ipf ! Loop on the number of arrays to be treated 95 26 ! 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' 97 195 ! 98 CASE ( 3 , 4 ) ! * North fold T-point pivot196 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 99 197 ! 100 SELECT CASE ( NAT_IN(jf))198 SELECT CASE ( cd_nat(jf) ) 101 199 CASE ( 'T' , 'W' ) ! T-, W-point 102 200 DO jl = 1, ipl; DO jk = 1, ipk 103 201 ! 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 116 273 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 198 281 END DO 199 282 ! … … 202 285 DO jl = 1, ipl; DO jk = 1, ipk 203 286 ! 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 216 354 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) 264 385 ! 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' 456 387 ! 457 388 END DO ! ipf 458 389 ! 459 END SUBROUTINE ROUTINE_NFD390 END SUBROUTINE lbc_nfd_/**/PRECISION 460 391 461 #undef PRECISION462 #undef ARRAY_TYPE463 #undef ARRAY_IN464 #undef NAT_IN465 #undef SGN_IN466 #undef J_SIZE467 #undef K_SIZE468 #undef L_SIZE469 #undef F_SIZE -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lbc_nfd_nogather_generic.h90
r13286 r14448 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 ) 78 3 !!---------------------------------------------------------------------- 79 4 !! … … 82 7 !! 83 8 !!---------------------------------------------------------------------- 84 ARRAY_TYPE(:,:,:,:,:)85 ARRAY2_TYPE(:,:,:,:,:)86 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:)! nature of array grid-points87 REAL( wp) , INTENT(in ) :: SGN_IN(:)! sign used across the north fold boundary88 INTEGER , OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays89 ! 90 INTEGER :: ji, jj, jk, jn, ii, jl, jh, jf! dummy loop indices91 INTEGER :: ip i, ipj, ipk, ipl, ipf, iij, ijj! dimension of the input array9 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 92 17 INTEGER :: ijt, iju, ijta, ijua, jia, startloop, endloop 93 18 LOGICAL :: l_fast_exchanges 94 19 !!---------------------------------------------------------------------- 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 ! 102 23 ! 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 110 27 ! 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 125 65 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 138 74 END DO 139 75 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 166 111 IF( nimpp + jpi - 1 /= jpiglo ) THEN 167 112 endloop = jpi 168 113 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 211 124 DO jl = 1, ipl; DO jk = 1, ipk 212 125 DO ji = startloop, endloop … … 215 128 ijua = jpiglo - jia + 1 216 129 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) 218 131 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) 220 133 ENDIF 221 134 END DO 222 135 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 232 197 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 233 285 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 241 290 END DO; END DO 242 291 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 258 322 IF( nimpp + jpi - 1 /= jpiglo ) THEN 259 323 endloop = jpi 260 324 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 264 335 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 272 340 END DO; END DO 273 341 ENDIF 274 DO jl = 1, ipl; DO jk = 1, ipk 275 DO ji = 1, endloop 276 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 277 ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf) 278 END DO 279 END DO; END DO 280 IF (nimpp .eq. 1) THEN 281 DO ii = 1, nn_hls 282 ARRAY_IN(ii,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:,jf) 283 END DO 284 IF ( .NOT. l_fast_exchanges ) THEN 285 DO jj = 1, nn_hls 286 ijj = jpj -jj 287 DO ii = 0, nn_hls-1 288 ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf) 289 END DO 290 END DO 291 ENDIF 292 ENDIF 293 IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN 294 DO ii = 1, nn_hls 295 ARRAY_IN(jpi-ii+1,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:,jf) 296 END DO 297 IF ( .NOT. l_fast_exchanges ) THEN 298 DO jj = 1, nn_hls 299 ijj = jpj -jj 300 DO ii = 1, nn_hls 301 ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf) 302 END DO 303 END DO 304 ENDIF 305 ENDIF 306 ! 307 END SELECT 308 ! 309 CASE ( 5, 6 ) ! * North fold F-point pivot 310 ! 311 SELECT CASE ( NAT_IN(jf) ) 312 CASE ( 'T' , 'W' ) ! T-, W-point 313 DO jl = 1, ipl; DO jk = 1, ipk 314 DO jj = 1, nn_hls 315 ijj = jpj-jj+1 316 DO ji = 1, jpi 317 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 318 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 319 END DO 320 END DO 321 END DO; END DO 322 ! 323 CASE ( 'U' ) ! U-point 324 IF( nimpp + jpi - 1 /= jpiglo ) THEN 325 endloop = jpi 326 ELSE 327 endloop = jpi - nn_hls 328 ENDIF 329 DO jl = 1, ipl; DO jk = 1, ipk 330 DO jj = 1, nn_hls 331 ijj = jpj-jj+1 332 DO ji = 1, endloop 333 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2 334 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf) 335 END DO 336 END DO 337 END DO; END DO 338 IF(nimpp + jpi - 1 .eq. jpiglo) THEN 339 DO jl = 1, ipl; DO jk = 1, ipk 340 DO jj = 1, nn_hls 341 ijj = jpj-jj+1 342 DO ii = 1, nn_hls 343 iij = jpi-ii+1 344 ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl,jf) 345 END DO 346 END DO 347 END DO; END DO 348 ENDIF 349 ! 350 CASE ( 'V' ) ! V-point 351 DO jl = 1, ipl; DO jk = 1, ipk 352 DO jj = 1, nn_hls 353 ijj = jpj -jj +1 354 DO ji = 1, jpi 355 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3 356 ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf) 357 END DO 358 END DO 359 END DO; END DO 342 ENDIF 343 ! 344 END SELECT 345 ! 346 ENDIF ! c_NFtype == 'F' 347 ! 348 END SUBROUTINE lbc_nfd_nogather_/**/PRECISION 360 349 361 IF ( .NOT. l_fast_exchanges ) THEN362 IF( nimpp >= Ni0glo/2+2 ) THEN363 startloop = 1364 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN365 startloop = Ni0glo/2+2 - nimpp + nn_hls366 ELSE367 startloop = jpi + 1368 ENDIF369 IF( startloop <= jpi ) THEN370 DO jl = 1, ipl; DO jk = 1, ipk371 DO ji = startloop, jpi372 ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3373 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf)374 END DO375 END DO; END DO376 ENDIF377 ENDIF378 !379 CASE ( 'F' ) ! F-point380 IF( nimpp + jpi - 1 /= jpiglo ) THEN381 endloop = jpi382 ELSE383 endloop = jpi - nn_hls384 ENDIF385 DO jl = 1, ipl; DO jk = 1, ipk386 DO jj = 1, nn_hls387 ijj = jpj -jj +1388 DO ji = 1, endloop389 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2390 ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)391 END DO392 END DO393 END DO; END DO394 IF((nimpp + jpi - 1) .eq. jpiglo) THEN395 DO jl = 1, ipl; DO jk = 1, ipk396 DO jj = 1, nn_hls397 ijj = jpj -jj +1398 DO ii = 1, nn_hls399 iij = jpi -ii+1400 ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl,jf)401 END DO402 END DO403 END DO; END DO404 ENDIF405 !406 IF ( .NOT. l_fast_exchanges ) THEN407 IF( nimpp + jpi - 1 /= jpiglo ) THEN408 endloop = jpi409 ELSE410 endloop = jpi - nn_hls411 ENDIF412 IF( nimpp >= Ni0glo/2+2 ) THEN413 startloop = 1414 ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN415 startloop = Ni0glo/2+2 - nimpp + nn_hls416 ELSE417 startloop = endloop + 1418 ENDIF419 IF( startloop <= endloop ) THEN420 DO jl = 1, ipl; DO jk = 1, ipk421 DO ji = startloop, endloop422 iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2423 ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf)424 END DO425 END DO; END DO426 ENDIF427 ENDIF428 !429 END SELECT430 !431 CASE DEFAULT ! * closed : the code probably never go through432 !433 WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj434 !435 END SELECT ! npolj436 !437 END DO ! End jf loop438 END SUBROUTINE ROUTINE_NFD439 #undef PRECISION440 #undef ARRAY_TYPE441 #undef ARRAY_IN442 #undef NAT_IN443 #undef SGN_IN444 #undef J_SIZE445 #undef K_SIZE446 #undef L_SIZE447 #undef F_SIZE448 #undef ARRAY2_TYPE449 #undef ARRAY2_IN -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lbclnk.F90
r14229 r14448 23 23 USE lbcnfd ! north fold 24 24 USE in_out_manager ! I/O manager 25 #if ! defined key_mpi_off 26 USE MPI 27 #endif 25 28 26 29 IMPLICIT NONE … … 28 31 29 32 INTERFACE lbc_lnk 30 MODULE PROCEDURE mpp_lnk_2d_sp , mpp_lnk_3d_sp , mpp_lnk_4d_sp 31 MODULE PROCEDURE mpp_lnk_2d_dp , mpp_lnk_3d_dp , mpp_lnk_4d_dp 32 END INTERFACE 33 INTERFACE lbc_lnk_ptr 34 MODULE PROCEDURE mpp_lnk_2d_ptr_sp , mpp_lnk_3d_ptr_sp , mpp_lnk_4d_ptr_sp 35 MODULE PROCEDURE mpp_lnk_2d_ptr_dp , mpp_lnk_3d_ptr_dp , mpp_lnk_4d_ptr_dp 36 END INTERFACE 37 INTERFACE lbc_lnk_multi 38 MODULE PROCEDURE lbc_lnk_2d_multi_sp , lbc_lnk_3d_multi_sp, lbc_lnk_4d_multi_sp 39 MODULE PROCEDURE lbc_lnk_2d_multi_dp , lbc_lnk_3d_multi_dp, lbc_lnk_4d_multi_dp 40 END INTERFACE 41 INTERFACE lbc_lnk_nc_multi 42 MODULE PROCEDURE lbc_lnk_nc_2d_sp, lbc_lnk_nc_3d_sp, lbc_lnk_nc_4d_sp 43 MODULE PROCEDURE lbc_lnk_nc_2d_dp, lbc_lnk_nc_3d_dp, lbc_lnk_nc_4d_dp 44 END INTERFACE 45 INTERFACE lbc_lnk_nc 46 MODULE PROCEDURE mpp_lnk_nc_2d_sp, mpp_lnk_nc_3d_sp, mpp_lnk_nc_4d_sp 47 MODULE PROCEDURE mpp_lnk_nc_2d_dp, mpp_lnk_nc_3d_dp, mpp_lnk_nc_4d_dp 33 MODULE PROCEDURE lbc_lnk_call_2d_sp, lbc_lnk_call_3d_sp, lbc_lnk_call_4d_sp 34 MODULE PROCEDURE lbc_lnk_call_2d_dp, lbc_lnk_call_3d_dp, lbc_lnk_call_4d_dp 35 END INTERFACE 36 37 INTERFACE lbc_lnk_pt2pt 38 MODULE PROCEDURE lbc_lnk_pt2pt_sp, lbc_lnk_pt2pt_dp 39 END INTERFACE 40 41 INTERFACE lbc_lnk_neicoll 42 MODULE PROCEDURE lbc_lnk_neicoll_sp ,lbc_lnk_neicoll_dp 48 43 END INTERFACE 49 44 ! … … 52 47 END INTERFACE 53 48 54 INTERFACE mpp_nfd55 MODULE PROCEDURE mpp_nfd_2d_sp , mpp_nfd_3d_sp , mpp_nfd_4d_sp56 MODULE PROCEDURE mpp_nfd_2d_dp , mpp_nfd_3d_dp , mpp_nfd_4d_dp57 MODULE PROCEDURE mpp_nfd_2d_ptr_sp, mpp_nfd_3d_ptr_sp, mpp_nfd_4d_ptr_sp58 MODULE PROCEDURE mpp_nfd_2d_ptr_dp, mpp_nfd_3d_ptr_dp, mpp_nfd_4d_ptr_dp59 60 END INTERFACE61 62 49 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 63 PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions64 50 PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions 65 PUBLIC lbc_lnk_nc ! ocean/ice lateral boundary conditions (MPI3 version) 66 PUBLIC lbc_lnk_nc_multi ! modified ocean/ice lateral boundary conditions (MPI3 version) 67 68 #if ! defined key_mpi_off 69 !$AGRIF_DO_NOT_TREAT 70 INCLUDE 'mpif.h' 71 !$AGRIF_END_DO_NOT_TREAT 72 #endif 73 74 INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 75 INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 76 INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 77 INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 78 INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 79 51 52 REAL(dp), DIMENSION(:), ALLOCATABLE :: buffsnd_dp, buffrcv_dp ! MPI send/recv buffers 53 REAL(sp), DIMENSION(:), ALLOCATABLE :: buffsnd_sp, buffrcv_sp ! 54 INTEGER, DIMENSION(8) :: nreq_p2p ! request id for MPI_Isend in point-2-point communication 55 80 56 !! * Substitutions 81 # include "do_loop_substitute.h90"57 !!# include "do_loop_substitute.h90" 82 58 !!---------------------------------------------------------------------- 83 59 !! NEMO/OCE 4.0 , NEMO Consortium (2018) … … 88 64 89 65 !!---------------------------------------------------------------------- 90 !! *** l oad_ptr_(2,3,4)d***66 !! *** lbc_lnk_call_[234]d_[sd]p *** 91 67 !! 92 68 !! * Dummy Argument : 93 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 69 !! in ==> cdname ! name of the calling subroutine (for monitoring) 70 !! ptab ! array to be loaded (2D, 3D or 4D) 94 71 !! cd_nat ! nature of pt2d array grid-points 95 72 !! psgn ! sign used across the north fold boundary … … 99 76 !! kfld ! number of elements that has been attributed 100 77 !!---------------------------------------------------------------------- 101 102 !!---------------------------------------------------------------------- 103 !! *** lbc_lnk_(2,3,4)d_multi *** 104 !! *** load_ptr_(2,3,4)d *** 105 !! 106 !! * Argument : dummy argument use in lbc_lnk_multi_... routines 107 !! 108 !!---------------------------------------------------------------------- 109 78 ! 79 !!---------------------------------------------------------------------- 80 !! 81 !! *** lbc_lnk_call_[234]d_[sd]p *** 82 !! *** load_ptr_[234]d_[sd]p *** 83 !! 84 !!---------------------------------------------------------------------- 110 85 !! 111 86 !! ---- SINGLE PRECISION VERSIONS 112 87 !! 113 # define SINGLE_PRECISION 114 # define DIM_2d 115 # define ROUTINE_LOAD load_ptr_2d_sp 116 # define ROUTINE_MULTI lbc_lnk_2d_multi_sp 117 # include "lbc_lnk_multi_generic.h90" 118 # undef ROUTINE_MULTI 119 # undef ROUTINE_LOAD 120 # undef DIM_2d 121 122 # define DIM_3d 123 # define ROUTINE_LOAD load_ptr_3d_sp 124 # define ROUTINE_MULTI lbc_lnk_3d_multi_sp 125 # include "lbc_lnk_multi_generic.h90" 126 # undef ROUTINE_MULTI 127 # undef ROUTINE_LOAD 128 # undef DIM_3d 129 130 # define DIM_4d 131 # define ROUTINE_LOAD load_ptr_4d_sp 132 # define ROUTINE_MULTI lbc_lnk_4d_multi_sp 133 # include "lbc_lnk_multi_generic.h90" 134 # undef ROUTINE_MULTI 135 # undef ROUTINE_LOAD 136 # undef DIM_4d 137 # undef SINGLE_PRECISION 88 #define PRECISION sp 89 # define DIM_2d 90 # include "lbc_lnk_call_generic.h90" 91 # undef DIM_2d 92 # define DIM_3d 93 # include "lbc_lnk_call_generic.h90" 94 # undef DIM_3d 95 # define DIM_4d 96 # include "lbc_lnk_call_generic.h90" 97 # undef DIM_4d 98 #undef PRECISION 138 99 !! 139 100 !! ---- DOUBLE PRECISION VERSIONS 140 101 !! 141 142 # define DIM_2d 143 # define ROUTINE_LOAD load_ptr_2d_dp 144 # define ROUTINE_MULTI lbc_lnk_2d_multi_dp 145 # include "lbc_lnk_multi_generic.h90" 146 # undef ROUTINE_MULTI 147 # undef ROUTINE_LOAD 148 # undef DIM_2d 149 150 # define DIM_3d 151 # define ROUTINE_LOAD load_ptr_3d_dp 152 # define ROUTINE_MULTI lbc_lnk_3d_multi_dp 153 # include "lbc_lnk_multi_generic.h90" 154 # undef ROUTINE_MULTI 155 # undef ROUTINE_LOAD 156 # undef DIM_3d 157 158 # define DIM_4d 159 # define ROUTINE_LOAD load_ptr_4d_dp 160 # define ROUTINE_MULTI lbc_lnk_4d_multi_dp 161 # include "lbc_lnk_multi_generic.h90" 162 # undef ROUTINE_MULTI 163 # undef ROUTINE_LOAD 164 # undef DIM_4d 165 166 !!---------------------------------------------------------------------- 167 !! *** routine mpp_lnk_(2,3,4)d *** 168 !! 169 !! * Argument : dummy argument use in mpp_lnk_... routines 170 !! ptab : array or pointer of arrays on which the boundary condition is applied 102 #define PRECISION dp 103 # define DIM_2d 104 # include "lbc_lnk_call_generic.h90" 105 # undef DIM_2d 106 # define DIM_3d 107 # include "lbc_lnk_call_generic.h90" 108 # undef DIM_3d 109 # define DIM_4d 110 # include "lbc_lnk_call_generic.h90" 111 # undef DIM_4d 112 #undef PRECISION 113 ! 114 !!---------------------------------------------------------------------- 115 !! *** lbc_lnk_pt2pt_[sd]p *** 116 !! *** lbc_lnk_neicoll_[sd]p *** 117 !! 118 !! * Argument : dummy argument use in lbc_lnk_... routines 119 !! cdname : name of the calling subroutine (for monitoring) 120 !! ptab : pointer of arrays on which the boundary condition is applied 171 121 !! cd_nat : nature of array grid-points 172 122 !! psgn : sign used across the north fold boundary 173 !! kfld : optional,number of pt3d arrays123 !! kfld : number of pt3d arrays 174 124 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 175 125 !! pfillval : optional, background value (used with jpfillcopy) 176 126 !!---------------------------------------------------------------------- 177 !178 ! !== 2D array and array of 2D pointer ==!179 !180 127 !! 181 128 !! ---- SINGLE PRECISION VERSIONS 182 129 !! 183 # define SINGLE_PRECISION 184 # define DIM_2d 185 # define ROUTINE_LNK mpp_lnk_2d_sp 186 # include "mpp_lnk_generic.h90" 187 # undef ROUTINE_LNK 188 # define MULTI 189 # define ROUTINE_LNK mpp_lnk_2d_ptr_sp 190 # include "mpp_lnk_generic.h90" 191 # undef ROUTINE_LNK 192 # undef MULTI 193 # undef DIM_2d 194 ! 195 ! !== 3D array and array of 3D pointer ==! 196 ! 197 # define DIM_3d 198 # define ROUTINE_LNK mpp_lnk_3d_sp 199 # include "mpp_lnk_generic.h90" 200 # undef ROUTINE_LNK 201 # define MULTI 202 # define ROUTINE_LNK mpp_lnk_3d_ptr_sp 203 # include "mpp_lnk_generic.h90" 204 # undef ROUTINE_LNK 205 # undef MULTI 206 # undef DIM_3d 207 ! 208 ! !== 4D array and array of 4D pointer ==! 209 ! 210 # define DIM_4d 211 # define ROUTINE_LNK mpp_lnk_4d_sp 212 # include "mpp_lnk_generic.h90" 213 # undef ROUTINE_LNK 214 # define MULTI 215 # define ROUTINE_LNK mpp_lnk_4d_ptr_sp 216 # include "mpp_lnk_generic.h90" 217 # undef ROUTINE_LNK 218 # undef MULTI 219 # undef DIM_4d 220 # undef SINGLE_PRECISION 221 130 #define PRECISION sp 131 # define MPI_TYPE MPI_REAL 132 # define BUFFSND buffsnd_sp 133 # define BUFFRCV buffrcv_sp 134 # include "lbc_lnk_pt2pt_generic.h90" 135 # include "lbc_lnk_neicoll_generic.h90" 136 # undef MPI_TYPE 137 # undef BUFFSND 138 # undef BUFFRCV 139 #undef PRECISION 222 140 !! 223 141 !! ---- DOUBLE PRECISION VERSIONS 224 142 !! 225 # define DIM_2d 226 # define ROUTINE_LNK mpp_lnk_2d_dp 227 # include "mpp_lnk_generic.h90" 228 # undef ROUTINE_LNK 229 # define MULTI 230 # define ROUTINE_LNK mpp_lnk_2d_ptr_dp 231 # include "mpp_lnk_generic.h90" 232 # undef ROUTINE_LNK 233 # undef MULTI 234 # undef DIM_2d 235 ! 236 ! !== 3D array and array of 3D pointer ==! 237 ! 238 # define DIM_3d 239 # define ROUTINE_LNK mpp_lnk_3d_dp 240 # include "mpp_lnk_generic.h90" 241 # undef ROUTINE_LNK 242 # define MULTI 243 # define ROUTINE_LNK mpp_lnk_3d_ptr_dp 244 # include "mpp_lnk_generic.h90" 245 # undef ROUTINE_LNK 246 # undef MULTI 247 # undef DIM_3d 248 ! 249 ! !== 4D array and array of 4D pointer ==! 250 ! 251 # define DIM_4d 252 # define ROUTINE_LNK mpp_lnk_4d_dp 253 # include "mpp_lnk_generic.h90" 254 # undef ROUTINE_LNK 255 # define MULTI 256 # define ROUTINE_LNK mpp_lnk_4d_ptr_dp 257 # include "mpp_lnk_generic.h90" 258 # undef ROUTINE_LNK 259 # undef MULTI 260 # undef DIM_4d 261 262 !!---------------------------------------------------------------------- 263 !! *** load_ptr_(2,3,4)d *** 264 !! 265 !! * Dummy Argument : 266 !! in ==> ptab ! array to be loaded (2D, 3D or 4D) 267 !! cd_nat ! nature of pt2d array grid-points 268 !! psgn ! sign used across the north fold boundary 269 !! inout <=> ptab_ptr ! array of 2D, 3D or 4D pointers 270 !! cdna_ptr ! nature of ptab array grid-points 271 !! psgn_ptr ! sign used across the north fold boundary 272 !! kfld ! number of elements that has been attributed 273 !!---------------------------------------------------------------------- 274 275 !!---------------------------------------------------------------------- 276 !! *** lbc_lnk_nc(2,3,4)d_multi *** 277 !! *** load_ptr_(2,3,4)d *** 278 !! 279 !! * Argument : dummy argument use in lbc_lnk_nc_multi_... routines 280 !! 281 !!---------------------------------------------------------------------- 282 283 !! 284 !! ---- SINGLE PRECISION VERSIONS 285 !! 286 # define SINGLE_PRECISION 287 # define DIM_2d 288 # define ROUTINE_NC_LOAD load_ptr_nc_2d_sp 289 # define ROUTINE_MULTI_NC lbc_lnk_nc_2d_sp 290 # include "lbc_lnk_nc_generic.h90" 291 # undef ROUTINE_MULTI_NC 292 # undef ROUTINE_NC_LOAD 293 # undef DIM_2d 294 295 # define DIM_3d 296 # define ROUTINE_NC_LOAD load_ptr_nc_3d_sp 297 # define ROUTINE_MULTI_NC lbc_lnk_nc_3d_sp 298 # include "lbc_lnk_nc_generic.h90" 299 # undef ROUTINE_MULTI_NC 300 # undef ROUTINE_NC_LOAD 301 # undef DIM_3d 302 303 # define DIM_4d 304 # define ROUTINE_NC_LOAD load_ptr_nc_4d_sp 305 # define ROUTINE_MULTI_NC lbc_lnk_nc_4d_sp 306 # include "lbc_lnk_nc_generic.h90" 307 # undef ROUTINE_MULTI_NC 308 # undef ROUTINE_NC_LOAD 309 # undef DIM_4d 310 # undef SINGLE_PRECISION 311 !! 312 !! ---- DOUBLE PRECISION VERSIONS 313 !! 314 315 # define DIM_2d 316 # define ROUTINE_NC_LOAD load_ptr_nc_2d_dp 317 # define ROUTINE_MULTI_NC lbc_lnk_nc_2d_dp 318 # include "lbc_lnk_nc_generic.h90" 319 # undef ROUTINE_MULTI_NC 320 # undef ROUTINE_NC_LOAD 321 # undef DIM_2d 322 323 # define DIM_3d 324 # define ROUTINE_NC_LOAD load_ptr_nc_3d_dp 325 # define ROUTINE_MULTI_NC lbc_lnk_nc_3d_dp 326 # include "lbc_lnk_nc_generic.h90" 327 # undef ROUTINE_MULTI_NC 328 # undef ROUTINE_NC_LOAD 329 # undef DIM_3d 330 331 # define DIM_4d 332 # define ROUTINE_NC_LOAD load_ptr_nc_4d_dp 333 # define ROUTINE_MULTI_NC lbc_lnk_nc_4d_dp 334 # include "lbc_lnk_nc_generic.h90" 335 # undef ROUTINE_MULTI_NC 336 # undef ROUTINE_NC_LOAD 337 # undef DIM_4d 338 339 !!---------------------------------------------------------------------- 340 !! *** routine mpp_lnk_nc_(2,3,4)d *** 341 !! 342 !! * Argument : dummy argument use in mpp_lnk_... routines 343 !! ptab : array or pointer of arrays on which the boundary condition is applied 344 !! cd_nat : nature of array grid-points 345 !! psgn : sign used across the north fold boundary 346 !! kfld : optional, number of pt3d arrays 347 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 348 !! pfillval : optional, background value (used with jpfillcopy) 349 !!---------------------------------------------------------------------- 350 ! 351 ! !== 2D array and array of 2D pointer ==! 352 ! 353 !! 354 !! ---- SINGLE PRECISION VERSIONS 355 !! 356 # define SINGLE_PRECISION 357 # define DIM_2d 358 # define ROUTINE_NC mpp_lnk_nc_2d_sp 359 # include "mpp_nc_generic.h90" 360 # undef ROUTINE_NC 361 # undef DIM_2d 362 ! 363 ! !== 3D array and array of 3D pointer ==! 364 ! 365 # define DIM_3d 366 # define ROUTINE_NC mpp_lnk_nc_3d_sp 367 # include "mpp_nc_generic.h90" 368 # undef ROUTINE_NC 369 # undef DIM_3d 370 ! 371 ! !== 4D array and array of 4D pointer ==! 372 ! 373 # define DIM_4d 374 # define ROUTINE_NC mpp_lnk_nc_4d_sp 375 # include "mpp_nc_generic.h90" 376 # undef ROUTINE_NC 377 # undef DIM_4d 378 # undef SINGLE_PRECISION 379 380 !! 381 !! ---- DOUBLE PRECISION VERSIONS 382 !! 383 # define DIM_2d 384 # define ROUTINE_NC mpp_lnk_nc_2d_dp 385 # include "mpp_nc_generic.h90" 386 # undef ROUTINE_NC 387 # undef DIM_2d 388 ! 389 ! !== 3D array and array of 3D pointer ==! 390 ! 391 # define DIM_3d 392 # define ROUTINE_NC mpp_lnk_nc_3d_dp 393 # include "mpp_nc_generic.h90" 394 # undef ROUTINE_NC 395 # undef DIM_3d 396 ! 397 ! !== 4D array and array of 4D pointer ==! 398 ! 399 # define DIM_4d 400 # define ROUTINE_NC mpp_lnk_nc_4d_dp 401 # include "mpp_nc_generic.h90" 402 # undef ROUTINE_NC 403 # undef DIM_4d 404 405 !!---------------------------------------------------------------------- 406 !! *** routine mpp_nfd_(2,3,4)d *** 407 !! 408 !! * Argument : dummy argument use in mpp_nfd_... routines 409 !! ptab : array or pointer of arrays on which the boundary condition is applied 410 !! cd_nat : nature of array grid-points 411 !! psgn : sign used across the north fold boundary 412 !! kfld : optional, number of pt3d arrays 413 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 414 !! pfillval : optional, background value (used with jpfillcopy) 415 !!---------------------------------------------------------------------- 416 ! 417 ! !== 2D array and array of 2D pointer ==! 418 ! 419 !! 420 !! ---- SINGLE PRECISION VERSIONS 421 !! 422 # define SINGLE_PRECISION 423 # define DIM_2d 424 # define ROUTINE_NFD mpp_nfd_2d_sp 425 # include "mpp_nfd_generic.h90" 426 # undef ROUTINE_NFD 427 # define MULTI 428 # define ROUTINE_NFD mpp_nfd_2d_ptr_sp 429 # include "mpp_nfd_generic.h90" 430 # undef ROUTINE_NFD 431 # undef MULTI 432 # undef DIM_2d 433 ! 434 ! !== 3D array and array of 3D pointer ==! 435 ! 436 # define DIM_3d 437 # define ROUTINE_NFD mpp_nfd_3d_sp 438 # include "mpp_nfd_generic.h90" 439 # undef ROUTINE_NFD 440 # define MULTI 441 # define ROUTINE_NFD mpp_nfd_3d_ptr_sp 442 # include "mpp_nfd_generic.h90" 443 # undef ROUTINE_NFD 444 # undef MULTI 445 # undef DIM_3d 446 ! 447 ! !== 4D array and array of 4D pointer ==! 448 ! 449 # define DIM_4d 450 # define ROUTINE_NFD mpp_nfd_4d_sp 451 # include "mpp_nfd_generic.h90" 452 # undef ROUTINE_NFD 453 # define MULTI 454 # define ROUTINE_NFD mpp_nfd_4d_ptr_sp 455 # include "mpp_nfd_generic.h90" 456 # undef ROUTINE_NFD 457 # undef MULTI 458 # undef DIM_4d 459 # undef SINGLE_PRECISION 460 461 !! 462 !! ---- DOUBLE PRECISION VERSIONS 463 !! 464 # define DIM_2d 465 # define ROUTINE_NFD mpp_nfd_2d_dp 466 # include "mpp_nfd_generic.h90" 467 # undef ROUTINE_NFD 468 # define MULTI 469 # define ROUTINE_NFD mpp_nfd_2d_ptr_dp 470 # include "mpp_nfd_generic.h90" 471 # undef ROUTINE_NFD 472 # undef MULTI 473 # undef DIM_2d 474 ! 475 ! !== 3D array and array of 3D pointer ==! 476 ! 477 # define DIM_3d 478 # define ROUTINE_NFD mpp_nfd_3d_dp 479 # include "mpp_nfd_generic.h90" 480 # undef ROUTINE_NFD 481 # define MULTI 482 # define ROUTINE_NFD mpp_nfd_3d_ptr_dp 483 # include "mpp_nfd_generic.h90" 484 # undef ROUTINE_NFD 485 # undef MULTI 486 # undef DIM_3d 487 ! 488 ! !== 4D array and array of 4D pointer ==! 489 ! 490 # define DIM_4d 491 # define ROUTINE_NFD mpp_nfd_4d_dp 492 # include "mpp_nfd_generic.h90" 493 # undef ROUTINE_NFD 494 # define MULTI 495 # define ROUTINE_NFD mpp_nfd_4d_ptr_dp 496 # include "mpp_nfd_generic.h90" 497 # undef ROUTINE_NFD 498 # undef MULTI 499 # undef DIM_4d 500 501 !!====================================================================== 502 143 #define PRECISION dp 144 # define MPI_TYPE MPI_DOUBLE_PRECISION 145 # define BUFFSND buffsnd_dp 146 # define BUFFRCV buffrcv_dp 147 # include "lbc_lnk_pt2pt_generic.h90" 148 # include "lbc_lnk_neicoll_generic.h90" 149 # undef MPI_TYPE 150 # undef BUFFSND 151 # undef BUFFRCV 152 #undef PRECISION 503 153 504 154 !!====================================================================== … … 541 191 !! jpi : first dimension of the local subdomain 542 192 !! jpj : second dimension of the local subdomain 543 !! kexti : number of columns for extra outer halo 544 !! kextj : number of rows for extra outer halo 545 !! nbondi : mark for "east-west local boundary" 546 !! nbondj : mark for "north-south local boundary" 547 !! noea : number for local neighboring processors 548 !! nowe : number for local neighboring processors 549 !! noso : number for local neighboring processors 550 !! nono : number for local neighboring processors 193 !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 551 194 !!---------------------------------------------------------------------- 552 195 -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lbcnfd.F90
r13286 r14448 21 21 USE in_out_manager ! I/O manager 22 22 USE lib_mpp ! MPP library 23 #if ! defined key_mpi_off 24 USE MPI 25 #endif 23 26 24 27 IMPLICIT NONE 25 28 PRIVATE 26 29 27 INTERFACE lbc_nfd 28 MODULE PROCEDURE lbc_nfd_2d_sp , lbc_nfd_3d_sp , lbc_nfd_4d_sp 29 MODULE PROCEDURE lbc_nfd_2d_ptr_sp, lbc_nfd_3d_ptr_sp, lbc_nfd_4d_ptr_sp 30 MODULE PROCEDURE lbc_nfd_2d_ext_sp 31 MODULE PROCEDURE lbc_nfd_2d_dp , lbc_nfd_3d_dp , lbc_nfd_4d_dp 32 MODULE PROCEDURE lbc_nfd_2d_ptr_dp, lbc_nfd_3d_ptr_dp, lbc_nfd_4d_ptr_dp 33 MODULE PROCEDURE lbc_nfd_2d_ext_dp 34 END INTERFACE 35 ! 36 INTERFACE lbc_nfd_nogather 37 ! ! Currently only 4d array version is needed 38 MODULE PROCEDURE lbc_nfd_nogather_2d_sp , lbc_nfd_nogather_3d_sp 39 MODULE PROCEDURE lbc_nfd_nogather_4d_sp 40 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_sp, lbc_nfd_nogather_3d_ptr_sp 41 MODULE PROCEDURE lbc_nfd_nogather_2d_dp , lbc_nfd_nogather_3d_dp 42 MODULE PROCEDURE lbc_nfd_nogather_4d_dp 43 MODULE PROCEDURE lbc_nfd_nogather_2d_ptr_dp, lbc_nfd_nogather_3d_ptr_dp 44 ! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr 30 INTERFACE lbc_nfd ! called by mpp_nfd, lbc_lnk_pt2pt or lbc_lnk_neicoll 31 MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_ext_sp 32 MODULE PROCEDURE lbc_nfd_dp, lbc_nfd_ext_dp 45 33 END INTERFACE 46 34 47 TYPE, PUBLIC :: PTR_2D_dp !: array of 2D pointers (also used in lib_mpp) 48 REAL(dp), DIMENSION (:,:) , POINTER :: pt2d 49 END TYPE PTR_2D_dp 50 TYPE, PUBLIC :: PTR_3D_dp !: array of 3D pointers (also used in lib_mpp) 51 REAL(dp), DIMENSION (:,:,:) , POINTER :: pt3d 52 END TYPE PTR_3D_dp 53 TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (also used in lib_mpp) 54 REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d 55 END TYPE PTR_4D_dp 35 INTERFACE mpp_nfd ! called by lbc_lnk_pt2pt or lbc_lnk_neicoll 36 MODULE PROCEDURE mpp_nfd_sp, mpp_nfd_dp 37 END INTERFACE 56 38 57 TYPE, PUBLIC :: PTR_2D_sp !: array of 2D pointers (also used in lib_mpp) 58 REAL(sp), DIMENSION (:,:) , POINTER :: pt2d 59 END TYPE PTR_2D_sp 60 TYPE, PUBLIC :: PTR_3D_sp !: array of 3D pointers (also used in lib_mpp) 61 REAL(sp), DIMENSION (:,:,:) , POINTER :: pt3d 62 END TYPE PTR_3D_sp 63 TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (also used in lib_mpp) 64 REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d 65 END TYPE PTR_4D_sp 66 67 39 INTERFACE lbc_nfd_nogather ! called by mpp_nfd 40 MODULE PROCEDURE lbc_nfd_nogather_sp, lbc_nfd_nogather_dp 41 END INTERFACE 42 43 PUBLIC mpp_nfd ! mpi north fold conditions 68 44 PUBLIC lbc_nfd ! north fold conditions 69 45 PUBLIC lbc_nfd_nogather ! north fold conditions (no allgather case) … … 82 58 83 59 !!---------------------------------------------------------------------- 84 !! *** routine lbc_nfd_(2,3,4)d *** 60 !! *** routine lbc_nfd_[sd]p *** 61 !! *** routine lbc_nfd_nogather_[sd]p *** 62 !! *** routine lbc_nfd_ext_[sd]p *** 85 63 !!---------------------------------------------------------------------- 86 64 !! … … 95 73 ! !== SINGLE PRECISION VERSIONS 96 74 ! 97 ! 98 ! !== 2D array and array of 2D pointer ==! 99 ! 100 # define SINGLE_PRECISION 101 # define DIM_2d 102 # define ROUTINE_NFD lbc_nfd_2d_sp 103 # include "lbc_nfd_generic.h90" 104 # undef ROUTINE_NFD 105 # define MULTI 106 # define ROUTINE_NFD lbc_nfd_2d_ptr_sp 107 # include "lbc_nfd_generic.h90" 108 # undef ROUTINE_NFD 109 # undef MULTI 110 # undef DIM_2d 111 ! 112 ! !== 2D array with extra haloes ==! 113 ! 114 # define DIM_2d 115 # define ROUTINE_NFD lbc_nfd_2d_ext_sp 116 # include "lbc_nfd_ext_generic.h90" 117 # undef ROUTINE_NFD 118 # undef DIM_2d 119 ! 120 ! !== 3D array and array of 3D pointer ==! 121 ! 122 # define DIM_3d 123 # define ROUTINE_NFD lbc_nfd_3d_sp 124 # include "lbc_nfd_generic.h90" 125 # undef ROUTINE_NFD 126 # define MULTI 127 # define ROUTINE_NFD lbc_nfd_3d_ptr_sp 128 # include "lbc_nfd_generic.h90" 129 # undef ROUTINE_NFD 130 # undef MULTI 131 # undef DIM_3d 132 ! 133 ! !== 4D array and array of 4D pointer ==! 134 ! 135 # define DIM_4d 136 # define ROUTINE_NFD lbc_nfd_4d_sp 137 # include "lbc_nfd_generic.h90" 138 # undef ROUTINE_NFD 139 # define MULTI 140 # define ROUTINE_NFD lbc_nfd_4d_ptr_sp 141 # include "lbc_nfd_generic.h90" 142 # undef ROUTINE_NFD 143 # undef MULTI 144 # undef DIM_4d 145 ! 146 ! lbc_nfd_nogather routines 147 ! 148 ! !== 2D array and array of 2D pointer ==! 149 ! 150 # define DIM_2d 151 # define ROUTINE_NFD lbc_nfd_nogather_2d_sp 152 # include "lbc_nfd_nogather_generic.h90" 153 # undef ROUTINE_NFD 154 # define MULTI 155 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_sp 156 # include "lbc_nfd_nogather_generic.h90" 157 # undef ROUTINE_NFD 158 # undef MULTI 159 # undef DIM_2d 160 ! 161 ! !== 3D array and array of 3D pointer ==! 162 ! 163 # define DIM_3d 164 # define ROUTINE_NFD lbc_nfd_nogather_3d_sp 165 # include "lbc_nfd_nogather_generic.h90" 166 # undef ROUTINE_NFD 167 # define MULTI 168 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_sp 169 # include "lbc_nfd_nogather_generic.h90" 170 # undef ROUTINE_NFD 171 # undef MULTI 172 # undef DIM_3d 173 ! 174 ! !== 4D array and array of 4D pointer ==! 175 ! 176 # define DIM_4d 177 # define ROUTINE_NFD lbc_nfd_nogather_4d_sp 178 # include "lbc_nfd_nogather_generic.h90" 179 # undef ROUTINE_NFD 180 !# define MULTI 181 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr 182 !# include "lbc_nfd_nogather_generic.h90" 183 !# undef ROUTINE_NFD 184 !# undef MULTI 185 # undef DIM_4d 186 # undef SINGLE_PRECISION 187 188 !!---------------------------------------------------------------------- 75 #define PRECISION sp 76 # include "lbc_nfd_generic.h90" 77 # include "lbc_nfd_nogather_generic.h90" 78 # include "lbc_nfd_ext_generic.h90" 79 #undef PRECISION 189 80 ! 190 81 ! !== DOUBLE PRECISION VERSIONS 191 82 ! 83 #define PRECISION dp 84 # include "lbc_nfd_generic.h90" 85 # include "lbc_nfd_nogather_generic.h90" 86 # include "lbc_nfd_ext_generic.h90" 87 #undef PRECISION 88 89 !!====================================================================== 192 90 ! 193 ! !== 2D array and array of 2D pointer ==!194 !195 # define DIM_2d196 # define ROUTINE_NFD lbc_nfd_2d_dp197 # include "lbc_nfd_generic.h90"198 # undef ROUTINE_NFD199 # define MULTI200 # define ROUTINE_NFD lbc_nfd_2d_ptr_dp201 # include "lbc_nfd_generic.h90"202 # undef ROUTINE_NFD203 # undef MULTI204 # undef DIM_2d205 !206 ! !== 2D array with extra haloes ==!207 !208 # define DIM_2d209 # define ROUTINE_NFD lbc_nfd_2d_ext_dp210 # include "lbc_nfd_ext_generic.h90"211 # undef ROUTINE_NFD212 # undef DIM_2d213 !214 ! !== 3D array and array of 3D pointer ==!215 !216 # define DIM_3d217 # define ROUTINE_NFD lbc_nfd_3d_dp218 # include "lbc_nfd_generic.h90"219 # undef ROUTINE_NFD220 # define MULTI221 # define ROUTINE_NFD lbc_nfd_3d_ptr_dp222 # include "lbc_nfd_generic.h90"223 # undef ROUTINE_NFD224 # undef MULTI225 # undef DIM_3d226 !227 ! !== 4D array and array of 4D pointer ==!228 !229 # define DIM_4d230 # define ROUTINE_NFD lbc_nfd_4d_dp231 # include "lbc_nfd_generic.h90"232 # undef ROUTINE_NFD233 # define MULTI234 # define ROUTINE_NFD lbc_nfd_4d_ptr_dp235 # include "lbc_nfd_generic.h90"236 # undef ROUTINE_NFD237 # undef MULTI238 # undef DIM_4d239 !240 ! lbc_nfd_nogather routines241 !242 ! !== 2D array and array of 2D pointer ==!243 !244 # define DIM_2d245 # define ROUTINE_NFD lbc_nfd_nogather_2d_dp246 # include "lbc_nfd_nogather_generic.h90"247 # undef ROUTINE_NFD248 # define MULTI249 # define ROUTINE_NFD lbc_nfd_nogather_2d_ptr_dp250 # include "lbc_nfd_nogather_generic.h90"251 # undef ROUTINE_NFD252 # undef MULTI253 # undef DIM_2d254 !255 ! !== 3D array and array of 3D pointer ==!256 !257 # define DIM_3d258 # define ROUTINE_NFD lbc_nfd_nogather_3d_dp259 # include "lbc_nfd_nogather_generic.h90"260 # undef ROUTINE_NFD261 # define MULTI262 # define ROUTINE_NFD lbc_nfd_nogather_3d_ptr_dp263 # include "lbc_nfd_nogather_generic.h90"264 # undef ROUTINE_NFD265 # undef MULTI266 # undef DIM_3d267 !268 ! !== 4D array and array of 4D pointer ==!269 !270 # define DIM_4d271 # define ROUTINE_NFD lbc_nfd_nogather_4d_dp272 # include "lbc_nfd_nogather_generic.h90"273 # undef ROUTINE_NFD274 !# define MULTI275 !# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr276 !# include "lbc_nfd_nogather_generic.h90"277 !# undef ROUTINE_NFD278 !# undef MULTI279 # undef DIM_4d280 281 91 !!---------------------------------------------------------------------- 282 283 92 !! *** routine mpp_nfd_[sd]p *** 93 !! 94 !! * Argument : dummy argument use in mpp_nfd_... routines 95 !! ptab : pointer of arrays on which the boundary condition is applied 96 !! cd_nat : nature of array grid-points 97 !! psgn : sign used across the north fold boundary 98 !! kfld : optional, number of pt3d arrays 99 !! kfillmode : optional, method to be use to fill the halos (see jpfill* variables) 100 !! pfillval : optional, background value (used with jpfillcopy) 101 !!---------------------------------------------------------------------- 102 !! 103 !! ---- SINGLE PRECISION VERSIONS 104 !! 105 #define PRECISION sp 106 # define MPI_TYPE MPI_REAL 107 # include "mpp_nfd_generic.h90" 108 # undef MPI_TYPE 109 #undef PRECISION 110 !! 111 !! ---- DOUBLE PRECISION VERSIONS 112 !! 113 #define PRECISION dp 114 # define MPI_TYPE MPI_DOUBLE_PRECISION 115 # include "mpp_nfd_generic.h90" 116 # undef MPI_TYPE 117 #undef PRECISION 284 118 285 119 !!====================================================================== -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/lib_mpp.F90
r14354 r14448 55 55 USE dom_oce ! ocean space and time domain 56 56 USE in_out_manager ! I/O manager 57 #if ! defined key_mpi_off 58 USE MPI 59 #endif 57 60 58 61 IMPLICIT NONE … … 107 110 END INTERFACE 108 111 112 TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (used in lbclnk and lbcnfd) 113 REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d 114 END TYPE PTR_4D_sp 115 116 TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (used in lbclnk and lbcnfd) 117 REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d 118 END TYPE PTR_4D_dp 119 109 120 !! ========================= !! 110 121 !! MPI variable definition !! 111 122 !! ========================= !! 112 123 #if ! defined key_mpi_off 113 !$AGRIF_DO_NOT_TREAT114 INCLUDE 'mpif.h'115 !$AGRIF_END_DO_NOT_TREAT116 124 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag 117 125 #else … … 130 138 INTEGER :: MPI_SUMDD 131 139 140 ! Neighbourgs informations 141 INTEGER, PARAMETER, PUBLIC :: n_hlsmax = 3 142 INTEGER, DIMENSION( 8), PUBLIC :: mpinei !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg) 143 INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiSnei !: 8-neighbourg Send MPI indexes (starting at 0, -1 if no neighbourg) 144 INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiRnei !: 8-neighbourg Recv MPI indexes (starting at 0, -1 if no neighbourg) 145 INTEGER, PARAMETER, PUBLIC :: jpwe = 1 !: WEst 146 INTEGER, PARAMETER, PUBLIC :: jpea = 2 !: EAst 147 INTEGER, PARAMETER, PUBLIC :: jpso = 3 !: SOuth 148 INTEGER, PARAMETER, PUBLIC :: jpno = 4 !: NOrth 149 INTEGER, PARAMETER, PUBLIC :: jpsw = 5 !: South-West 150 INTEGER, PARAMETER, PUBLIC :: jpse = 6 !: South-East 151 INTEGER, PARAMETER, PUBLIC :: jpnw = 7 !: North-West 152 INTEGER, PARAMETER, PUBLIC :: jpne = 8 !: North-East 153 154 LOGICAL, DIMENSION(8), PUBLIC :: l_SelfPerio ! should we explicitely take care of I/J periodicity 155 LOGICAL, PUBLIC :: l_IdoNFold 156 132 157 ! variables used for zonal integration 133 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average134 LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row135 INTEGER :: ngrp_znl !group ID for the znl processors136 INTEGER :: ndim_rank_znl !number of processors on the same zonal average158 INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average 159 LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row 160 INTEGER :: ngrp_znl !: group ID for the znl processors 161 INTEGER :: ndim_rank_znl !: number of processors on the same zonal average 137 162 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain 138 163 139 164 ! variables used for MPI3 neighbourhood collectives 140 INTEGER, PUBLIC :: mpi_nc_com! MPI3 neighbourhood collectives communicator141 INTEGER, PUBLIC :: mpi_nc_all_com! MPI3 neighbourhood collectives communicator (with diagionals)165 INTEGER, DIMENSION(n_hlsmax), PUBLIC :: mpi_nc_com4 ! MPI3 neighbourhood collectives communicator 166 INTEGER, DIMENSION(n_hlsmax), PUBLIC :: mpi_nc_com8 ! MPI3 neighbourhood collectives communicator (with diagionals) 142 167 143 168 ! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM) … … 185 210 186 211 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms 187 LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms 212 INTEGER, PUBLIC :: nn_comm !: namelist control of comms 213 214 INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1 215 INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2 216 INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3 217 INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4 218 INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5 188 219 189 220 !! * Substitutions … … 263 294 INTEGER , INTENT(in ) :: kdest ! receive process number 264 295 INTEGER , INTENT(in ) :: ktyp ! tag of the message 265 INTEGER , INTENT(in 296 INTEGER , INTENT(inout) :: md_req ! argument for isend 266 297 !! 267 298 INTEGER :: iflag … … 292 323 INTEGER , INTENT(in ) :: kdest ! receive process number 293 324 INTEGER , INTENT(in ) :: ktyp ! tag of the message 294 INTEGER , INTENT(in 325 INTEGER , INTENT(inout) :: md_req ! argument for isend 295 326 !! 296 327 INTEGER :: iflag … … 315 346 INTEGER , INTENT(in ) :: kdest ! receive process number 316 347 INTEGER , INTENT(in ) :: ktyp ! tag of the message 317 INTEGER , INTENT(in 348 INTEGER , INTENT(inout) :: md_req ! argument for isend 318 349 !! 319 350 INTEGER :: iflag … … 942 973 LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number 943 974 LOGICAL :: ll_abort 944 INTEGER :: info 975 INTEGER :: info, ierr 945 976 !!---------------------------------------------------------------------- 946 977 ll_abort = .FALSE. … … 949 980 #if ! defined key_mpi_off 950 981 IF(ll_abort) THEN 951 CALL mpi_abort( MPI_COMM_WORLD )982 CALL mpi_abort( MPI_COMM_WORLD, 123, info ) 952 983 ELSE 953 984 CALL mppsync … … 962 993 SUBROUTINE mpp_comm_free( kcom ) 963 994 !!---------------------------------------------------------------------- 964 INTEGER, INTENT(in ) :: kcom995 INTEGER, INTENT(inout) :: kcom 965 996 !! 966 997 INTEGER :: ierr … … 1071 1102 END SUBROUTINE mpp_ini_znl 1072 1103 1073 SUBROUTINE mpp_ini_nc 1104 1105 SUBROUTINE mpp_ini_nc( khls ) 1074 1106 !!---------------------------------------------------------------------- 1075 1107 !! *** routine mpp_ini_nc *** … … 1082 1114 ! 1083 1115 !! ** output 1084 !! mpi_nc_com = MPI3 neighbourhood collectives communicator 1085 !! mpi_nc_all_com = MPI3 neighbourhood collectives communicator 1086 !! (with diagonals) 1087 !! 1088 !!---------------------------------------------------------------------- 1089 INTEGER, DIMENSION(:), ALLOCATABLE :: ineigh, ineighalls, ineighallr 1090 INTEGER :: ideg, idegalls, idegallr, icont, icont1 1091 INTEGER :: ierr 1092 LOGICAL, PARAMETER :: ireord = .FALSE. 1093 1094 #if ! defined key_mpi_off 1095 1096 ideg = 0 1097 idegalls = 0 1098 idegallr = 0 1099 icont = 0 1100 icont1 = 0 1101 1102 IF (nbondi .eq. 1) THEN 1103 ideg = ideg + 1 1104 ELSEIF (nbondi .eq. -1) THEN 1105 ideg = ideg + 1 1106 ELSEIF (nbondi .eq. 0) THEN 1107 ideg = ideg + 2 1108 ENDIF 1109 1110 IF (nbondj .eq. 1) THEN 1111 ideg = ideg + 1 1112 ELSEIF (nbondj .eq. -1) THEN 1113 ideg = ideg + 1 1114 ELSEIF (nbondj .eq. 0) THEN 1115 ideg = ideg + 2 1116 ENDIF 1117 1118 idegalls = ideg 1119 idegallr = ideg 1120 1121 IF (nones .ne. -1) idegalls = idegalls + 1 1122 IF (nonws .ne. -1) idegalls = idegalls + 1 1123 IF (noses .ne. -1) idegalls = idegalls + 1 1124 IF (nosws .ne. -1) idegalls = idegalls + 1 1125 IF (noner .ne. -1) idegallr = idegallr + 1 1126 IF (nonwr .ne. -1) idegallr = idegallr + 1 1127 IF (noser .ne. -1) idegallr = idegallr + 1 1128 IF (noswr .ne. -1) idegallr = idegallr + 1 1129 1130 ALLOCATE(ineigh(ideg)) 1131 ALLOCATE(ineighalls(idegalls)) 1132 ALLOCATE(ineighallr(idegallr)) 1133 1134 IF (nbondi .eq. 1) THEN 1135 icont = icont + 1 1136 ineigh(icont) = nowe 1137 ineighalls(icont) = nowe 1138 ineighallr(icont) = nowe 1139 ELSEIF (nbondi .eq. -1) THEN 1140 icont = icont + 1 1141 ineigh(icont) = noea 1142 ineighalls(icont) = noea 1143 ineighallr(icont) = noea 1144 ELSEIF (nbondi .eq. 0) THEN 1145 icont = icont + 1 1146 ineigh(icont) = nowe 1147 ineighalls(icont) = nowe 1148 ineighallr(icont) = nowe 1149 icont = icont + 1 1150 ineigh(icont) = noea 1151 ineighalls(icont) = noea 1152 ineighallr(icont) = noea 1153 ENDIF 1154 1155 IF (nbondj .eq. 1) THEN 1156 icont = icont + 1 1157 ineigh(icont) = noso 1158 ineighalls(icont) = noso 1159 ineighallr(icont) = noso 1160 ELSEIF (nbondj .eq. -1) THEN 1161 icont = icont + 1 1162 ineigh(icont) = nono 1163 ineighalls(icont) = nono 1164 ineighallr(icont) = nono 1165 ELSEIF (nbondj .eq. 0) THEN 1166 icont = icont + 1 1167 ineigh(icont) = noso 1168 ineighalls(icont) = noso 1169 ineighallr(icont) = noso 1170 icont = icont + 1 1171 ineigh(icont) = nono 1172 ineighalls(icont) = nono 1173 ineighallr(icont) = nono 1174 ENDIF 1175 1176 icont1 = icont 1177 IF (nosws .ne. -1) THEN 1178 icont = icont + 1 1179 ineighalls(icont) = nosws 1180 ENDIF 1181 IF (noses .ne. -1) THEN 1182 icont = icont + 1 1183 ineighalls(icont) = noses 1184 ENDIF 1185 IF (nonws .ne. -1) THEN 1186 icont = icont + 1 1187 ineighalls(icont) = nonws 1188 ENDIF 1189 IF (nones .ne. -1) THEN 1190 icont = icont + 1 1191 ineighalls(icont) = nones 1192 ENDIF 1193 IF (noswr .ne. -1) THEN 1194 icont1 = icont1 + 1 1195 ineighallr(icont1) = noswr 1196 ENDIF 1197 IF (noser .ne. -1) THEN 1198 icont1 = icont1 + 1 1199 ineighallr(icont1) = noser 1200 ENDIF 1201 IF (nonwr .ne. -1) THEN 1202 icont1 = icont1 + 1 1203 ineighallr(icont1) = nonwr 1204 ENDIF 1205 IF (noner .ne. -1) THEN 1206 icont1 = icont1 + 1 1207 ineighallr(icont1) = noner 1208 ENDIF 1209 1210 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, ideg, ineigh, MPI_UNWEIGHTED, ideg, ineigh, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_com, ierr) 1211 CALL MPI_Dist_graph_create_adjacent(mpi_comm_oce, idegallr, ineighallr, MPI_UNWEIGHTED, idegalls, ineighalls, MPI_UNWEIGHTED, MPI_INFO_NULL, ireord, mpi_nc_all_com, ierr) 1212 1213 DEALLOCATE (ineigh) 1214 DEALLOCATE (ineighalls) 1215 DEALLOCATE (ineighallr) 1116 !! mpi_nc_com4 = MPI3 neighbourhood collectives communicator 1117 !! mpi_nc_com8 = MPI3 neighbourhood collectives communicator (with diagonals) 1118 !!---------------------------------------------------------------------- 1119 INTEGER, INTENT(in ) :: khls ! halo size, default = nn_hls 1120 ! 1121 INTEGER, DIMENSION(:), ALLOCATABLE :: iSnei4, iRnei4, iSnei8, iRnei8 1122 INTEGER :: iScnt4, iRcnt4, iScnt8, iRcnt8 1123 INTEGER :: ierr 1124 LOGICAL, PARAMETER :: ireord = .FALSE. 1125 !!---------------------------------------------------------------------- 1126 #if ! defined key_mpi_off && ! defined key_mpi2 1127 1128 iScnt4 = COUNT( mpiSnei(khls,1:4) >= 0 ) 1129 iRcnt4 = COUNT( mpiRnei(khls,1:4) >= 0 ) 1130 iScnt8 = COUNT( mpiSnei(khls,1:8) >= 0 ) 1131 iRcnt8 = COUNT( mpiRnei(khls,1:8) >= 0 ) 1132 1133 ALLOCATE( iSnei4(iScnt4), iRnei4(iRcnt4), iSnei8(iScnt8), iRnei8(iRcnt8) ) ! ok if icnt4 or icnt8 = 0 1134 1135 iSnei4 = PACK( mpiSnei(khls,1:4), mask = mpiSnei(khls,1:4) >= 0 ) 1136 iRnei4 = PACK( mpiRnei(khls,1:4), mask = mpiRnei(khls,1:4) >= 0 ) 1137 iSnei8 = PACK( mpiSnei(khls,1:8), mask = mpiSnei(khls,1:8) >= 0 ) 1138 iRnei8 = PACK( mpiRnei(khls,1:8), mask = mpiRnei(khls,1:8) >= 0 ) 1139 1140 CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt4, iSnei4, MPI_UNWEIGHTED, iRcnt4, iRnei4, MPI_UNWEIGHTED, & 1141 & MPI_INFO_NULL, ireord, mpi_nc_com4(khls), ierr ) 1142 CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt8, iSnei8, MPI_UNWEIGHTED, iRcnt8, iRnei8, MPI_UNWEIGHTED, & 1143 & MPI_INFO_NULL, ireord, mpi_nc_com8(khls), ierr) 1144 1145 DEALLOCATE( iSnei4, iRnei4, iSnei8, iRnei8 ) 1216 1146 #endif 1217 1147 END SUBROUTINE mpp_ini_nc 1218 1219 1148 1220 1149 … … 1232 1161 !! 1233 1162 !! ** output 1234 !! njmppmax = njmpp for northern procs1235 1163 !! ndim_rank_north = number of processors in the northern line 1236 1164 !! nrank_north (ndim_rank_north) = number of the northern procs. … … 1247 1175 ! 1248 1176 #if ! defined key_mpi_off 1249 njmppmax = MAXVAL( njmppt )1250 1177 ! 1251 1178 ! Look for how many procs on the northern boundary -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/mpp_lbc_north_icb_generic.h90
r14229 r14448 31 31 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 32 32 ! ! = T , U , V , F or W -points 33 REAL( wp), INTENT(in ) :: psgn ! = -1. the sign change across the33 REAL(PRECISION) , INTENT(in ) :: psgn ! = -1. the sign change across the 34 34 !! ! north fold, = 1. otherwise 35 35 INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/mpp_lnk_icb_generic.h90
r13286 r14448 24 24 !! jpi : first dimension of the local subdomain 25 25 !! jpj : second dimension of the local subdomain 26 !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 26 27 !! kexti : number of columns for extra outer halo 27 28 !! kextj : number of rows for extra outer halo 28 !! nbondi : mark for "east-west local boundary"29 !! nbondj : mark for "north-south local boundary"30 !! noea : number for local neighboring processors31 !! nowe : number for local neighboring processors32 !! noso : number for local neighboring processors33 !! nono : number for local neighboring processors34 29 !!---------------------------------------------------------------------- 35 30 CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine 36 31 REAL(PRECISION), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo 37 32 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 38 REAL( wp), INTENT(in ) :: psgn ! sign used across the north fold33 REAL(PRECISION) , INTENT(in ) :: psgn ! sign used across the north fold 39 34 INTEGER , INTENT(in ) :: kexti ! extra i-halo width 40 35 INTEGER , INTENT(in ) :: kextj ! extra j-halo width … … 90 85 ! north fold treatment 91 86 ! ----------------------- 92 IF( npolj /= 0) THEN87 IF( l_IdoNFold ) THEN 93 88 ! 94 89 SELECT CASE ( jpni ) … … 103 98 ! we play with the neigbours AND the row number because of the periodicity 104 99 ! 105 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 106 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 100 IF( mpinei(jpwe) >= 0 .OR. mpinei(jpea) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) 107 101 iihom = jpi - (2 * nn_hls) -kexti 108 102 DO jl = 1, ipreci … … 110 104 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 111 105 END DO 112 END SELECT106 ENDIF 113 107 ! 114 108 ! ! Migrations … … 120 114 IF( ln_timing ) CALL tic_tac(.TRUE.) 121 115 ! 122 SELECT CASE ( nbondi ) 123 CASE ( -1 ) 124 CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) 125 CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea ) 126 CALL mpi_wait(ml_req1,ml_stat,ml_err) 127 CASE ( 0 ) 128 CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 129 CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) 130 CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, noea ) 131 CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 132 CALL mpi_wait(ml_req1,ml_stat,ml_err) 133 CALL mpi_wait(ml_req2,ml_stat,ml_err) 134 CASE ( 1 ) 135 CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) 136 CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, nowe ) 137 CALL mpi_wait(ml_req1,ml_stat,ml_err) 138 END SELECT 116 IF( mpinei(jpwe) >= 0 ) CALL SENDROUTINE( 1, r2dew(1-kextj,1,1), imigr, mpinei(jpwe), ml_req1 ) 117 IF( mpinei(jpea) >= 0 ) CALL SENDROUTINE( 2, r2dwe(1-kextj,1,1), imigr, mpinei(jpea), ml_req2 ) 118 IF( mpinei(jpwe) >= 0 ) CALL RECVROUTINE( 2, r2dwe(1-kextj,1,2), imigr, mpinei(jpwe) ) 119 IF( mpinei(jpea) >= 0 ) CALL RECVROUTINE( 1, r2dew(1-kextj,1,2), imigr, mpinei(jpea) ) 120 IF( mpinei(jpwe) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) 121 IF( mpinei(jpea) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) 139 122 ! 140 123 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 142 125 ! ! Write Dirichlet lateral conditions 143 126 iihom = jpi - nn_hls 144 ! 145 SELECT CASE ( nbondi ) 146 CASE ( -1 ) 127 IF( mpinei(jpwe) >= 0 ) THEN 128 DO jl = 1, ipreci 129 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 130 END DO 131 ENDIF 132 IF( mpinei(jpea) >= 0 ) THEN 147 133 DO jl = 1, ipreci 148 134 pt2d(iihom+jl,:) = r2dew(:,jl,2) 149 135 END DO 150 CASE ( 0 ) 151 DO jl = 1, ipreci 152 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 153 pt2d(iihom+jl,:) = r2dew(:,jl,2) 154 END DO 155 CASE ( 1 ) 156 DO jl = 1, ipreci 157 pt2d(jl-kexti,:) = r2dwe(:,jl,2) 158 END DO 159 END SELECT 160 136 ENDIF 161 137 162 138 ! 3. North and south directions … … 164 140 ! always closed : we play only with the neigbours 165 141 ! 166 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions142 IF( mpinei(jpso) >= 0 .OR. mpinei(jpno) >= 0 ) THEN ! Read Dirichlet lateral conditions: all exept 2 (i.e. close case) 167 143 ijhom = jpj - (2 * nn_hls) - kextj 168 144 DO jl = 1, iprecj … … 177 153 IF( ln_timing ) CALL tic_tac(.TRUE.) 178 154 ! 179 SELECT CASE ( nbondj ) 180 CASE ( -1 ) 181 CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) 182 CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono ) 183 CALL mpi_wait(ml_req1,ml_stat,ml_err) 184 CASE ( 0 ) 185 CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 186 CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) 187 CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, nono ) 188 CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso ) 189 CALL mpi_wait(ml_req1,ml_stat,ml_err) 190 CALL mpi_wait(ml_req2,ml_stat,ml_err) 191 CASE ( 1 ) 192 CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) 193 CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, noso ) 194 CALL mpi_wait(ml_req1,ml_stat,ml_err) 195 END SELECT 155 IF( mpinei(jpso) >= 0 ) CALL SENDROUTINE( 3, r2dns(1-kexti,1,1), imigr, mpinei(jpso), ml_req1 ) 156 IF( mpinei(jpno) >= 0 ) CALL SENDROUTINE( 4, r2dsn(1-kexti,1,1), imigr, mpinei(jpno), ml_req2 ) 157 IF( mpinei(jpso) >= 0 ) CALL RECVROUTINE( 4, r2dsn(1-kexti,1,2), imigr, mpinei(jpso) ) 158 IF( mpinei(jpno) >= 0 ) CALL RECVROUTINE( 3, r2dns(1-kexti,1,2), imigr, mpinei(jpno) ) 159 IF( mpinei(jpso) >= 0 ) CALL mpi_wait(ml_req1,ml_stat,ml_err) 160 IF( mpinei(jpno) >= 0 ) CALL mpi_wait(ml_req2,ml_stat,ml_err) 196 161 ! 197 162 IF( ln_timing ) CALL tic_tac(.FALSE.) … … 200 165 ijhom = jpj - nn_hls 201 166 ! 202 SELECT CASE ( nbondj ) 203 CASE ( -1 ) 204 DO jl = 1, iprecj 205 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 206 END DO 207 CASE ( 0 ) 208 DO jl = 1, iprecj 209 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 210 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 211 END DO 212 CASE ( 1 ) 167 IF( mpinei(jpso) >= 0 ) THEN 213 168 DO jl = 1, iprecj 214 169 pt2d(:,jl-kextj) = r2dsn(:,jl,2) 215 170 END DO 216 END SELECT 171 ENDIF 172 IF( mpinei(jpno) >= 0 ) THEN 173 DO jl = 1, iprecj 174 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 175 END DO 176 ENDIF 217 177 ! 218 178 END SUBROUTINE ROUTINE_LNK -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/mpp_nfd_generic.h90
r14229 r14448 1 #if defined MULTI2 # define NAT_IN(k) cd_nat(k)3 # define SGN_IN(k) psgn(k)4 # define F_SIZE(ptab) kfld5 # define LBC_ARG (jf)6 # if defined DIM_2d7 # if defined SINGLE_PRECISION8 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_sp) , INTENT(inout) :: ptab(f)9 # else10 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D_dp) , INTENT(inout) :: ptab(f)11 # endif12 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j)13 # define K_SIZE(ptab) 114 # define L_SIZE(ptab) 115 # endif16 # if defined DIM_3d17 # if defined SINGLE_PRECISION18 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_sp) , INTENT(inout) :: ptab(f)19 # else20 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D_dp) , INTENT(inout) :: ptab(f)21 # endif22 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k)23 # define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3)24 # define L_SIZE(ptab) 125 # endif26 # if defined DIM_4d27 # if defined SINGLE_PRECISION28 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_sp) , INTENT(inout) :: ptab(f)29 # else30 # define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D_dp) , INTENT(inout) :: ptab(f)31 # endif32 # define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l)33 # define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3)34 # define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4)35 # endif36 #else37 ! !== IN: ptab is an array ==!38 # if defined SINGLE_PRECISION39 # define ARRAY_TYPE(i,j,k,l,f) REAL(sp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)40 # else41 # define ARRAY_TYPE(i,j,k,l,f) REAL(dp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f)42 # endif43 # define NAT_IN(k) cd_nat44 # define SGN_IN(k) psgn45 # define F_SIZE(ptab) 146 # define LBC_ARG47 # if defined DIM_2d48 # define ARRAY_IN(i,j,k,l,f) ptab(i,j)49 # define K_SIZE(ptab) 150 # define L_SIZE(ptab) 151 # endif52 # if defined DIM_3d53 # 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) 156 # endif57 # if defined DIM_4d58 # 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 # endif62 #endif63 1 64 # if defined SINGLE_PRECISION 65 # define PRECISION sp 66 # define SENDROUTINE mppsend_sp 67 # define RECVROUTINE mpprecv_sp 68 # define MPI_TYPE MPI_REAL 69 # define HUGEVAL(x) HUGE(x/**/_sp) 70 # else 71 # define PRECISION dp 72 # define SENDROUTINE mppsend_dp 73 # define RECVROUTINE mpprecv_dp 74 # define MPI_TYPE MPI_DOUBLE_PRECISION 75 # define HUGEVAL(x) HUGE(x/**/_dp) 76 # endif 77 78 SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfillmode, pfillval, kfld ) 79 !!---------------------------------------------------------------------- 80 ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied 81 CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points 82 REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary 83 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 84 REAL(wp) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 85 INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays 2 SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld ) 3 TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. 4 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points 5 REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary 6 INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land 7 REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries) 8 INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls 9 INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays 86 10 ! 87 11 LOGICAL :: ll_add_line … … 95 19 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather 96 20 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 97 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather98 21 ! ! Workspace for message transfers avoiding mpi_allgather 99 22 INTEGER :: ipj_b ! sum of lines for all multi fields … … 103 26 INTEGER , DIMENSION(:) , ALLOCATABLE :: ipj_s ! number of sent lines 104 27 REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: ztabb, ztabr, ztabw ! buffer, receive and work arrays 105 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: z tabglo, znorthloc28 REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc 106 29 REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo 30 TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c. 107 31 !!---------------------------------------------------------------------- 108 32 ! 109 ipk = K_SIZE(ptab) ! 3rd dimension110 ipl = L_SIZE(ptab) ! 4th -111 ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers)33 ipk = SIZE(ptab(1)%pt4d,3) 34 ipl = SIZE(ptab(1)%pt4d,4) 35 ipf = kfld 112 36 ! 113 IF( l _north_nogather ) THEN !== no allgather exchanges ==!37 IF( ln_nnogather ) THEN !== no allgather exchanges ==! 114 38 115 39 ! --- define number of exchanged lines --- … … 118 42 ! 119 43 ! However, some other points are duplicated in the north pole folding: 120 ! - jperio=[34], grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls)121 ! - jperio=[34], grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls)122 ! - jperio=[34], grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls)123 ! - jperio=[34], grid=F : all the last line (nn_hls+1:jpiglo-nn_hls)124 ! - jperio=[56], grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls)125 ! - jperio=[56], grid=U : no points are duplicated126 ! - jperio=[56], grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls)127 ! - jperio=[56], grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1)44 ! - c_NFtype='T', grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls) 45 ! - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 46 ! - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls) 47 ! - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls) 48 ! - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls) 49 ! - c_NFtype='F', grid=U : no points are duplicated 50 ! - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls) 51 ! - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1) 128 52 ! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1) 129 53 ! This explain why these duplicated points may have different values even if they are at the exact same location. … … 141 65 IF( ll_add_line ) THEN 142 66 DO jf = 1, ipf ! Loop over the number of arrays to be processed 143 ipj_s(jf) = nn_hls + COUNT( (/ npolj == 3 .OR. npolj == 4 .OR. NAT_IN(jf) == 'V' .OR. NAT_IN(jf) == 'F' /) )67 ipj_s(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) 144 68 END DO 145 69 ELSE 146 ipj_s(:) = nn_hls70 ipj_s(:) = khls 147 71 ENDIF 148 72 … … 155 79 DO jf = 1, ipf ! Loop over the number of arrays to be processed 156 80 ! 157 SELECT CASE ( npolj ) 158 CASE ( 3, 4 ) ! * North fold T-point pivot 159 SELECT CASE ( NAT_IN(jf) ) 81 IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot 82 SELECT CASE ( cd_nat(jf) ) 160 83 CASE ( 'T', 'W', 'U' ) ; i012 = 1 ! T-, U-, W-point 161 84 CASE ( 'V', 'F' ) ; i012 = 2 ! V-, F-point 162 85 END SELECT 163 CASE ( 5, 6 ) ! * North fold F-point pivot 164 SELECT CASE ( NAT_IN(jf) ) 86 ENDIF 87 IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot 88 SELECT CASE ( cd_nat(jf) ) 165 89 CASE ( 'T', 'W', 'U' ) ; i012 = 0 ! T-, U-, W-point 166 90 CASE ( 'V', 'F' ) ; i012 = 1 ! V-, F-point 167 91 END SELECT 168 END SELECT92 ENDIF 169 93 ! 170 94 DO jj = 1, ipj_s(jf) 171 95 ij1 = ij1 + 1 172 96 jj_b(jj,jf) = ij1 173 jj_s(jj,jf) = jpj - 2* nn_hls + jj - i01297 jj_s(jj,jf) = jpj - 2*khls + jj - i012 174 98 END DO 175 99 ! … … 184 108 ij2 = jj_s(jj,jf) 185 109 DO ji = 1, jpi 186 ztabb(ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf)110 ztabb(ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 187 111 END DO 188 112 DO ji = jpi+1, jpimax 189 ztabb(ji,ij1,jk,jl) = HUGE VAL(0.) ! avoid sending uninitialized values (make sure we don't use it)113 ztabb(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it) 190 114 END DO 191 115 END DO … … 199 123 iproc = nfproc(isendto(jr)) 200 124 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 201 CALL SENDROUTINE( 5, ztabb, ibuffsize, iproc, ml_req_nf(jr) ) 125 #if ! defined key_mpi_off 126 CALL MPI_ISEND( ztabb, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ml_req_nf(jr), ierr ) 127 #endif 202 128 ENDIF 203 129 END DO … … 212 138 ipi = nfjpi (ipni) 213 139 ! 214 IF( ipni == 1 ) THEN ; iis0 = 1 215 ELSE ; iis0 = 1 + nn_hls ! default: -> from inner domain216 ENDIF 217 IF( ipni == jpni ) THEN ; iie0 = ipi 218 ELSE ; iie0 = ipi - nn_hls ! default: -> until inner domain140 IF( ipni == 1 ) THEN ; iis0 = 1 ! domain left side: as e-w comm already done -> from 1st column 141 ELSE ; iis0 = 1 + khls ! default: -> from inner domain 142 ENDIF 143 IF( ipni == jpni ) THEN ; iie0 = ipi ! domain right side: as e-w comm already done -> until last column 144 ELSE ; iie0 = ipi - khls ! default: -> until inner domain 219 145 ENDIF 220 146 impp = nfimpp(ipni) - nfimpp(isendto(1)) … … 230 156 ij2 = jj_s(jj,jf) 231 157 DO ji = iis0, iie0 232 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point158 ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st iner domain point 233 159 END DO 234 160 END DO … … 251 177 ij2 = jj_s(jj,jf) 252 178 DO ji = iis0, iie0 253 ztabr(impp+ji,ij1,jk,jl) = ARRAY_IN(ji,ij2,jk,jl,jf)179 ztabr(impp+ji,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl) 254 180 END DO 255 181 END DO … … 258 184 ELSE ! get data from a neighbour trough communication 259 185 ! 260 CALL RECVROUTINE(5, ztabw, ibuffsize, iproc) 186 #if ! defined key_mpi_off 187 CALL MPI_RECV( ztabw, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, MPI_STATUS_IGNORE, ierr ) 188 #endif 261 189 DO jl = 1, ipl ; DO jk = 1, ipk 262 190 DO jj = 1, ipj_b … … 278 206 ij1 = jj_b( 1 ,jf) 279 207 ij2 = jj_b(ipj_s(jf),jf) 280 CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,ij1:ij2,:,:), cd_nat LBC_ARG, psgn LBC_ARG)208 CALL lbc_nfd_nogather( ptab(jf)%pt4d(:,:,:,:), ztabr(:,ij1:ij2,:,:), cd_nat(jf), psgn(jf), khls ) 281 209 END DO 282 210 ! … … 286 214 iproc = nfproc(isendto(jr)) 287 215 IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN 288 CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) ! put the wait at the very end just before the deallocate216 CALL mpi_wait( ml_req_nf(jr), MPI_STATUS_IGNORE, ml_err ) ! put the wait at the very end just before the deallocate 289 217 ENDIF 290 218 END DO … … 294 222 ! 295 223 ! how many lines do we exchange at max? -> ipj (no further optimizations in this case...) 296 ipj = nn_hls + 2224 ipj = khls + 2 297 225 ! how many lines do we need at max? -> ipj2 (no further optimizations in this case...) 298 ipj2 = 2 * nn_hls + 2299 ! 300 i0max = jpimax - 2 * nn_hls226 ipj2 = 2 * khls + 2 227 ! 228 i0max = jpimax - 2 * khls 301 229 ibuffsize = i0max * ipj * ipk * ipl * ipf 302 230 ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) ) … … 307 235 DO ji = 1, Ni_0 308 236 ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0 309 znorthloc(ji,jj,jk,jl,jf) = ARRAY_IN(ii2,ij2,jk,jl,jf)237 znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl) 310 238 END DO 311 239 DO ji = Ni_0+1, i0max 312 znorthloc(ji,jj,jk,jl,jf) = HUGE VAL(0.) ! avoid sending uninitialized values (make sure we don't use it)240 znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it) 313 241 END DO 314 242 END DO … … 323 251 IF( ln_timing ) CALL tic_tac(.FALSE.) 324 252 DEALLOCATE( znorthloc ) 325 ALLOCATE( ztabglo(jpiglo,ipj2,ipk,ipl,ipf) ) 326 ! 327 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last nn_hls lines 253 ALLOCATE( ztabglo(ipf) ) 254 DO jf = 1, ipf 255 ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) ) 256 END DO 257 ! 258 ! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines 328 259 ijnr = 0 329 260 DO jr = 1, jpni ! recover the global north array 330 261 iproc = nfproc(jr) 331 262 impp = nfimpp(jr) 332 ipi = nfjpi( jr) - 2 * nn_hls ! corresponds to Ni_0 but for subdomain iproc263 ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc 333 264 IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed) 334 265 ! … … 340 271 ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines 341 272 DO ji = 1, ipi 342 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc343 ztabglo( ii1,jj,jk,jl,jf) = ARRAY_IN(Nis0,ij2,jk,jl,jf) ! chose to take the 1st iner domain point273 ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc 274 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point 344 275 END DO 345 276 END DO … … 349 280 DO jj = 1, ipj 350 281 DO ji = 1, ipi 351 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc352 ztabglo( ii1,jj,jk,jl,jf) = pfillval282 ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc 283 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval 353 284 END DO 354 285 END DO … … 361 292 DO jj = 1, ipj 362 293 DO ji = 1, ipi 363 ii1 = impp + nn_hls + ji - 1 ! corresponds to mig(nn_hls + ji) but for subdomain iproc364 ztabglo( ii1,jj,jk,jl,jf) = znorthglo(ji,jj,jk,jl,jf,ijnr)294 ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc 295 ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr) 365 296 END DO 366 297 END DO … … 372 303 ! 373 304 DO jf = 1, ipf 374 CALL lbc_nfd( ztabglo( :,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG) ! North fold boundary condition305 CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition 375 306 DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity 376 DO jj = 1, nn_hls + 1377 ij1 = ipj2 - ( nn_hls + 1) + jj ! need only the last nn_hls + 1 lines until ipj2378 ztabglo( 1:nn_hls,ij1,jk,jl,jf) = ztabglo(jpiglo-2*nn_hls+1:jpiglo-nn_hls,ij1,jk,jl,jf)379 ztabglo(j piglo-nn_hls+1:jpiglo,ij1,jk,jl,jf) = ztabglo( nn_hls+1: 2*nn_hls,ij1,jk,jl,jf)307 DO jj = 1, khls + 1 308 ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2 309 ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl) 310 ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl) 380 311 END DO 381 312 END DO ; END DO … … 383 314 ! 384 315 DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN 385 DO jj = 1, nn_hls + 1386 ij1 = jpj - ( nn_hls + 1) + jj ! last nn_hls + 1 lines until jpj387 ij2 = ipj2 - ( nn_hls + 1) + jj ! last nn_hls + 1 lines until ipj2316 DO jj = 1, khls + 1 317 ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj 318 ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2 388 319 DO ji= 1, jpi 389 320 ii2 = mig(ji) 390 ARRAY_IN(ji,ij1,jk,jl,jf) = ztabglo(ii2,ij2,jk,jl,jf)321 ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl) 391 322 END DO 392 323 END DO 393 324 END DO ; END DO ; END DO 394 325 ! 326 DO jf = 1, ipf 327 DEALLOCATE( ztabglo(jf)%pt4d ) 328 END DO 395 329 DEALLOCATE( ztabglo ) 396 330 ! 397 331 ENDIF ! l_north_nogather 398 332 ! 399 END SUBROUTINE ROUTINE_NFD333 END SUBROUTINE mpp_nfd_/**/PRECISION 400 334 401 #undef PRECISION402 #undef MPI_TYPE403 #undef SENDROUTINE404 #undef RECVROUTINE405 #undef ARRAY_TYPE406 #undef NAT_IN407 #undef SGN_IN408 #undef ARRAY_IN409 #undef K_SIZE410 #undef L_SIZE411 #undef F_SIZE412 #undef LBC_ARG413 #undef HUGEVAL -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LBC/mppini.F90
r14275 r14448 69 69 jpi = jpiglo 70 70 jpj = jpjglo 71 jpk = jpkglo 72 jpim1 = jpi-1 ! inner domain indices 73 jpjm1 = jpj-1 ! " " 74 jpkm1 = MAX( 1, jpk-1 ) ! " " 71 jpk = MAX( 2, jpkglo ) 75 72 jpij = jpi*jpj 76 73 jpni = 1 … … 79 76 nimpp = 1 80 77 njmpp = 1 81 nbondi = 282 nbondj = 283 78 nidom = FLIO_DOM_NONE 84 npolj = 085 IF( jperio == 3 .OR. jperio == 4 ) npolj = 386 IF( jperio == 5 .OR. jperio == 6 ) npolj = 587 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7)88 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7)89 79 ! 90 80 CALL init_doloop ! set start/end indices or do-loop depending on the halo width value (nn_hls) … … 95 85 WRITE(numout,*) '~~~~~~~~ ' 96 86 WRITE(numout,*) ' l_Iperio = ', l_Iperio, ' l_Jperio = ', l_Jperio 97 WRITE(numout,*) ' n polj = ', npolj , ' njmpp = ', njmpp87 WRITE(numout,*) ' njmpp = ', njmpp 98 88 ENDIF 99 89 ! … … 123 113 !! ** Method : Global domain is distributed in smaller local domains. 124 114 !! Periodic condition is a function of the local domain position 125 !! (global boundary or neighbouring domain) and of the global 126 !! periodic 127 !! Type : jperio global periodic condition 115 !! (global boundary or neighbouring domain) and of the global periodic 128 116 !! 129 117 !! ** Action : - set domain parameters … … 131 119 !! njmpp : latitudinal index 132 120 !! narea : number for local area 133 !! nbondi : mark for "east-west local boundary" 134 !! nbondj : mark for "north-south local boundary" 135 !! noea : number for local neighboring processor 136 !! nowe : number for local neighboring processor 137 !! noso : number for local neighboring processor 138 !! nono : number for local neighboring processor 139 !!---------------------------------------------------------------------- 140 INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices 141 INTEGER :: inijmin 142 INTEGER :: inum ! local logical unit 143 INTEGER :: idir, ifreq ! local integers 144 INTEGER :: ii, il1, ili, imil ! - - 145 INTEGER :: ij, il2, ilj, ijm1 ! - - 146 INTEGER :: iino, ijno, iiso, ijso ! - - 147 INTEGER :: iiea, ijea, iiwe, ijwe ! - - 148 INTEGER :: iarea0 ! - - 149 INTEGER :: ierr, ios ! 150 INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 121 !! mpinei : number of neighboring domains (starting at 0, -1 if no neighbourg) 122 !!---------------------------------------------------------------------- 123 INTEGER :: ji, jj, jn, jp, jh 124 INTEGER :: ii, ij, ii2, ij2 125 INTEGER :: inijmin ! number of oce subdomains 126 INTEGER :: inum, inum0 127 INTEGER :: ifreq, il1, imil, il2, ijm1 128 INTEGER :: ierr, ios 129 INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 130 INTEGER, DIMENSION(16*n_hlsmax) :: ichanged 131 INTEGER, ALLOCATABLE, DIMENSION(: ) :: iin, ijn 132 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: iimppt, ijpi, ipproc 133 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: ijmppt, ijpj 134 INTEGER, ALLOCATABLE, DIMENSION(:,: ) :: impi 135 INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: inei 151 136 LOGICAL :: llbest, llauto 152 137 LOGICAL :: llwrtlay 138 LOGICAL :: llmpi_Iperio, llmpi_Jperio, llmpiNFold 153 139 LOGICAL :: ln_listonly 154 INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace 155 INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - 156 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ijpi, ibondi, ipproc ! 2D workspace 157 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ijpj, ibondj, ipolj ! - - 158 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iie0, iis0, iono, ioea ! - - 159 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ije0, ijs0, ioso, iowe ! - - 160 LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - 140 LOGICAL, ALLOCATABLE, DIMENSION(:,: ) :: llisOce ! is not land-domain only? 141 LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: llnei ! are neighbourgs existing? 161 142 NAMELIST/nambdy/ ln_bdy, nb_bdy, ln_coords_file, cn_coords_file, & 162 143 & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & … … 165 146 & cn_ice, nn_ice_dta, & 166 147 & ln_vol, nn_volctl, nn_rimwidth 167 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 148 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly, nn_comm 168 149 !!---------------------------------------------------------------------- 169 150 ! … … 193 174 IF(lwm) WRITE( numond, nammpp ) 194 175 ! 195 !!!------------------------------------196 !!! nn_hls shloud be read in nammpp197 !!!------------------------------------198 176 jpiglo = Ni0glo + 2 * nn_hls 199 177 jpjglo = Nj0glo + 2 * nn_hls … … 213 191 ! ----------------------------------- 214 192 ! 215 ! If dimensions of processors grid weren't specified in the namelist file193 ! If dimensions of MPI processes grid weren't specified in the namelist file 216 194 ! then we calculate them here now that we have our communicator size 217 195 IF(lwp) THEN … … 260 238 261 239 ! look for land mpi subdomains... 262 ALLOCATE( llis oce(jpni,jpnj) )263 CALL mpp_is_ocean( llis oce )264 inijmin = COUNT( llis oce ) ! number of oce subdomains240 ALLOCATE( llisOce(jpni,jpnj) ) 241 CALL mpp_is_ocean( llisOce ) 242 inijmin = COUNT( llisOce ) ! number of oce subdomains 265 243 266 244 IF( mppsize < inijmin ) THEN ! too many oce subdomains: can happen only if jpni and jpnj are prescribed... … … 319 297 9003 FORMAT (a, i5) 320 298 321 ALLOCATE( nfimpp(jpni ) , nfproc(jpni ) , nfjpi(jpni ) , & 322 & nimppt(jpnij) , ibonit(jpnij) , jpiall(jpnij) , jpjall(jpnij) , & 323 & njmppt(jpnij) , ibonjt(jpnij) , nis0all(jpnij) , njs0all(jpnij) , & 324 & nie0all(jpnij) , nje0all(jpnij) , & 325 & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & 326 & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & 327 & iimppt(jpni,jpnj), ijpi(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & 328 & ijmppt(jpni,jpnj), ijpj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & 329 & iie0(jpni,jpnj), iis0(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & 330 & ije0(jpni,jpnj), ijs0(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & 331 & STAT=ierr ) 299 ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni), & 300 & iin(jpnij), ijn(jpnij), & 301 & iimppt(jpni,jpnj), ijmppt(jpni,jpnj), ijpi(jpni,jpnj), ijpj(jpni,jpnj), ipproc(jpni,jpnj), & 302 & inei(8,jpni,jpnj), llnei(8,jpni,jpnj), & 303 & impi(8,jpnij), & 304 & STAT=ierr ) 332 305 CALL mpp_sum( 'mppini', ierr ) 333 306 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' ) … … 343 316 ! 344 317 CALL mpp_basesplit( jpiglo, jpjglo, nn_hls, jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ijpi, ijpj ) 345 CALL mpp_getnum( llisoce, ipproc, iin, ijn ) 346 ! 347 !DO jn = 1, jpni 348 ! jproc = ipproc(jn,jpnj) 349 ! ii = iin(jproc+1) 350 ! ij = ijn(jproc+1) 351 ! nfproc(jn) = jproc 352 ! nfimpp(jn) = iimppt(ii,ij) 353 ! nfjpi (jn) = ijpi(ii,ij) 354 !END DO 355 nfproc(:) = ipproc(:,jpnj) 356 nfimpp(:) = iimppt(:,jpnj) 357 nfjpi (:) = ijpi(:,jpnj) 318 CALL mpp_getnum( llisOce, ipproc, iin, ijn ) 319 ! 320 ii = iin(narea) 321 ij = ijn(narea) 322 jpi = ijpi(ii,ij) 323 jpj = ijpj(ii,ij) 324 jpk = MAX( 2, jpkglo ) 325 jpij = jpi*jpj 326 nimpp = iimppt(ii,ij) 327 njmpp = ijmppt(ii,ij) 328 ! 329 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 358 330 ! 359 331 IF(lwp) THEN … … 365 337 WRITE(numout,*) ' jpnj = ', jpnj 366 338 WRITE(numout,*) ' jpnij = ', jpnij 339 WRITE(numout,*) ' nimpp = ', nimpp 340 WRITE(numout,*) ' njmpp = ', njmpp 367 341 WRITE(numout,*) 368 342 WRITE(numout,*) ' sum ijpi(i,1) = ', sum(ijpi(:,1)), ' jpiglo = ', jpiglo 369 WRITE(numout,*) ' sum ijpj(1,j) = ', sum(ijpj(1,:)), ' jpjglo = ', jpjglo 370 ENDIF 371 372 ! 3. Subdomain description in the Regular Case 373 ! -------------------------------------------- 374 ! specific cases where there is no communication -> must do the periodicity by itself 375 ! Warning: because of potential land-area suppression, do not use nbond[ij] == 2 376 l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) 377 l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) 378 379 DO jarea = 1, jpni*jpnj 380 ! 381 iarea0 = jarea - 1 382 ii = 1 + MOD(iarea0,jpni) 383 ij = 1 + iarea0/jpni 384 ili = ijpi(ii,ij) 385 ilj = ijpj(ii,ij) 386 ibondi(ii,ij) = 0 ! default: has e-w neighbours 387 IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour 388 IF( ii == jpni ) ibondi(ii,ij) = 1 ! last column, has only w neighbour 389 IF( jpni == 1 ) ibondi(ii,ij) = 2 ! has no e-w neighbour 390 ibondj(ii,ij) = 0 ! default: has n-s neighbours 391 IF( ij == 1 ) ibondj(ii,ij) = -1 ! first row, has only n neighbour 392 IF( ij == jpnj ) ibondj(ii,ij) = 1 ! last row, has only s neighbour 393 IF( jpnj == 1 ) ibondj(ii,ij) = 2 ! has no n-s neighbour 394 395 ! Subdomain neighbors (get their zone number): default definition 396 ioso(ii,ij) = iarea0 - jpni 397 iowe(ii,ij) = iarea0 - 1 398 ioea(ii,ij) = iarea0 + 1 399 iono(ii,ij) = iarea0 + jpni 400 iis0(ii,ij) = 1 + nn_hls 401 iie0(ii,ij) = ili - nn_hls 402 ijs0(ii,ij) = 1 + nn_hls 403 ije0(ii,ij) = ilj - nn_hls 404 405 ! East-West periodicity: change ibondi, ioea, iowe 406 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN 407 IF( jpni /= 1 ) ibondi(ii,ij) = 0 ! redefine: all have e-w neighbours 408 IF( ii == 1 ) iowe(ii,ij) = iarea0 + (jpni-1) ! redefine: first column, address of w neighbour 409 IF( ii == jpni ) ioea(ii,ij) = iarea0 - (jpni-1) ! redefine: last column, address of e neighbour 410 ENDIF 411 412 ! Simple North-South periodicity: change ibondj, ioso, iono 413 IF( jperio == 2 .OR. jperio == 7 ) THEN 414 IF( jpnj /= 1 ) ibondj(ii,ij) = 0 ! redefine: all have n-s neighbours 415 IF( ij == 1 ) ioso(ii,ij) = iarea0 + jpni * (jpnj-1) ! redefine: first row, address of s neighbour 416 IF( ij == jpnj ) iono(ii,ij) = iarea0 - jpni * (jpnj-1) ! redefine: last row, address of n neighbour 417 ENDIF 418 419 ! North fold: define ipolj, change iono. Warning: we do not change ibondj... 420 ipolj(ii,ij) = 0 421 IF( jperio == 3 .OR. jperio == 4 ) THEN 422 ijm1 = jpni*(jpnj-1) 423 imil = ijm1+(jpni+1)/2 424 IF( jarea > ijm1 ) ipolj(ii,ij) = 3 425 IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4 426 IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour 427 ENDIF 428 IF( jperio == 5 .OR. jperio == 6 ) THEN 429 ijm1 = jpni*(jpnj-1) 430 imil = ijm1+(jpni+1)/2 431 IF( jarea > ijm1) ipolj(ii,ij) = 5 432 IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6 433 IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour 434 ENDIF 435 ! 436 END DO 437 438 ! 4. deal with land subdomains 439 ! ---------------------------- 440 ! 441 ! neighbour treatment: change ibondi, ibondj if next to a land zone 442 DO jarea = 1, jpni*jpnj 443 ii = 1 + MOD( jarea-1 , jpni ) 444 ij = 1 + (jarea-1) / jpni 445 ! land-only area with an active n neigbour 446 IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN 447 iino = 1 + MOD( iono(ii,ij) , jpni ) ! ii index of this n neigbour 448 ijno = 1 + iono(ii,ij) / jpni ! ij index of this n neigbour 449 ! In case of north fold exchange: I am the n neigbour of my n neigbour!! (#1057) 450 ! --> for northern neighbours of northern row processors (in case of north-fold) 451 ! need to reverse the LOGICAL direction of communication 452 idir = 1 ! we are indeed the s neigbour of this n neigbour 453 IF( ij == jpnj .AND. ijno == jpnj ) idir = -1 ! both are on the last row, we are in fact the n neigbour 454 IF( ibondj(iino,ijno) == idir ) ibondj(iino,ijno) = 2 ! this n neigbour had only a s/n neigbour -> no more 455 IF( ibondj(iino,ijno) == 0 ) ibondj(iino,ijno) = -idir ! this n neigbour had both, n-s neighbours -> keep 1 456 ENDIF 457 ! land-only area with an active s neigbour 458 IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN 459 iiso = 1 + MOD( ioso(ii,ij) , jpni ) ! ii index of this s neigbour 460 ijso = 1 + ioso(ii,ij) / jpni ! ij index of this s neigbour 461 IF( ibondj(iiso,ijso) == -1 ) ibondj(iiso,ijso) = 2 ! this s neigbour had only a n neigbour -> no more neigbour 462 IF( ibondj(iiso,ijso) == 0 ) ibondj(iiso,ijso) = 1 ! this s neigbour had both, n-s neighbours -> keep s neigbour 463 ENDIF 464 ! land-only area with an active e neigbour 465 IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN 466 iiea = 1 + MOD( ioea(ii,ij) , jpni ) ! ii index of this e neigbour 467 ijea = 1 + ioea(ii,ij) / jpni ! ij index of this e neigbour 468 IF( ibondi(iiea,ijea) == 1 ) ibondi(iiea,ijea) = 2 ! this e neigbour had only a w neigbour -> no more neigbour 469 IF( ibondi(iiea,ijea) == 0 ) ibondi(iiea,ijea) = -1 ! this e neigbour had both, e-w neighbours -> keep e neigbour 470 ENDIF 471 ! land-only area with an active w neigbour 472 IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN 473 iiwe = 1 + MOD( iowe(ii,ij) , jpni ) ! ii index of this w neigbour 474 ijwe = 1 + iowe(ii,ij) / jpni ! ij index of this w neigbour 475 IF( ibondi(iiwe,ijwe) == -1 ) ibondi(iiwe,ijwe) = 2 ! this w neigbour had only a e neigbour -> no more neigbour 476 IF( ibondi(iiwe,ijwe) == 0 ) ibondi(iiwe,ijwe) = 1 ! this w neigbour had both, e-w neighbours -> keep w neigbour 477 ENDIF 478 END DO 479 480 ! 5. Subdomain print 481 ! ------------------ 482 IF(lwp) THEN 343 WRITE(numout,*) ' sum ijpj(1,j) = ', SUM(ijpj(1,:)), ' jpjglo = ', jpjglo 344 345 ! Subdomain grid print 483 346 ifreq = 4 484 347 il1 = 1 … … 503 366 9404 FORMAT(' * ' ,20(' ' ,i4,' * ') ) 504 367 ENDIF 505 506 ! just to save nono etc for all proc 507 ! warning ii*ij (zone) /= mpprank (processors)! 508 ! ioso = zone number, ii_noso = proc number 509 ii_noso(:) = -1 510 ii_nono(:) = -1 511 ii_noea(:) = -1 512 ii_nowe(:) = -1 513 DO jproc = 1, jpnij 514 ii = iin(jproc) 515 ij = ijn(jproc) 516 IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 517 iiso = 1 + MOD( ioso(ii,ij) , jpni ) 518 ijso = 1 + ioso(ii,ij) / jpni 519 ii_noso(jproc) = ipproc(iiso,ijso) 520 ENDIF 521 IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN 522 iiwe = 1 + MOD( iowe(ii,ij) , jpni ) 523 ijwe = 1 + iowe(ii,ij) / jpni 524 ii_nowe(jproc) = ipproc(iiwe,ijwe) 525 ENDIF 526 IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN 527 iiea = 1 + MOD( ioea(ii,ij) , jpni ) 528 ijea = 1 + ioea(ii,ij) / jpni 529 ii_noea(jproc)= ipproc(iiea,ijea) 530 ENDIF 531 IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN 532 iino = 1 + MOD( iono(ii,ij) , jpni ) 533 ijno = 1 + iono(ii,ij) / jpni 534 ii_nono(jproc)= ipproc(iino,ijno) 535 ENDIF 536 END DO 537 538 ! 6. Change processor name 539 ! ------------------------ 540 ii = iin(narea) 541 ij = ijn(narea) 542 ! 543 jpi = ijpi(ii,ij) 544 !!$ Nis0 = iis0(ii,ij) 545 !!$ Nie0 = iie0(ii,ij) 546 jpj = ijpj(ii,ij) 547 !!$ Njs0 = ijs0(ii,ij) 548 !!$ Nje0 = ije0(ii,ij) 549 nbondi = ibondi(ii,ij) 550 nbondj = ibondj(ii,ij) 551 nimpp = iimppt(ii,ij) 552 njmpp = ijmppt(ii,ij) 553 jpk = jpkglo ! third dim 554 555 ! set default neighbours 556 noso = ii_noso(narea) 557 nowe = ii_nowe(narea) 558 noea = ii_noea(narea) 559 nono = ii_nono(narea) 560 561 nones = -1 562 nonws = -1 563 noses = -1 564 nosws = -1 565 566 noner = -1 567 nonwr = -1 568 noser = -1 569 noswr = -1 570 571 IF((nbondi .eq. -1) .or. (nbondi .eq. 0)) THEN ! east neighbour exists 572 IF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 0) THEN 573 nones = ii_nono(noea+1) ! east neighbour has north and south neighbours 574 noses = ii_noso(noea+1) 575 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. -1) THEN 576 nones = ii_nono(noea+1) ! east neighbour has north neighbour 577 ELSEIF(ibondj(iin(noea+1),ijn(noea+1)) .eq. 1) THEN 578 noses = ii_noso(noea+1) ! east neighbour has south neighbour 579 END IF 580 END IF 581 IF((nbondi .eq. 1) .or. (nbondi .eq. 0)) THEN ! west neighbour exists 582 IF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 0) THEN 583 nonws = ii_nono(nowe+1) ! west neighbour has north and south neighbours 584 nosws = ii_noso(nowe+1) 585 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. -1) THEN 586 nonws = ii_nono(nowe+1) ! west neighbour has north neighbour 587 ELSEIF(ibondj(iin(nowe+1),ijn(nowe+1)) .eq. 1) THEN 588 nosws = ii_noso(nowe+1) ! west neighbour has north neighbour 589 END IF 590 END IF 591 592 IF((nbondj .eq. -1) .or. (nbondj .eq. 0)) THEN ! north neighbour exists 593 IF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 0) THEN 594 noner = ii_noea(nono+1) ! north neighbour has east and west neighbours 595 nonwr = ii_nowe(nono+1) 596 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. -1) THEN 597 noner = ii_noea(nono+1) ! north neighbour has east neighbour 598 ELSEIF(ibondi(iin(nono+1),ijn(nono+1)) .eq. 1) THEN 599 nonwr = ii_nowe(nono+1) ! north neighbour has west neighbour 600 END IF 601 END IF 602 IF((nbondj .eq. 1) .or. (nbondj .eq. 0)) THEN ! south neighbour exists 603 IF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 0) THEN 604 noser = ii_noea(noso+1) ! south neighbour has east and west neighbours 605 noswr = ii_nowe(noso+1) 606 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. -1) THEN 607 noser = ii_noea(noso+1) ! south neighbour has east neighbour 608 ELSEIF(ibondi(iin(noso+1),ijn(noso+1)) .eq. 1) THEN 609 noswr = ii_nowe(noso+1) ! south neighbour has west neighbour 610 END IF 611 END IF 612 613 ! 614 CALL init_doloop ! set start/end indices of do-loop, depending on the halo width value (nn_hls) 615 ! 616 jpim1 = jpi-1 ! inner domain indices 617 jpjm1 = jpj-1 ! " " 618 jpkm1 = MAX( 1, jpk-1 ) ! " " 619 jpij = jpi*jpj ! jpi x j 620 DO jproc = 1, jpnij 621 ii = iin(jproc) 622 ij = ijn(jproc) 623 jpiall (jproc) = ijpi(ii,ij) 624 nis0all(jproc) = iis0(ii,ij) 625 nie0all(jproc) = iie0(ii,ij) 626 jpjall (jproc) = ijpj(ii,ij) 627 njs0all(jproc) = ijs0(ii,ij) 628 nje0all(jproc) = ije0(ii,ij) 629 ibonit(jproc) = ibondi(ii,ij) 630 ibonjt(jproc) = ibondj(ii,ij) 631 nimppt(jproc) = iimppt(ii,ij) 632 njmppt(jproc) = ijmppt(ii,ij) 633 END DO 634 368 ! 369 ! Store informations for the north pole folding communications 370 nfproc(:) = ipproc(:,jpnj) 371 nfimpp(:) = iimppt(:,jpnj) 372 nfjpi (:) = ijpi(:,jpnj) 373 ! 374 ! 3. Define Western, Eastern, Southern and Northern neighbors + corners in the subdomain grid reference 375 ! ------------------------------------------------------------------------------------------------------ 376 ! 377 ! note that North fold is has specific treatment for its MPI communications. 378 ! This must not be treated as a "usual" communication with a northern neighbor. 379 ! -> North fold processes have no Northern neighbor in the definition done bellow 380 ! 381 llmpi_Iperio = jpni > 1 .AND. l_Iperio ! do i-periodicity with an MPI communication? 382 llmpi_Jperio = jpnj > 1 .AND. l_Jperio ! do j-periodicity with an MPI communication? 383 ! 384 l_SelfPerio(1:2) = l_Iperio .AND. jpni == 1 ! west, east periodicity by itself 385 l_SelfPerio(3:4) = l_Jperio .AND. jpnj == 1 ! south, north periodicity by itself 386 l_SelfPerio(5:8) = l_SelfPerio(jpwe) .AND. l_SelfPerio(jpso) ! corners bi-periodicity by itself 387 ! 388 ! define neighbors mapping (1/2): default definition: ignore if neighbours are land-only subdomains or not 389 DO jj = 1, jpnj 390 DO ji = 1, jpni 391 ! 392 IF ( llisOce(ji,jj) ) THEN ! this subdomain has some ocean: it has neighbours 393 ! 394 inum0 = ji - 1 + ( jj - 1 ) * jpni ! index in the subdomains grid. start at 0 395 ! 396 ! Is there a neighbor? 397 llnei(jpwe,ji,jj) = ji > 1 .OR. llmpi_Iperio ! West nei exists if not the first column or llmpi_Iperio 398 llnei(jpea,ji,jj) = ji < jpni .OR. llmpi_Iperio ! East nei exists if not the last column or llmpi_Iperio 399 llnei(jpso,ji,jj) = jj > 1 .OR. llmpi_Jperio ! South nei exists if not the first line or llmpi_Jperio 400 llnei(jpno,ji,jj) = jj < jpnj .OR. llmpi_Jperio ! North nei exists if not the last line or llmpi_Jperio 401 llnei(jpsw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpso,ji,jj) ! So-We nei exists if both South and West nei exist 402 llnei(jpse,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpso,ji,jj) ! So-Ea nei exists if both South and East nei exist 403 llnei(jpnw,ji,jj) = llnei(jpwe,ji,jj) .AND. llnei(jpno,ji,jj) ! No-We nei exists if both North and West nei exist 404 llnei(jpne,ji,jj) = llnei(jpea,ji,jj) .AND. llnei(jpno,ji,jj) ! No-Ea nei exists if both North and East nei exist 405 ! 406 ! Which index (starting at 0) have neighbors in the subdomains grid? 407 IF( llnei(jpwe,ji,jj) ) inei(jpwe,ji,jj) = inum0 - 1 + jpni * COUNT( (/ ji == 1 /) ) 408 IF( llnei(jpea,ji,jj) ) inei(jpea,ji,jj) = inum0 + 1 - jpni * COUNT( (/ ji == jpni /) ) 409 IF( llnei(jpso,ji,jj) ) inei(jpso,ji,jj) = inum0 - jpni + jpni * jpnj * COUNT( (/ jj == 1 /) ) 410 IF( llnei(jpno,ji,jj) ) inei(jpno,ji,jj) = inum0 + jpni - jpni * jpnj * COUNT( (/ jj == jpnj /) ) 411 IF( llnei(jpsw,ji,jj) ) inei(jpsw,ji,jj) = inei(jpso,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) 412 IF( llnei(jpse,ji,jj) ) inei(jpse,ji,jj) = inei(jpso,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) 413 IF( llnei(jpnw,ji,jj) ) inei(jpnw,ji,jj) = inei(jpno,ji,jj) - 1 + jpni * COUNT( (/ ji == 1 /) ) 414 IF( llnei(jpne,ji,jj) ) inei(jpne,ji,jj) = inei(jpno,ji,jj) + 1 - jpni * COUNT( (/ ji == jpni /) ) 415 ! 416 ELSE ! land-only domain has no neighbour 417 llnei(:,ji,jj) = .FALSE. 418 ENDIF 419 ! 420 END DO 421 END DO 422 ! 423 ! define neighbors mapping (2/2): check if neighbours are not land-only subdomains 424 DO jj = 1, jpnj 425 DO ji = 1, jpni 426 DO jn = 1, 8 427 IF( llnei(jn,ji,jj) ) THEN ! if a neighbour is existing -> this should not be a land-only domain 428 ii = 1 + MOD( inei(jn,ji,jj) , jpni ) 429 ij = 1 + inei(jn,ji,jj) / jpni 430 llnei(jn,ji,jj) = llisOce( ii, ij ) 431 ENDIF 432 END DO 433 END DO 434 END DO 435 ! 436 ! update index of the neighbours in the subdomains grid 437 WHERE( .NOT. llnei ) inei = -1 438 ! 635 439 ! Save processor layout in ascii file 636 440 IF (llwrtlay) THEN 637 441 CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 638 WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo'//& 639 & ' ( local: narea jpi jpj )' 640 WRITE(inum,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& 641 & ' ( local: ',narea,jpi,jpj,' )' 642 WRITE(inum,'(a)') 'narea jpi jpj Nis0 Njs0 Nie0 Nje0 nimp njmp nono noso nowe noea nbondi nbondj ' 643 644 DO jproc = 1, jpnij 645 WRITE(inum,'(13i5,2i7)') jproc, jpiall(jproc), jpjall(jproc), & 646 & nis0all(jproc), njs0all(jproc), & 647 & nie0all(jproc), nje0all(jproc), & 648 & nimppt (jproc), njmppt (jproc), & 649 & ii_nono(jproc), ii_noso(jproc), & 650 & ii_nowe(jproc), ii_noea(jproc), & 651 & ibonit (jproc), ibonjt (jproc) 442 WRITE(inum,'(a)') ' jpnij jpimax jpjmax jpk jpiglo jpjglo ( local: narea jpi jpj )' 443 WRITE(inum,'(6i7,a,3i7,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,' ( local: ',narea,jpi,jpj,' )' 444 WRITE(inum,*) 445 WRITE(inum, *) '------------------------------------' 446 WRITE(inum,'(a,i2)') ' Mapping of the default neighnourgs ' 447 WRITE(inum, *) '------------------------------------' 448 WRITE(inum,*) 449 WRITE(inum,'(a)') ' rank ii ij jpi jpj nimpp njmpp mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 450 DO jp = 1, jpnij 451 ii = iin(jp) 452 ij = ijn(jp) 453 WRITE(inum,'(15i6)') jp-1, ii, ij, ijpi(ii,ij), ijpj(ii,ij), iimppt(ii,ij), ijmppt(ii,ij), inei(:,ii,ij) 652 454 END DO 653 END IF 654 655 ! ! north fold parameter 656 ! Defined npolj, either 0, 3 , 4 , 5 , 6 657 ! In this case the important thing is that npolj /= 0 658 ! Because if we go through these line it is because jpni >1 and thus 659 ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0 660 npolj = 0 661 ij = ijn(narea) 662 IF( jperio == 3 .OR. jperio == 4 ) THEN 663 IF( ij == jpnj ) npolj = 3 664 ENDIF 665 IF( jperio == 5 .OR. jperio == 6 ) THEN 666 IF( ij == jpnj ) npolj = 5 667 ENDIF 455 ENDIF 456 457 ! 458 ! 4. Define Western, Eastern, Southern and Northern neighbors + corners for each mpi process 459 ! ------------------------------------------------------------------------------------------ 460 ! 461 ! rewrite information from "subdomain grid" to mpi process list 462 ! Warning, for example: 463 ! position of the northern neighbor in the "subdomain grid" 464 ! position of the northern neighbor in the "mpi process list" 465 466 ! default definition: no neighbors 467 impi(:,:) = -1 ! (starting at 0, -1 if no neighbourg) 468 469 DO jp = 1, jpnij 470 ii = iin(jp) 471 ij = ijn(jp) 472 DO jn = 1, 8 473 IF( llnei(jn,ii,ij) ) THEN ! must be tested as some land-domain can be kept to fit mppsize 474 ii2 = 1 + MOD( inei(jn,ii,ij) , jpni ) 475 ij2 = 1 + inei(jn,ii,ij) / jpni 476 impi(jn,jp) = ipproc( ii2, ij2 ) 477 ENDIF 478 END DO 479 END DO 480 481 ! 482 ! 4. keep information for the local process 483 ! ----------------------------------------- 484 ! 485 ! set default neighbours 486 mpinei(:) = impi(:,narea) 487 DO jh = 1, n_hlsmax 488 mpiSnei(jh,:) = impi(:,narea) ! default definition 489 mpiRnei(jh,:) = impi(:,narea) 490 END DO 668 491 ! 669 492 IF(lwp) THEN 670 493 WRITE(numout,*) 671 494 WRITE(numout,*) ' resulting internal parameters : ' 672 WRITE(numout,*) ' narea = ', narea 673 WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea 674 WRITE(numout,*) ' nono = ', nono , ' noso = ', noso 675 WRITE(numout,*) ' nbondi = ', nbondi 676 WRITE(numout,*) ' nbondj = ', nbondj 677 WRITE(numout,*) ' npolj = ', npolj 678 WRITE(numout,*) ' l_Iperio = ', l_Iperio 679 WRITE(numout,*) ' l_Jperio = ', l_Jperio 680 WRITE(numout,*) ' nimpp = ', nimpp 681 WRITE(numout,*) ' njmpp = ', njmpp 682 ENDIF 683 495 WRITE(numout,*) ' narea = ', narea 496 WRITE(numout,*) ' mpi nei west = ', mpinei(jpwe) , ' mpi nei east = ', mpinei(jpea) 497 WRITE(numout,*) ' mpi nei south = ', mpinei(jpso) , ' mpi nei north = ', mpinei(jpno) 498 WRITE(numout,*) ' mpi nei so-we = ', mpinei(jpsw) , ' mpi nei so-ea = ', mpinei(jpse) 499 WRITE(numout,*) ' mpi nei no-we = ', mpinei(jpnw) , ' mpi nei no-ea = ', mpinei(jpne) 500 ENDIF 684 501 ! ! Prepare mpp north fold 685 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 502 ! 503 llmpiNFold = jpni > 1 .AND. l_NFold ! is the North fold done with an MPI communication? 504 l_IdoNFold = ijn(narea) == jpnj .AND. l_NFold ! is this process doing North fold? 505 ! 506 IF( llmpiNFold ) THEN 686 507 CALL mpp_ini_north 687 508 IF (lwp) THEN 688 509 WRITE(numout,*) 689 510 WRITE(numout,*) ' ==>>> North fold boundary prepared for jpni >1' 690 ! additional prints in layout.dat 691 ENDIF 692 IF (llwrtlay) THEN 511 ENDIF 512 IF (llwrtlay) THEN ! additional prints in layout.dat 693 513 WRITE(inum,*) 694 514 WRITE(inum,*) 695 WRITE(inum,*) ' number of subdomains located along the north fold : ', ndim_rank_north515 WRITE(inum,*) 'Number of subdomains located along the north fold : ', ndim_rank_north 696 516 WRITE(inum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north 697 DO jp roc= 1, ndim_rank_north, 5698 WRITE(inum,*) nrank_north( jp roc:MINVAL( (/jproc+4,ndim_rank_north/) ) )517 DO jp = 1, ndim_rank_north, 5 518 WRITE(inum,*) nrank_north( jp:MINVAL( (/jp+4,ndim_rank_north/) ) ) 699 519 END DO 700 520 ENDIF 701 ENDIF 702 703 ! 704 CALL mpp_ini_nc ! Initialize communicator for neighbourhood collective communications 705 ! 706 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 707 ! 708 IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN 709 CALL init_nfdcom ! northfold neighbour lists 710 IF (llwrtlay) THEN 711 WRITE(inum,*) 712 WRITE(inum,*) 713 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 714 WRITE(inum,*) 'nsndto : ', nsndto 715 WRITE(inum,*) 'isendto : ', isendto 716 ENDIF 717 ENDIF 521 IF ( l_IdoNFold .AND. ln_nnogather ) THEN 522 CALL init_nfdcom ! northfold neighbour lists 523 IF (llwrtlay) THEN 524 WRITE(inum,*) 525 WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' 526 WRITE(inum,*) ' nsndto : ', nsndto 527 WRITE(inum,*) ' isendto : ', isendto(1:nsndto) 528 ENDIF 529 ENDIF 530 ENDIF 531 ! 532 CALL mpp_ini_nc(nn_hls) ! Initialize communicator for neighbourhood collective communications 533 DO jh = 1, n_hlsmax 534 mpi_nc_com4(jh) = mpi_nc_com4(nn_hls) ! default definition 535 mpi_nc_com8(jh) = mpi_nc_com8(nn_hls) 536 END DO 537 ! 538 CALL init_excl_landpt ! exclude exchanges which contain only land points 539 ! 540 ! Save processor layout changes in ascii file 541 DO jh = 1, n_hlsmax ! different halo size 542 DO ji = 1, 8 543 ichanged(16*(jh-1) +ji) = COUNT( mpinei(ji:ji) /= mpiSnei(jh,ji:ji) ) 544 ichanged(16*(jh-1)+8+ji) = COUNT( mpinei(ji:ji) /= mpiRnei(jh,ji:ji) ) 545 END DO 546 END DO 547 CALL mpp_sum( "mpp_init", ichanged ) ! must be called by all processes 548 IF (llwrtlay) THEN 549 WRITE(inum,*) 550 WRITE(inum, *) '----------------------------------------------------------------------' 551 WRITE(inum,'(a,i2)') ' Mapping of the neighnourgs once excluding comm with only land points ' 552 WRITE(inum, *) '----------------------------------------------------------------------' 553 DO jh = 1, n_hlsmax ! different halo size 554 WRITE(inum,*) 555 WRITE(inum,'(a,i2)') 'halo size: ', jh 556 WRITE(inum, *) '---------' 557 WRITE(inum,'(a)') ' rank ii ij mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 558 WRITE(inum, '(11i6,a)') narea-1, iin(narea), ijn(narea), mpinei(:), ' <- Org' 559 WRITE(inum,'(18x,8i6,a,i1,a)') mpiSnei(jh,:), ' <- Send ', COUNT( mpinei(:) /= mpiSnei(jh,:) ), ' modif' 560 WRITE(inum,'(18x,8i6,a,i1,a)') mpiRnei(jh,:), ' <- Recv ', COUNT( mpinei(:) /= mpiRnei(jh,:) ), ' modif' 561 WRITE(inum,*) ' total changes among all mpi tasks:' 562 WRITE(inum,*) ' mpiwe mpiea mpiso mpino mpisw mpise mpinw mpine' 563 WRITE(inum,'(a,8i6)') ' Send: ', ichanged(jh*16-15:jh*16-8) 564 WRITE(inum,'(a,8i6)') ' Recv: ', ichanged(jh*16 -7:jh*16 ) 565 END DO 566 ENDIF 567 ! 568 CALL init_ioipsl ! Prepare NetCDF output file (if necessary) 718 569 ! 719 570 IF (llwrtlay) CLOSE(inum) 720 571 ! 721 DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & 722 & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & 723 & ijpi, ijpj, iie0, ije0, iis0, ijs0, & 724 & iono, ioea, ioso, iowe, llisoce) 572 DEALLOCATE(iin, ijn, iimppt, ijmppt, ijpi, ijpj, ipproc, inei, llnei, impi, llisOce) 725 573 ! 726 574 END SUBROUTINE mpp_init … … 789 637 CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 790 638 ENDIF 791 IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6) THEN639 IF( l_NFold ) THEN 792 640 ! minimize the size of the last row to compensate for the north pole folding coast 793 IF( jperio == 3 .OR. jperio == 4) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos794 IF( jperio == 5 .OR. jperio == 6) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos795 irm = knbj - irestj 796 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) 797 irm = irm - ( kjmax - klcj(1,knbj) ) 641 IF( c_NFtype == 'T' ) ijpjmin = 2+3*khls ! V and F folding must be outside of southern halos 642 IF( c_NFtype == 'F' ) ijpjmin = 1+3*khls ! V and F folding must be outside of southern halos 643 irm = knbj - irestj ! total number of lines to be removed 644 klcj(:,knbj) = MAX( ijpjmin, kjmax-irm ) ! we must have jpj >= ijpjmin in the last row 645 irm = irm - ( kjmax - klcj(1,knbj) ) ! remaining number of lines to remove 798 646 irestj = knbj - 1 - irm 799 647 klcj(:, irestj+1:knbj-1) = kjmax-1 … … 860 708 LOGICAL :: llist 861 709 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llmsk2d ! max size of the subdomains along i,j 862 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llis oce ! - -710 LOGICAL, DIMENSION(:,:), ALLOCATABLE :: llisOce ! - - 863 711 REAL(wp):: zpropland 864 712 !!---------------------------------------------------------------------- … … 883 731 iszimin = 4*nn_hls ! minimum size of the MPI subdomain so halos are always adressing neighbor inner domain 884 732 iszjmin = 4*nn_hls 885 IF( jperio == 3 .OR. jperio == 4) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos886 IF( jperio == 5 .OR. jperio == 6) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos733 IF( c_NFtype == 'T' ) iszjmin = MAX(iszjmin, 2+3*nn_hls) ! V and F folding must be outside of southern halos 734 IF( c_NFtype == 'F' ) iszjmin = MAX(iszjmin, 1+3*nn_hls) ! V and F folding must be outside of southern halos 887 735 ! 888 736 ! get the list of knbi that gives a smaller jpimax than knbi-1 … … 933 781 iszi1(ii) = iszi0(ji) 934 782 iszj1(ii) = iszj0(jj) 935 END 783 ENDIF 936 784 END DO 937 785 END DO … … 989 837 WRITE(numout,*) ' -----------------------------------------------------' 990 838 WRITE(numout,*) 991 END 839 ENDIF 992 840 ji = isz0 ! initialization with the largest value 993 ALLOCATE( llis oce(inbi0(ji), inbj0(ji)) )994 CALL mpp_is_ocean( llis oce ) ! Warning: must be call by all cores (call mpp_sum)995 inbijold = COUNT(llis oce)996 DEALLOCATE( llis oce )841 ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) 842 CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) 843 inbijold = COUNT(llisOce) 844 DEALLOCATE( llisOce ) 997 845 DO ji =isz0-1,1,-1 998 ALLOCATE( llis oce(inbi0(ji), inbj0(ji)) )999 CALL mpp_is_ocean( llis oce ) ! Warning: must be call by all cores (call mpp_sum)1000 inbij = COUNT(llis oce)1001 DEALLOCATE( llis oce )846 ALLOCATE( llisOce(inbi0(ji), inbj0(ji)) ) 847 CALL mpp_is_ocean( llisOce ) ! Warning: must be call by all cores (call mpp_sum) 848 inbij = COUNT(llisOce) 849 DEALLOCATE( llisOce ) 1002 850 IF(lwp .AND. inbij < inbijold) THEN 1003 851 WRITE(numout,'(a, i6, a, i6, a, f4.1, a, i9, a, i6, a, i6, a)') & … … 1006 854 & '%), largest oce domain: ', iszi0(ji)*iszj0(ji), ' ( ', iszi0(ji),' x ', iszj0(ji), ' )' 1007 855 inbijold = inbij 1008 END 856 ENDIF 1009 857 END DO 1010 858 DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) … … 1022 870 DO WHILE( inbij > knbij ) ! while the number of ocean subdomains exceed the number of procs 1023 871 ii = ii -1 1024 ALLOCATE( llis oce(inbi0(ii), inbj0(ii)) )1025 CALL mpp_is_ocean( llis oce ) ! must be done by all core1026 inbij = COUNT(llis oce)1027 DEALLOCATE( llis oce )872 ALLOCATE( llisOce(inbi0(ii), inbj0(ii)) ) 873 CALL mpp_is_ocean( llisOce ) ! must be done by all core 874 inbij = COUNT(llisOce) 875 DEALLOCATE( llisOce ) 1028 876 END DO 1029 877 knbi = inbi0(ii) … … 1073 921 ! 1074 922 ALLOCATE( lloce(Ni0glo, ijsz) ) ! allocate the strip 1075 CALL read bot_strip( ijstr, ijsz, lloce )923 CALL read_mask( 1, ijstr, Ni0glo, ijsz, lloce ) 1076 924 inboce = COUNT(lloce) ! number of ocean point in the stripe 1077 925 DEALLOCATE(lloce) … … 1087 935 1088 936 1089 SUBROUTINE mpp_is_ocean( ld isoce )937 SUBROUTINE mpp_is_ocean( ldIsOce ) 1090 938 !!---------------------------------------------------------------------- 1091 939 !! *** ROUTINE mpp_is_ocean *** … … 1095 943 !! at least 1 ocean point. 1096 944 !! We must indeed ensure that each subdomain that is a neighbour 1097 !! of a land subdomain 945 !! of a land subdomain, has only land points on its boundary 1098 946 !! (inside the inner subdomain) with the land subdomain. 1099 947 !! This is needed to get the proper bondary conditions on … … 1102 950 !! ** Method : read inbj strips (of length Ni0glo) of the land-sea mask 1103 951 !!---------------------------------------------------------------------- 1104 LOGICAL, DIMENSION(:,:), INTENT( out) :: ld isoce ! .true. if a sub domain constains 1 ocean point952 LOGICAL, DIMENSION(:,:), INTENT( out) :: ldIsOce ! .true. if a sub domain constains 1 ocean point 1105 953 ! 1106 954 INTEGER :: idiv, iimax, ijmax, iarea … … 1115 963 ! do nothing if there is no land-sea mask 1116 964 IF( numbot == -1 .AND. numbdy == -1 ) THEN 1117 ld isoce(:,:) = .TRUE.965 ldIsOce(:,:) = .TRUE. 1118 966 RETURN 1119 967 ENDIF 1120 968 ! 1121 inbi = SIZE( ld isoce, dim = 1 )1122 inbj = SIZE( ld isoce, dim = 2 )969 inbi = SIZE( ldIsOce, dim = 1 ) 970 inbj = SIZE( ldIsOce, dim = 2 ) 1123 971 ! 1124 972 ! we want to read inbj strips of the land-sea mask. -> pick up inbj processes every idiv processes starting at 1 … … 1143 991 inry = iny - COUNT( (/ iarea == 1, iarea == inbj /) ) ! number of point to read in y-direction 1144 992 isty = 1 + COUNT( (/ iarea == 1 /) ) ! read from the first or the second line? 1145 CALL read bot_strip( ijmppt(1,iarea) - 2 + isty, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip993 CALL read_mask( 1, ijmppt(1,iarea) - 2 + isty, Ni0glo, inry, lloce(2:inx-1, isty:inry+isty-1) ) ! read the strip 1146 994 ! 1147 995 IF( iarea == 1 ) THEN ! the first line was not read 1148 IF( jperio == 2 .OR. jperio == 7 ) THEN! north-south periodocity1149 CALL read bot_strip( Nj0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce996 IF( l_Jperio ) THEN ! north-south periodocity 997 CALL read_mask( 1, Nj0glo, Ni0glo, 1, lloce(2:inx-1, 1) ) ! read the last line -> first line of lloce 1150 998 ELSE 1151 999 lloce(2:inx-1, 1) = .FALSE. ! closed boundary … … 1153 1001 ENDIF 1154 1002 IF( iarea == inbj ) THEN ! the last line was not read 1155 IF( jperio == 2 .OR. jperio == 7 ) THEN! north-south periodocity1156 CALL read bot_strip( 1, 1, lloce(2:inx-1,iny) )! read the first line -> last line of lloce1157 ELSEIF( jperio == 3 .OR. jperio == 4 ) THEN! north-pole folding T-pivot, T-point1003 IF( l_Jperio ) THEN ! north-south periodocity 1004 CALL read_mask( 1, 1, Ni0glo, 1, lloce(2:inx-1,iny) ) ! read the first line -> last line of lloce 1005 ELSEIF( c_NFtype == 'T' ) THEN ! north-pole folding T-pivot, T-point 1158 1006 lloce(2,iny) = lloce(2,iny-2) ! here we have 1 halo (even if nn_hls>1) 1159 1007 DO ji = 3,inx-1 … … 1163 1011 lloce(ji,iny-1) = lloce(inx-ji+2,iny-1) 1164 1012 END DO 1165 ELSEIF( jperio == 5 .OR. jperio == 6 ) THEN! north-pole folding F-pivot, T-point, 1 halo1013 ELSEIF( c_NFtype == 'F' ) THEN ! north-pole folding F-pivot, T-point, 1 halo 1166 1014 lloce(inx/2+1,iny-1) = lloce(inx/2,iny-1) ! here we have 1 halo (even if nn_hls>1) 1167 1015 lloce(inx -1,iny-1) = lloce(2 ,iny-1) … … 1174 1022 ENDIF 1175 1023 ! ! first and last column were not read 1176 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) THEN1024 IF( l_Iperio ) THEN 1177 1025 lloce(1,:) = lloce(inx-1,:) ; lloce(inx,:) = lloce(2,:) ! east-west periodocity 1178 1026 ELSE … … 1193 1041 CALL mpp_sum( 'mppini', inboce_1d ) 1194 1042 inboce = RESHAPE(inboce_1d, (/inbi, inbj/)) 1195 ld isoce(:,:) = inboce(:,:) /= 01043 ldIsOce(:,:) = inboce(:,:) /= 0 1196 1044 DEALLOCATE(inboce, inboce_1d) 1197 1045 ! … … 1199 1047 1200 1048 1201 SUBROUTINE read bot_strip( kjstr, kjcnt, ldoce )1202 !!---------------------------------------------------------------------- 1203 !! *** ROUTINE read bot_strip***1049 SUBROUTINE read_mask( kistr, kjstr, kicnt, kjcnt, ldoce ) 1050 !!---------------------------------------------------------------------- 1051 !! *** ROUTINE read_mask *** 1204 1052 !! 1205 1053 !! ** Purpose : Read relevant bathymetric information in order to … … 1209 1057 !! ** Method : read stipe of size (Ni0glo,...) 1210 1058 !!---------------------------------------------------------------------- 1211 INTEGER , INTENT(in ) :: kjstr ! startingj position of the reading1212 INTEGER , INTENT(in ) :: kjcnt ! number of lines to read1213 LOGICAL, DIMENSION( Ni0glo,kjcnt), INTENT( out) :: ldoce! ldoce(i,j) = .true. if the point (i,j) is ocean1214 ! 1215 INTEGER :: inumsave! local logical unit1216 REAL(wp), DIMENSION( Ni0glo,kjcnt) :: zbot, zbdy1059 INTEGER , INTENT(in ) :: kistr, kjstr ! starting i and j position of the reading 1060 INTEGER , INTENT(in ) :: kicnt, kjcnt ! number of points to read in i and j directions 1061 LOGICAL, DIMENSION(kicnt,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean 1062 ! 1063 INTEGER :: inumsave ! local logical unit 1064 REAL(wp), DIMENSION(kicnt,kjcnt) :: zbot, zbdy 1217 1065 !!---------------------------------------------------------------------- 1218 1066 ! … … 1220 1068 ! 1221 1069 IF( numbot /= -1 ) THEN 1222 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/ 1,kjstr/), kcount = (/Ni0glo, kjcnt/) )1070 CALL iom_get( numbot, jpdom_unknown, 'bottom_level', zbot, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) 1223 1071 ELSE 1224 1072 zbot(:,:) = 1._wp ! put a non-null value … … 1226 1074 ! 1227 1075 IF( numbdy /= -1 ) THEN ! Adjust with bdy_msk if it exists 1228 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/ 1,kjstr/), kcount = (/Ni0glo, kjcnt/) )1076 CALL iom_get ( numbdy, jpdom_unknown, 'bdy_msk', zbdy, kstart = (/kistr,kjstr/), kcount = (/kicnt, kjcnt/) ) 1229 1077 zbot(:,:) = zbot(:,:) * zbdy(:,:) 1230 1078 ENDIF 1231 1079 ! 1232 ldoce(:,:) = zbot(:,:) > 0._wp1080 ldoce(:,:) = NINT(zbot(:,:)) > 0 1233 1081 numout = inumsave 1234 1082 ! 1235 END SUBROUTINE read bot_strip1236 1237 1238 SUBROUTINE mpp_getnum( ld isoce, kproc, kipos, kjpos )1083 END SUBROUTINE read_mask 1084 1085 1086 SUBROUTINE mpp_getnum( ldIsOce, kproc, kipos, kjpos ) 1239 1087 !!---------------------------------------------------------------------- 1240 1088 !! *** ROUTINE mpp_getnum *** … … 1244 1092 !! ** Method : start from bottom left. First skip land subdomain, and finally use them if needed 1245 1093 !!---------------------------------------------------------------------- 1246 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ld isoce ! F if land process1247 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if supressed, starting at 0)1094 LOGICAL, DIMENSION(:,:), INTENT(in ) :: ldIsOce ! F if land process 1095 INTEGER, DIMENSION(:,:), INTENT( out) :: kproc ! subdomain number (-1 if not existing, starting at 0) 1248 1096 INTEGER, DIMENSION( :), INTENT( out) :: kipos ! i-position of the subdomain (from 1 to jpni) 1249 1097 INTEGER, DIMENSION( :), INTENT( out) :: kjpos ! j-position of the subdomain (from 1 to jpnj) … … 1253 1101 !!---------------------------------------------------------------------- 1254 1102 ! 1255 ini = SIZE(ld isoce, dim = 1)1256 inj = SIZE(ld isoce, dim = 2)1103 ini = SIZE(ldIsOce, dim = 1) 1104 inj = SIZE(ldIsOce, dim = 2) 1257 1105 inij = SIZE(kipos) 1258 1106 ! … … 1264 1112 ii = 1 + MOD(iarea0,ini) 1265 1113 ij = 1 + iarea0/ini 1266 IF( ld isoce(ii,ij) ) THEN1114 IF( ldIsOce(ii,ij) ) THEN 1267 1115 icont = icont + 1 1268 1116 kproc(ii,ij) = icont … … 1272 1120 END DO 1273 1121 ! if needed add some land subdomains to reach inij active subdomains 1274 i2add = inij - COUNT( ld isoce )1122 i2add = inij - COUNT( ldIsOce ) 1275 1123 DO jarea = 1, ini*inj 1276 1124 iarea0 = jarea - 1 1277 1125 ii = 1 + MOD(iarea0,ini) 1278 1126 ij = 1 + iarea0/ini 1279 IF( .NOT. ld isoce(ii,ij) .AND. i2add > 0 ) THEN1127 IF( .NOT. ldIsOce(ii,ij) .AND. i2add > 0 ) THEN 1280 1128 icont = icont + 1 1281 1129 kproc(ii,ij) = icont … … 1287 1135 ! 1288 1136 END SUBROUTINE mpp_getnum 1137 1138 1139 SUBROUTINE init_excl_landpt 1140 !!---------------------------------------------------------------------- 1141 !! *** ROUTINE *** 1142 !! 1143 !! ** Purpose : exclude exchanges which contain only land points 1144 !! 1145 !! ** Method : if a send or receive buffer constains only land point we 1146 !! flag off the corresponding communication 1147 !! Warning: this selection depend on the halo size -> loop on halo size 1148 !! 1149 !!---------------------------------------------------------------------- 1150 INTEGER :: inumsave 1151 INTEGER :: jh 1152 INTEGER :: ipi, ipj 1153 INTEGER :: iiwe, iiea, iist, iisz 1154 INTEGER :: ijso, ijno, ijst, ijsz 1155 LOGICAL :: llsave 1156 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zmsk 1157 LOGICAL , DIMENSION(Ni_0,Nj_0,1) :: lloce 1158 !!---------------------------------------------------------------------- 1159 ! 1160 ! read the land-sea mask on the inner domain 1161 CALL read_mask( nimpp, njmpp, Ni_0, Nj_0, lloce(:,:,1) ) 1162 ! 1163 ! Here we look only at communications excluding the NP folding. 1164 ! As lbcnfd not validated if halo size /= nn_hls, we switch if off temporary... 1165 llsave = l_IdoNFold 1166 l_IdoNFold = .FALSE. 1167 ! 1168 DO jh = 1, n_hlsmax ! different halo size 1169 ! 1170 ipi = Ni_0 + 2*jh ! local domain size 1171 ipj = Nj_0 + 2*jh 1172 ! 1173 ALLOCATE( zmsk(ipi,ipj) ) 1174 zmsk(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3), wp) ! define inner domain -> need REAL to use lbclnk 1175 CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos 1176 ! 1177 iiwe = jh ; iiea = Ni_0 ! bottom-left corfer - 1 of the sent data 1178 ijso = jh ; ijno = Nj_0 1179 IF( nn_comm == 1 ) THEN 1180 iist = 0 ; iisz = ipi 1181 ijst = 0 ; ijsz = ipj 1182 ELSE 1183 iist = jh ; iisz = Ni_0 1184 ijst = jh ; ijsz = Nj_0 1185 ENDIF 1186 IF( nn_comm == 1 ) THEN ! SM: NOT WORKING FOR NEIGHBOURHOOD COLLECTIVE COMMUNICATIONS, I DON'T KNOW WHY... 1187 ! do not send if we send only land points 1188 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiSnei(jh,jpwe) = -1 1189 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiSnei(jh,jpea) = -1 1190 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpso) = -1 1191 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpno) = -1 1192 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpsw) = -1 1193 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiSnei(jh,jpse) = -1 1194 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpnw) = -1 1195 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiSnei(jh,jpne) = -1 1196 ! 1197 iiwe = iiwe-jh ; iiea = iiea+jh ! bottom-left corfer - 1 of the received data 1198 ijso = ijso-jh ; ijno = ijno+jh 1199 ! do not send if we send only land points 1200 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiRnei(jh,jpwe) = -1 1201 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijst+1:ijst+ijsz) )) == 0 ) mpiRnei(jh,jpea) = -1 1202 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpso) = -1 1203 IF( NINT(SUM( zmsk(iist+1:iist+iisz,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpno) = -1 1204 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpsw) = -1 1205 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijso+1:ijso+jh ) )) == 0 ) mpiRnei(jh,jpse) = -1 1206 IF( NINT(SUM( zmsk(iiwe+1:iiwe+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpnw) = -1 1207 IF( NINT(SUM( zmsk(iiea+1:iiea+jh ,ijno+1:ijno+jh ) )) == 0 ) mpiRnei(jh,jpne) = -1 1208 ENDIF 1209 ! 1210 ! Specific (and rare) problem in corner treatment because we do 1st West-East comm, next South-North comm 1211 IF( nn_comm == 1 ) THEN 1212 IF( mpiSnei(jh,jpwe) > -1 ) mpiSnei(jh, (/jpsw,jpnw/) ) = -1 ! SW and NW corners already sent through West nei 1213 IF( mpiSnei(jh,jpea) > -1 ) mpiSnei(jh, (/jpse,jpne/) ) = -1 ! SE and NE corners already sent through East nei 1214 IF( mpiRnei(jh,jpso) > -1 ) mpiRnei(jh, (/jpsw,jpse/) ) = -1 ! SW and SE corners will be received through South nei 1215 IF( mpiRnei(jh,jpno) > -1 ) mpiRnei(jh, (/jpnw,jpne/) ) = -1 ! NW and NE corners will be received through North nei 1216 ENDIF 1217 ! 1218 DEALLOCATE( zmsk ) 1219 ! 1220 CALL mpp_ini_nc(jh) ! Initialize/Update communicator for neighbourhood collective communications 1221 ! 1222 END DO 1223 l_IdoNFold = llsave 1224 1225 END SUBROUTINE init_excl_landpt 1289 1226 1290 1227 … … 1343 1280 !!---------------------------------------------------------------------- 1344 1281 ! 1345 !initializes the north-fold communication variables 1346 isendto(:) = 0 1347 nsndto = 0 1348 ! 1349 IF ( njmpp == MAXVAL( njmppt ) ) THEN ! if I am a process in the north 1282 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1283 sxM = jpiglo - nimpp - jpi + 1 1284 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1285 dxM = jpiglo - nimpp + 2 1286 ! 1287 ! loop over the other north-fold processes to find the processes 1288 ! managing the points belonging to the sxT-dxT range 1289 ! 1290 nsndto = 0 1291 DO jn = 1, jpni 1350 1292 ! 1351 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 1352 sxM = jpiglo - nimppt(narea) - jpiall(narea) + 1 1353 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 1354 dxM = jpiglo - nimppt(narea) + 2 1293 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1294 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1355 1295 ! 1356 ! loop over the other north-fold processes to find the processes 1357 ! managing the points belonging to the sxT-dxT range 1296 IF ( sxT < sxM .AND. sxM < dxT ) THEN 1297 nsndto = nsndto + 1 1298 isendto(nsndto) = jn 1299 ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN 1300 nsndto = nsndto + 1 1301 isendto(nsndto) = jn 1302 ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN 1303 nsndto = nsndto + 1 1304 isendto(nsndto) = jn 1305 ENDIF 1358 1306 ! 1359 DO jn = 1, jpni 1360 ! 1361 sxT = nfimpp(jn) ! sxT = 1st point (in the global domain) of the jn process 1362 dxT = nfimpp(jn) + nfjpi(jn) - 1 ! dxT = last point (in the global domain) of the jn process 1363 ! 1364 IF ( sxT < sxM .AND. sxM < dxT ) THEN 1365 nsndto = nsndto + 1 1366 isendto(nsndto) = jn 1367 ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN 1368 nsndto = nsndto + 1 1369 isendto(nsndto) = jn 1370 ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN 1371 nsndto = nsndto + 1 1372 isendto(nsndto) = jn 1373 ENDIF 1374 ! 1375 END DO 1376 ! 1377 ENDIF 1378 l_north_nogather = .TRUE. 1307 END DO 1379 1308 ! 1380 1309 END SUBROUTINE init_nfdcom … … 1389 1318 !!---------------------------------------------------------------------- 1390 1319 ! 1391 Nis0 = 1+nn_hls ; Nis1 = Nis0-1 ; Nis2 = MAX( 1, Nis0-2) 1392 Njs0 = 1+nn_hls ; Njs1 = Njs0-1 ; Njs2 = MAX( 1, Njs0-2) 1393 ! 1394 Nie0 = jpi-nn_hls ; Nie1 = Nie0+1 ; Nie2 = MIN(jpi, Nie0+2) 1395 Nje0 = jpj-nn_hls ; Nje1 = Nje0+1 ; Nje2 = MIN(jpj, Nje0+2) 1396 ! 1397 IF( nn_hls == 1 ) THEN !* halo size of 1 1398 ! 1399 Nis1nxt2 = Nis0 ; Njs1nxt2 = Njs0 1400 Nie1nxt2 = Nie0 ; Nje1nxt2 = Nje0 1401 ! 1402 ELSE !* larger halo size... 1403 ! 1404 Nis1nxt2 = Nis1 ; Njs1nxt2 = Njs1 1405 Nie1nxt2 = Nie1 ; Nje1nxt2 = Nje1 1406 ! 1407 ENDIF 1320 Nis0 = 1+nn_hls 1321 Njs0 = 1+nn_hls 1322 Nie0 = jpi-nn_hls 1323 Nje0 = jpj-nn_hls 1408 1324 ! 1409 1325 Ni_0 = Nie0 - Nis0 + 1 1410 1326 Nj_0 = Nje0 - Njs0 + 1 1411 Ni_1 = Nie1 - Nis1 + 1 1412 Nj_1 = Nje1 - Njs1 + 1 1413 Ni_2 = Nie2 - Nis2 + 1 1414 Nj_2 = Nje2 - Njs2 + 1 1327 ! 1328 ! old indices to be removed... 1329 jpim1 = jpi-1 ! inner domain indices 1330 jpjm1 = jpj-1 ! " " 1331 jpkm1 = jpk-1 ! " " 1415 1332 ! 1416 1333 END SUBROUTINE init_doloop -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LDF/ldfc1d_c2d.F90
r14189 r14448 95 95 END_3D 96 96 ! Lateral boundary conditions 97 CALL lbc_lnk _multi( 'ldfc1d_c2d', pah1, 'U', 1.0_wp , pah2, 'V', 1.0_wp )97 CALL lbc_lnk( 'ldfc1d_c2d', pah1, 'U', 1.0_wp , pah2, 'V', 1.0_wp ) 98 98 ! 99 99 CASE DEFAULT ! error -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LDF/ldfdyn.F90
r14201 r14448 412 412 ENDIF 413 413 ! 414 CALL lbc_lnk _multi( 'ldfdyn', ahmt, 'T', 1.0_wp, ahmf, 'F', 1.0_wp )414 CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_wp, ahmf, 'F', 1.0_wp ) 415 415 ! 416 416 ! … … 444 444 END DO 445 445 ! 446 CALL lbc_lnk _multi( 'ldfdyn', dtensq, 'T', 1.0_wp ) ! lbc_lnk on dshesq not needed446 CALL lbc_lnk( 'ldfdyn', dtensq, 'T', 1.0_wp ) ! lbc_lnk on dshesq not needed 447 447 ! 448 448 DO jk = 1, jpkm1 … … 495 495 ENDIF 496 496 ! 497 CALL lbc_lnk _multi( 'ldfdyn', ahmt, 'T', 1.0_wp , ahmf, 'F', 1.0_wp )497 CALL lbc_lnk( 'ldfdyn', ahmt, 'T', 1.0_wp , ahmf, 'F', 1.0_wp ) 498 498 ! 499 499 END SELECT -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LDF/ldfslp.F90
r14312 r14448 229 229 !!gm end modif 230 230 END_3D 231 CALL lbc_lnk _multi( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions231 CALL lbc_lnk( 'ldfslp', zwz, 'U', -1.0_wp, zww, 'V', -1.0_wp ) ! lateral boundary conditions 232 232 ! 233 233 ! !* horizontal Shapiro filter … … 289 289 !!gm end modif 290 290 END_3D 291 CALL lbc_lnk _multi( 'ldfslp', zwz, 'T', -1.0_wp, zww, 'T', -1.0_wp ) ! lateral boundary conditions291 CALL lbc_lnk( 'ldfslp', zwz, 'T', -1.0_wp, zww, 'T', -1.0_wp ) ! lateral boundary conditions 292 292 ! 293 293 ! !* horizontal Shapiro filter … … 318 318 ! IV. Lateral boundary conditions 319 319 ! =============================== 320 CALL lbc_lnk _multi( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp )320 CALL lbc_lnk( 'ldfslp', uslp , 'U', -1.0_wp , vslp , 'V', -1.0_wp , wslpi, 'W', -1.0_wp, wslpj, 'W', -1.0_wp ) 321 321 322 322 IF(sn_cfctl%l_prtctl) THEN … … 659 659 END_2D 660 660 !!gm this lbc_lnk should be useless.... 661 CALL lbc_lnk _multi( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp )661 CALL lbc_lnk( 'ldfslp', uslpml , 'U', -1.0_wp , vslpml , 'V', -1.0_wp , wslpiml, 'W', -1.0_wp , wslpjml, 'W', -1.0_wp ) 662 662 ! 663 663 END SUBROUTINE ldf_slp_mxl … … 727 727 ! END DO 728 728 ! END DO 729 ! CALL lbc_lnk _multi( 'ldfslp', uslp , 'U', -1. ; CALL lbc_lnk( 'ldfslp', vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1. )729 ! CALL lbc_lnk( 'ldfslp', uslp , 'U', -1. ; CALL lbc_lnk( 'ldfslp', vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1. ) 730 730 !!gm ENDIF 731 731 ENDIF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/LDF/ldftra.F90
r14201 r14448 697 697 paeiv(ji,jj,1) = 0.5_wp * ( zaeiw(ji,jj) + zaeiw(ji ,jj+1) ) * vmask(ji,jj,1) 698 698 END_2D 699 CALL lbc_lnk _multi( 'ldftra', paeiu(:,:,1), 'U', 1.0_wp , paeiv(:,:,1), 'V', 1.0_wp ) ! lateral boundary condition699 CALL lbc_lnk( 'ldftra', paeiu(:,:,1), 'U', 1.0_wp , paeiv(:,:,1), 'V', 1.0_wp ) ! lateral boundary condition 700 700 701 701 DO jk = 2, jpkm1 !== deeper values equal the surface one ==! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/cpl_oasis3.F90
r14227 r14448 294 294 ! 295 295 #if defined key_agrif 296 IF( agrif_fixed() == Agrif_Nb_Fine_Grids() ) THEN 296 ! Warning: Agrif_Nb_Fine_Grids not yet defined at this stage for Agrif_Root -> must use Agrif_Root_Only() 297 IF( Agrif_Root_Only() .OR. agrif_fixed() == Agrif_Nb_Fine_Grids() ) THEN 297 298 #endif 298 299 CALL oasis_enddef(nerror) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/fldread.F90
r13546 r14448 211 211 ! 212 212 IF( sd(jf)%ln_tint ) THEN ! temporal interpolation 213 IF(lwp .AND. kt - nit000 <= 100) THEN213 IF(lwp .AND. ( kt - nit000 <= 20 .OR. nitend - kt <= 20 ) ) THEN 214 214 clfmt = "(' fld_read: var ', a, ' kt = ', i8, ' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & 215 215 & "', records b/a: ', i6.4, '/', i6.4, ' (days ', f9.4,'/', f9.4, ')')" … … 223 223 sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,ibb) + ztinta * sd(jf)%fdta(:,:,:,iaa) 224 224 ELSE ! nothing to do... 225 IF(lwp .AND. kt - nit000 <= 100) THEN225 IF(lwp .AND. ( kt - nit000 <= 20 .OR. nitend - kt <= 20 ) ) THEN 226 226 clfmt = "(' fld_read: var ', a, ' kt = ', i8,' (', f9.4,' days), Y/M/D = ', i4.4,'/', i2.2,'/', i2.2," // & 227 227 & "', record: ', i6.4, ' (days ', f9.4, ' <-> ', f9.4, ')')" … … 251 251 !!--------------------------------------------------------------------- 252 252 ! 253 IF( nflag == 0 ) nflag = - ( HUGE(0) - 10)253 IF( nflag == 0 ) nflag = -HUGE(0) 254 254 ! 255 255 CALL fld_def( sdjf ) … … 908 908 TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables 909 909 ! 910 INTEGER , DIMENSION(2):: isave910 INTEGER :: isave 911 911 LOGICAL :: llprev, llnext, llstop 912 912 !!---------------------------------------------------------------------- 913 913 ! 914 914 llprev = sdjf%nrecsec(sdjf%nreclast) < nsec000_1jan000 ! file ends before the beginning of the job -> file may not exist 915 llnext = sdjf%nrecsec( 0) > nsecend_1jan000 ! file begins after the end of the job -> file may not exist915 llnext = sdjf%nrecsec( 1 ) > nsecend_1jan000 ! file begins after the end of the job -> file may not exist 916 916 917 917 llstop = sdjf%ln_clim .OR. .NOT. ( llprev .OR. llnext ) … … 926 926 IF( llprev ) THEN ! previous file does not exist : go back to current and accept to read only the first record 927 927 CALL ctl_warn('previous file: '//TRIM(sdjf%clname)//' not found -> go back to current year/month/week/day file') 928 isave(1:2) = sdjf%nrecsec(sdjf%nreclast-1:sdjf%nreclast) ! save previous file info 929 CALL fld_def( sdjf ) ! go back to current file 930 sdjf%nreclast = 1 ! force to use only the first record (do as if other were not existing...) 931 sdjf%nrecsec(0:1) = isave(1:2) 928 isave = sdjf%nrecsec(sdjf%nreclast) ! save previous file info 929 CALL fld_def( sdjf ) ! go back to current file 930 sdjf%nreclast = 1 ! force to use only the first record (do as if other were not existing...) 932 931 ENDIF 933 932 ! 934 933 IF( llnext ) THEN ! next file does not exist : go back to current and accept to read only the last record 935 934 CALL ctl_warn('next file: '//TRIM(sdjf%clname)//' not found -> go back to current year/month/week/day file') 936 isave (1:2) = sdjf%nrecsec(0:1)! save next file info937 CALL fld_def( sdjf ) ! go back to current file938 ! -> read last record but keep record info from the first record of next file939 sdjf%nrecsec(sdjf%nreclast-1:sdjf%nreclast) = isave(1:2)940 sdjf%nrecsec(0:sdjf%nreclast-2) = nflag941 ENDIF935 isave = sdjf%nrecsec(1) ! save next file info 936 CALL fld_def( sdjf ) ! go back to current file 937 ENDIF 938 ! -> read "last" record but keep record info from the first record of next file 939 sdjf%nrecsec( sdjf%nreclast ) = isave 940 sdjf%nrecsec(0:sdjf%nreclast-1) = nflag 942 941 ! 943 942 CALL iom_open( sdjf%clname, sdjf%num, ldiof = LEN_TRIM(sdjf%wgtname) > 0 ) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/geo2ocean.F90
r14215 r14448 272 272 ! =========================== ! 273 273 ! ! lateral boundary cond.: T-, U-, V-, F-pts, sgn 274 CALL lbc_lnk _multi( 'geo2ocean', gcost, 'T', -1.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, &275 &gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp )274 CALL lbc_lnk( 'geo2ocean', gcost, 'T', -1.0_wp, gsint, 'T', -1.0_wp, gcosu, 'U', -1.0_wp, gsinu, 'U', -1.0_wp, & 275 & gcosv, 'V', -1.0_wp, gsinv, 'V', -1.0_wp, gcosf, 'F', -1.0_wp, gsinf, 'F', -1.0_wp ) 276 276 ! 277 277 END SUBROUTINE angle -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/sbcblk.F90
r14072 r14448 40 40 USE sbcdcy ! surface boundary condition: diurnal cycle 41 41 USE sbcwave , ONLY : cdn_wave ! wave module 42 USE lib_fortran ! to use key_nosignedzero 42 USE lib_fortran ! to use key_nosignedzero and glob_sum 43 43 ! 44 44 #if defined key_si3 … … 348 348 ! !- fill the bulk structure with namelist informations 349 349 CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_init', 'surface boundary condition -- bulk formulae', 'namsbc_blk' ) 350 sf(jp_wndi )%zsgn = -1._wp ; sf(jp_wndj )%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn 351 sf(jp_uoatm)%zsgn = -1._wp ; sf(jp_voatm)%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn 352 sf(jp_hpgi )%zsgn = -1._wp ; sf(jp_hpgj )%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn 350 353 ! 351 354 DO jfpr= 1, jpfld … … 501 504 !!---------------------------------------------------------------------- 502 505 REAL(wp), DIMENSION(jpi,jpj) :: zssq, zcd_du, zsen, zlat, zevp 503 REAL(wp) :: ztmp 506 REAL(wp) :: ztst 507 LOGICAL :: llerr 504 508 !!---------------------------------------------------------------------- 505 509 ! … … 508 512 ! Sanity/consistence test on humidity at first time step to detect potential screw-up: 509 513 IF( kt == nit000 ) THEN 510 IF(lwp) WRITE(numout,*) '' 511 #if defined key_agrif 512 IF(lwp) WRITE(numout,*) ' === AGRIF => Sanity/consistence test on air humidity SKIPPED! :( ===' 513 #else 514 ztmp = SUM(tmask(:,:,1)) ! number of ocean points on local proc domain 515 IF( ztmp > 8._wp ) THEN ! test only on proc domains with at least 8 ocean points! 516 ztmp = SUM(sf(jp_humi)%fnow(:,:,1)*tmask(:,:,1))/ztmp ! mean humidity over ocean on proc 517 SELECT CASE( nhumi ) 518 CASE( np_humi_sph ) ! specific humidity => expect: 0. <= something < 0.065 [kg/kg] (0.061 is saturation at 45degC !!!) 519 IF( (ztmp < 0._wp) .OR. (ztmp > 0.065) ) ztmp = -1._wp 520 CASE( np_humi_dpt ) ! dew-point temperature => expect: 110. <= something < 320. [K] 521 IF( (ztmp < 110._wp).OR.(ztmp > 320._wp) ) ztmp = -1._wp 522 CASE( np_humi_rlh ) ! relative humidity => expect: 0. <= something < 100. [%] 523 IF( (ztmp < 0._wp) .OR.(ztmp > 100._wp) ) ztmp = -1._wp 524 END SELECT 525 IF(ztmp < 0._wp) THEN 526 IF (lwp) WRITE(numout,'(" Mean humidity value found on proc #",i6.6," is: ",f10.5)') narea, ztmp 527 CALL ctl_stop( 'STOP', 'Something is wrong with air humidity!!!', & 528 & ' ==> check the unit in your input files' , & 529 & ' ==> check consistence of namelist choice: specific? relative? dew-point?', & 530 & ' ==> ln_humi_sph -> [kg/kg] | ln_humi_rlh -> [%] | ln_humi_dpt -> [K] !!!' ) 531 END IF 532 END IF 533 IF(lwp) WRITE(numout,*) ' === Sanity/consistence test on air humidity sucessfuly passed! ===' 534 #endif 535 IF(lwp) WRITE(numout,*) '' 536 END IF !IF( kt == nit000 ) 514 ! mean humidity over ocean on proc 515 ztst = glob_sum( 'sbcblk', sf(jp_humi)%fnow(:,:,1) * e1e2t(:,:) * tmask(:,:,1) ) / glob_sum( 'sbcblk', e1e2t(:,:) * tmask(:,:,1) ) 516 llerr = .FALSE. 517 SELECT CASE( nhumi ) 518 CASE( np_humi_sph ) ! specific humidity => expect: 0. <= something < 0.065 [kg/kg] (0.061 is saturation at 45degC !!!) 519 IF( (ztst < 0._wp) .OR. (ztst > 0.065_wp) ) llerr = .TRUE. 520 CASE( np_humi_dpt ) ! dew-point temperature => expect: 110. <= something < 320. [K] 521 IF( (ztst < 110._wp) .OR. (ztst > 320._wp) ) llerr = .TRUE. 522 CASE( np_humi_rlh ) ! relative humidity => expect: 0. <= something < 100. [%] 523 IF( (ztst < 0._wp) .OR. (ztst > 100._wp) ) llerr = .TRUE. 524 END SELECT 525 IF(llerr) THEN 526 WRITE(ctmp1,'(" Error on mean humidity value: ",f10.5)') ztst 527 CALL ctl_stop( 'STOP', ctmp1, 'Something is wrong with air humidity!!!', & 528 & ' ==> check the unit in your input files' , & 529 & ' ==> check consistence of namelist choice: specific? relative? dew-point?', & 530 & ' ==> ln_humi_sph -> [kg/kg] | ln_humi_rlh -> [%] | ln_humi_dpt -> [K] !!!' ) 531 ENDIF 532 IF(lwp) THEN 533 WRITE(numout,*) '' 534 WRITE(numout,*) ' Global mean humidity at kt = nit000: ', ztst 535 WRITE(numout,*) ' === Sanity/consistence test on air humidity sucessfuly passed! ===' 536 WRITE(numout,*) '' 537 ENDIF 538 ENDIF !IF( kt == nit000 ) 537 539 ! ! compute the surface ocean fluxes using bulk formulea 538 540 IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN … … 620 622 !!--------------------------------------------------------------------- 621 623 INTEGER , INTENT(in ) :: kt ! time step index 622 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndi ! atmospheric wind at U-point [m/s]623 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndj ! atmospheric wind at V-point [m/s]624 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndi ! atmospheric wind at T-point [m/s] 625 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pwndj ! atmospheric wind at T-point [m/s] 624 626 REAL(wp), INTENT(in ), DIMENSION(:,:) :: pqair ! specific humidity at T-points [kg/kg] 625 627 REAL(wp), INTENT(in ), DIMENSION(:,:) :: ptair ! potential temperature at T-points [Kelvin] … … 830 832 831 833 IF( ln_crt_fbk ) THEN 832 CALL lbc_lnk _multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1., taum, 'T', -1.)834 CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp, taum, 'T', 1._wp ) 833 835 ELSE 834 CALL lbc_lnk _multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1.)836 CALL lbc_lnk( 'sbcblk', utau, 'U', -1._wp, vtau, 'V', -1._wp ) 835 837 ENDIF 836 838 … … 1066 1068 pvtaui(ji,jj) = zztmp2 * ( pvtaui(ji,jj) + pvtaui(ji ,jj+1) ) 1067 1069 END_2D 1068 CALL lbc_lnk _multi( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp )1070 CALL lbc_lnk( 'sbcblk', putaui, 'U', -1._wp, pvtaui, 'V', -1._wp ) 1069 1071 ! 1070 1072 IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab2d_1=putaui , clinfo1=' blk_ice: putaui : ' & -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/sbccpl.F90
r14227 r14448 1248 1248 frcv(jpr_oty1)%z3(ji,jj,1) = 0.5 * ( frcv(jpr_oty1)%z3(ji ,jj+1,1) + frcv(jpr_oty1)%z3(ji,jj,1) ) 1249 1249 END_2D 1250 CALL lbc_lnk _multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V', -1.0_wp )1250 CALL lbc_lnk( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1.0_wp, frcv(jpr_oty1)%z3(:,:,1), 'V', -1.0_wp ) 1251 1251 ENDIF 1252 1252 llnewtx = .TRUE. … … 1666 1666 p_tauj(ji,jj) = zztmp2 * ( frcv(jpr_ity1)%z3(ji ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) ) 1667 1667 END_2D 1668 CALL lbc_lnk _multi( 'sbccpl', p_taui, 'U', -1., p_tauj, 'V', -1. )1668 CALL lbc_lnk( 'sbccpl', p_taui, 'U', -1., p_tauj, 'V', -1. ) 1669 1669 END SELECT 1670 1670 … … 2560 2560 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2561 2561 END_2D 2562 CALL lbc_lnk _multi( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp )2562 CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) 2563 2563 CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T 2564 2564 DO_2D( 0, 0, 0, 0 ) … … 2569 2569 END_2D 2570 2570 END SELECT 2571 CALL lbc_lnk _multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp )2571 CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocy1)%clgrid, -1.0_wp ) 2572 2572 ! 2573 2573 ENDIF … … 2637 2637 zity1(ji,jj) = 0.5 * ( v_ice(ji,jj ) + v_ice(ji ,jj-1 ) ) * fr_i(ji,jj) 2638 2638 END_2D 2639 CALL lbc_lnk _multi( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp )2639 CALL lbc_lnk( 'sbccpl', zitx1, 'T', -1.0_wp, zity1, 'T', -1.0_wp ) 2640 2640 CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T 2641 2641 DO_2D( 0, 0, 0, 0 ) … … 2646 2646 END_2D 2647 2647 END SELECT 2648 CALL lbc_lnk _multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp )2648 CALL lbc_lnk( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1.0_wp, zoty1, ssnd(jps_ocyw)%clgrid, -1.0_wp ) 2649 2649 ! 2650 2650 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/sbcflx.F90
r14072 r14448 119 119 ! ! fill sf with slf_i and control print 120 120 CALL fld_fill( sf, slf_i, cn_dir, 'sbc_flx', 'flux formulation for ocean surface boundary condition', 'namsbc_flx' ) 121 sf(jp_utau)%cltype = 'U' ; sf(jp_utau)%zsgn = -1._wp ! vector field at U point: overwrite default definition of cltype and zsgn 122 sf(jp_vtau)%cltype = 'V' ; sf(jp_vtau)%zsgn = -1._wp ! vector field at V point: overwrite default definition of cltype and zsgn 121 123 ! 122 124 ENDIF … … 129 131 qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) 130 132 ELSE 131 DO_2D( 0, 0, 0, 0)132 qsr(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1)* tmask(ji,jj,1)133 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 134 qsr(ji,jj) = sf(jp_qsr)%fnow(ji,jj,1) * tmask(ji,jj,1) 133 135 END_2D 134 136 ENDIF 135 DO_2D( 0, 0, 0, 0 )! set the ocean fluxes from read fields137 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) ! set the ocean fluxes from read fields 136 138 utau(ji,jj) = sf(jp_utau)%fnow(ji,jj,1) * umask(ji,jj,1) 137 139 vtau(ji,jj) = sf(jp_vtau)%fnow(ji,jj,1) * vmask(ji,jj,1) … … 143 145 !!clem: I do not think it is needed 144 146 !!qns(:,:) = qns(:,:) - emp(:,:) * sst_m(:,:) * rcp ! mass flux is at SST 145 !146 ! clem: without these lbc calls, it seems that the northfold is not ok (true in 3.6, not sure in 4.x)147 CALL lbc_lnk_multi( 'sbcflx', utau, 'U', -1._wp, vtau, 'V', -1._wp, &148 & qns, 'T', 1._wp, emp , 'T', 1._wp, qsr, 'T', 1._wp ) !! sfx, 'T', 1._wp )149 147 ! 150 148 IF( nitend-nit000 <= 100 .AND. lwp ) THEN ! control print (if less than 100 time-step asked) … … 172 170 END_2D 173 171 ! 174 CALL lbc_lnk _multi( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp )172 CALL lbc_lnk( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp ) 175 173 ! 176 174 END SUBROUTINE sbc_flx -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/sbcice_cice.F90
r14275 r14448 222 222 END_2D 223 223 224 CALL lbc_lnk _multi( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp )224 CALL lbc_lnk( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp ) 225 225 226 226 ! set the snow+ice mass … … 569 569 fmmflx(:,:) = ztmp1(:,:) !!Joakim edit 570 570 571 CALL lbc_lnk _multi( 'sbcice_cice', emp , 'T', 1.0_wp, sfx , 'T', 1.0_wp )571 CALL lbc_lnk( 'sbcice_cice', emp , 'T', 1.0_wp, sfx , 'T', 1.0_wp ) 572 572 573 573 ! Solar penetrative radiation and non solar surface heat flux … … 626 626 END_2D 627 627 628 CALL lbc_lnk _multi( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp )628 CALL lbc_lnk( 'sbcice_cice', fr_iu , 'U', 1.0_wp, fr_iv , 'V', 1.0_wp ) 629 629 630 630 ! set the snow+ice mass -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/SBC/sbcwave.F90
r14072 r14448 211 211 ENDIF 212 212 213 CALL lbc_lnk _multi( 'sbcwave', usd, 'U', -1.0_wp, vsd, 'V', -1.0_wp )213 CALL lbc_lnk( 'sbcwave', usd, 'U', -1.0_wp, vsd, 'V', -1.0_wp ) 214 214 215 215 ! … … 503 503 ! 504 504 CALL fld_fill( sf_sd, slf_i, cn_dir, 'sbc_wave_init', 'Wave module ', 'namsbc_wave' ) 505 sf_sd(jp_usd)%zsgn = -1._wp ; sf_sd(jp_vsd)%zsgn = -1._wp ! vector field at T point: overwrite default definition of zsgn 505 506 ENDIF 506 507 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traadv.F90
r14189 r14448 182 182 CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order 183 183 IF (nn_hls.EQ.2) THEN 184 CALL lbc_lnk _multi( 'traadv', pts(:,:,:,:,Kbb), 'T', 1., pts(:,:,:,:,Kmm), 'T', 1.)185 CALL lbc_lnk _multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.)184 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1., pts(:,:,:,:,Kmm), 'T', 1.) 185 CALL lbc_lnk( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 186 186 #if defined key_loop_fusion 187 187 CALL tra_adv_fct_lf ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v ) … … 208 208 CASE ( np_QCK ) ! QUICKEST 209 209 IF (nn_hls.EQ.2) THEN 210 CALL lbc_lnk _multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.)210 CALL lbc_lnk( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 211 211 CALL lbc_lnk( 'traadv', pts(:,:,:,:,Kbb), 'T', 1.) 212 212 END IF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traadv_cen.F90
r14072 r14448 119 119 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 120 120 END_3D 121 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond.121 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_cen', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. 122 122 ! 123 123 DO_3D( nn_hls-1, 0, nn_hls-1, 0, 1, jpkm1 ) ! Horizontal advective fluxes … … 131 131 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v 132 132 END_3D 133 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. )133 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) 134 134 ! 135 135 CASE DEFAULT -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traadv_fct.F90
r14298 r14448 238 238 END_2D 239 239 END DO 240 CALL lbc_lnk _multi( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn)240 CALL lbc_lnk( 'traadv_fct', zltu, 'T', 1.0_wp , zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 241 241 ! 242 242 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) … … 247 247 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - zwy(ji,jj,jk) 248 248 END_3D 249 IF (nn_hls.EQ.2) CALL lbc_lnk _multi( 'traadv_fct', zwx, 'U', -1.0_wp, zwy, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn)249 IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv_fct', zwx, 'U', -1.0_wp, zwy, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 250 250 ! 251 251 CASE( 41 ) !- 4th order centered ==>> !!gm coding attempt need to be tested … … 256 256 ztv(ji,jj,jk) = ( pt(ji ,jj+1,jk,jn,Kmm) - pt(ji,jj,jk,jn,Kmm) ) * vmask(ji,jj,jk) 257 257 END_3D 258 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn)258 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_fct', ztu, 'U', -1.0_wp , ztv, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 259 259 ! 260 260 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes … … 268 268 zwy(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) 269 269 END_3D 270 IF (nn_hls.EQ.2) CALL lbc_lnk _multi( 'traadv_fct', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn)270 IF (nn_hls.EQ.2) CALL lbc_lnk( 'traadv_fct', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 271 271 ! 272 272 END SELECT … … 292 292 ! 293 293 IF (nn_hls.EQ.1) THEN 294 CALL lbc_lnk _multi( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp )294 CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp, zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp, zwz, 'T', 1.0_wp ) 295 295 ELSE 296 296 CALL lbc_lnk( 'traadv_fct', zwi, 'T', 1.0_wp) … … 449 449 END_2D 450 450 END DO 451 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign)451 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_fct', zbetup, 'T', 1.0_wp , zbetdo, 'T', 1.0_wp ) ! lateral boundary cond. (unchanged sign) 452 452 453 453 ! 3. monotonic flux in the i & j direction (paa & pbb) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traadv_fct_lf.F90
r14072 r14448 270 270 END_2D 271 271 END DO 272 CALL lbc_lnk _multi( 'traadv_fct', zltu_3d, 'T', 1.0_wp , zltv_3d, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn)272 CALL lbc_lnk( 'traadv_fct', zltu_3d, 'T', 1.0_wp , zltv_3d, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 273 273 ! ! 274 274 DO_3D( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 ) … … 280 280 END_3D 281 281 ! 282 CALL lbc_lnk _multi( 'traadv_fct', zwx_3d, 'U', -1.0_wp , zwy_3d, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn)282 CALL lbc_lnk( 'traadv_fct', zwx_3d, 'U', -1.0_wp , zwy_3d, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 283 283 CASE( 41 ) !- 4th order centered ==>> !!gm coding attempt need to be tested 284 284 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) ! Horizontal advective fluxes … … 298 298 zwy_3d(ji,jj,jk) = 0.5_wp * pV(ji,jj,jk) * zC4t_v - zwy_3d(ji,jj,jk) 299 299 END_3D 300 CALL lbc_lnk _multi( 'traadv_fct', zwx_3d, 'U', -1.0_wp , zwy_3d, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn)300 CALL lbc_lnk( 'traadv_fct', zwx_3d, 'U', -1.0_wp , zwy_3d, 'V', -1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 301 301 ! 302 302 END SELECT -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traadv_mus.F90
r14072 r14448 140 140 END_3D 141 141 ! lateral boundary conditions (changed sign) 142 IF ( nn_hls.EQ.1 ) CALL lbc_lnk _multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp )142 IF ( nn_hls.EQ.1 ) CALL lbc_lnk( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) 143 143 ! !-- Slopes of tracer 144 144 zslpx(:,:,jpk) = 0._wp ! bottom values … … 176 176 zwy(ji,jj,jk) = pV(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) 177 177 END_3D 178 IF ( nn_hls.EQ.1 ) CALL lbc_lnk _multi( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! lateral boundary conditions (changed sign)178 IF ( nn_hls.EQ.1 ) CALL lbc_lnk( 'traadv_mus', zwx, 'U', -1.0_wp , zwy, 'V', -1.0_wp ) ! lateral boundary conditions (changed sign) 179 179 ! 180 180 DO_3D( 0, 0, 0, 0, 1, jpkm1 ) !-- Tracer advective trend -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traadv_qck.F90
r14215 r14448 149 149 zfd(ji,jj,jk) = pt(ji+1,jj,jk,jn,Kbb) ! Downstream in the x-direction for the tracer 150 150 END_3D 151 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions151 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 152 152 153 153 ! … … 167 167 END_3D 168 168 !--- Lateral boundary conditions 169 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwx(:,:,:), 'T', 1.0_wp )169 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwx(:,:,:), 'T', 1.0_wp ) 170 170 171 171 !--- QUICKEST scheme … … 239 239 END_2D 240 240 END DO 241 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions241 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfc(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp ) ! Lateral boundary conditions 242 242 243 243 ! … … 259 259 260 260 !--- Lateral boundary conditions 261 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp )261 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1.0_wp , zfd(:,:,:), 'T', 1.0_wp, zfc(:,:,:), 'T', 1.0_wp, zwy(:,:,:), 'T', 1.0_wp ) 262 262 263 263 !--- QUICKEST scheme -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traadv_ubs.F90
r14072 r14448 140 140 ! 141 141 END DO 142 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'traadv_ubs', zltu, 'T', 1.0_wp, zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn)142 IF (nn_hls.EQ.1) CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1.0_wp, zltv, 'T', 1.0_wp ) ! Lateral boundary cond. (unchanged sgn) 143 143 ! 144 144 DO_3D( 1, 0, 1, 0, 1, jpkm1 ) !== Horizontal advective fluxes ==! (UBS) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traatf.F90
r14072 r14448 110 110 #endif 111 111 ! ! local domain boundaries (T-point, unchanged sign) 112 CALL lbc_lnk _multi( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp )112 CALL lbc_lnk( 'traatf', pts(:,:,:,jp_tem,Kaa), 'T', 1.0_wp, pts(:,:,:,jp_sal,Kaa), 'T', 1.0_wp ) 113 113 ! 114 114 IF( ln_bdy ) CALL bdy_tra( kt, Kbb, pts, Kaa ) ! BDY open boundaries … … 156 156 ENDIF 157 157 ! 158 CALL lbc_lnk _multi( 'traatf', pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp )158 CALL lbc_lnk( 'traatf', pts(:,:,:,jp_tem,Kmm) , 'T', 1.0_wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1.0_wp ) 159 159 160 160 ENDIF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traatf_qco.F90
r14072 r14448 146 146 ENDIF 147 147 ! 148 CALL lbc_lnk _multi( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp )148 CALL lbc_lnk( 'traatfqco', pts(:,:,:,jp_tem,Kmm) , 'T', 1._wp, pts(:,:,:,jp_sal,Kmm) , 'T', 1._wp ) 149 149 ! 150 150 ENDIF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/trabbl.F90
r14215 r14448 141 141 IF( ntile == 0 .OR. ntile == nijtile ) THEN ! Do only on the last tile 142 142 ! lateral boundary conditions ; just need for outputs 143 CALL lbc_lnk _multi( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp )143 CALL lbc_lnk( 'trabbl', utr_bbl, 'U', 1.0_wp , vtr_bbl, 'V', 1.0_wp ) 144 144 CALL iom_put( "uoce_bbl", utr_bbl ) ! bbl i-transport 145 145 CALL iom_put( "voce_bbl", vtr_bbl ) ! bbl j-transport … … 522 522 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 523 523 zmbku(:,:) = REAL( mbku_d(:,:), wp ) ; zmbkv(:,:) = REAL( mbkv_d(:,:), wp ) 524 CALL lbc_lnk _multi( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp)524 CALL lbc_lnk( 'trabbl', zmbku,'U',1.0_wp, zmbkv,'V',1.0_wp) 525 525 mbku_d(:,:) = MAX( INT( zmbku(:,:) ), 1 ) ; mbkv_d(:,:) = MAX( NINT( zmbkv(:,:) ), 1 ) 526 526 ! … … 541 541 e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 542 542 END_2D 543 CALL lbc_lnk _multi( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp ) ! lateral boundary conditions543 CALL lbc_lnk( 'trabbl', e3u_bbl_0, 'U', 1.0_wp , e3v_bbl_0, 'V', 1.0_wp ) ! lateral boundary conditions 544 544 ! 545 545 ! !* masked diffusive flux coefficients -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/tramle.F90
r14210 r14448 361 361 rfv(ji,jj) = SQRT( zfv * zfv + z1_t2 ) 362 362 END_2D 363 CALL lbc_lnk _multi( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp )363 CALL lbc_lnk( 'tramle', rfu, 'U', 1.0_wp , rfv, 'V', 1.0_wp ) 364 364 ! 365 365 ELSEIF( nn_mle == 1 ) THEN ! MLE array allocation & initialisation -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/trazdf.F90
r14189 r14448 102 102 END DO 103 103 !!gm this should be moved in trdtra.F90 and done on all trends 104 CALL lbc_lnk _multi( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp )104 CALL lbc_lnk( 'trazdf', ztrdt, 'T', 1.0_wp , ztrds, 'T', 1.0_wp ) 105 105 !!gm 106 106 CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_zdf, ztrdt ) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/zpshde.F90
r14189 r14448 173 173 END DO 174 174 ! 175 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond.175 IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 176 176 ! 177 177 IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) … … 206 206 ENDIF 207 207 END_2D 208 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions208 IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions 209 209 ! 210 210 END IF … … 359 359 END DO 360 360 ! 361 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond.361 IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgtu(:,:,:), 'U', -1.0_wp , pgtv(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 362 362 363 363 ! horizontal derivative of density anomalies (rd) … … 401 401 END_2D 402 402 403 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions403 IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgru , 'U', -1.0_wp , pgrv , 'V', -1.0_wp ) ! Lateral boundary conditions 404 404 ! 405 405 END IF … … 452 452 ! 453 453 END DO 454 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond.454 IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgtui(:,:,:), 'U', -1.0_wp , pgtvi(:,:,:), 'V', -1.0_wp ) ! Lateral boundary cond. 455 455 456 456 IF( PRESENT( prd ) ) THEN !== horizontal derivative of density anomalies (rd) ==! (optional part) … … 491 491 492 492 END_2D 493 IF (nn_hls.EQ.1) CALL lbc_lnk _multi( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions493 IF (nn_hls.EQ.1) CALL lbc_lnk( 'zpshde', pgrui, 'U', -1.0_wp , pgrvi, 'V', -1.0_wp ) ! Lateral boundary conditions 494 494 ! 495 495 END IF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRD/trddyn.F90
r13497 r14448 128 128 z3dy(ji,jj,jk) = vv(ji,jj,jk,Kmm) * ( vv(ji,jj+1,jk,Kmm) - vv(ji,jj-1,jk,Kmm) ) / ( 2._wp * e2v(ji,jj) ) 129 129 END_3D 130 CALL lbc_lnk _multi( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp )130 CALL lbc_lnk( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) 131 131 CALL iom_put( "utrd_udx", z3dx ) 132 132 CALL iom_put( "vtrd_vdy", z3dy ) … … 164 164 ! END DO 165 165 ! END DO 166 ! CALL lbc_lnk _multi( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp )166 ! CALL lbc_lnk( 'trddyn', z3dx, 'U', -1.0_wp, z3dy, 'V', -1.0_wp ) 167 167 ! CALL iom_put( "utrd_bfr", z3dx ) 168 168 ! CALL iom_put( "vtrd_bfr", z3dy ) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRD/trdken.F90
r13295 r14448 90 90 !!---------------------------------------------------------------------- 91 91 ! 92 CALL lbc_lnk _multi( 'trdken', putrd, 'U', -1.0_wp , pvtrd, 'V', -1.0_wp ) ! lateral boundary conditions92 CALL lbc_lnk( 'trdken', putrd, 'U', -1.0_wp , pvtrd, 'V', -1.0_wp ) ! lateral boundary conditions 93 93 ! 94 94 nkstp = kt -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRD/trdmxl.F90
r13497 r14448 154 154 !!gm to be put juste before the output ! 155 155 ! ! Lateral boundary conditions 156 ! CALL lbc_lnk _multi( 'trdmxl', tmltrd(:,:,jl), 'T', 1.0_wp , smltrd(:,:,jl), 'T', 1.0_wp )156 ! CALL lbc_lnk( 'trdmxl', tmltrd(:,:,jl), 'T', 1.0_wp , smltrd(:,:,jl), 'T', 1.0_wp ) 157 157 !!gm end 158 158 … … 472 472 !-- Lateral boundary conditions 473 473 ! ... temperature ... ... salinity ... 474 CALL lbc_lnk _multi( 'trdmxl', ztmltot , 'T', 1.0_wp, zsmltot , 'T', 1.0_wp, &475 &ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, &476 &ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp )474 CALL lbc_lnk( 'trdmxl', ztmltot , 'T', 1.0_wp, zsmltot , 'T', 1.0_wp, & 475 & ztmlres , 'T', 1.0_wp, zsmlres , 'T', 1.0_wp, & 476 & ztmlatf , 'T', 1.0_wp, zsmlatf , 'T', 1.0_wp ) 477 477 478 478 … … 523 523 !-- Lateral boundary conditions 524 524 ! ... temperature ... ... salinity ... 525 CALL lbc_lnk _multi( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, &526 &ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp )527 ! 528 CALL lbc_lnk _multi( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! / in the NetCDF trends file525 CALL lbc_lnk( 'trdmxl', ztmltot2, 'T', 1.0_wp, zsmltot2, 'T', 1.0_wp, & 526 & ztmlres2, 'T', 1.0_wp, zsmlres2, 'T', 1.0_wp ) 527 ! 528 CALL lbc_lnk( 'trdmxl', ztmltrd2(:,:,:), 'T', 1.0_wp, zsmltrd2(:,:,:), 'T', 1.0_wp ) ! / in the NetCDF trends file 529 529 530 530 ! III.3 Time evolution array swap -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRD/trdvor.F90
r13497 r14448 162 162 163 163 zudpvor(:,:) = 0._wp ; zvdpvor(:,:) = 0._wp ! Initialisation 164 CALL lbc_lnk _multi( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp ) ! lateral boundary condition164 CALL lbc_lnk( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp ) ! lateral boundary condition 165 165 166 166 … … 251 251 zvdpvor(:,:) = 0._wp 252 252 ! ! lateral boundary condition on input momentum trends 253 CALL lbc_lnk _multi( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp )253 CALL lbc_lnk( 'trdvor', putrdvor, 'U', -1.0_wp , pvtrdvor, 'V', -1.0_wp ) 254 254 255 255 ! ===================================== … … 400 400 401 401 ! Boundary conditions 402 CALL lbc_lnk _multi( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp )402 CALL lbc_lnk( 'trdvor', vor_avrtot, 'F', 1.0_wp , vor_avrres, 'F', 1.0_wp ) 403 403 404 404 -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/USR/README.rst
r14239 r14448 58 58 59 59 .. _here: https://prodn.idris.fr/thredds/catalog/ipsl_public/rron463/catalog.html 60 61 Option 4: Use the nesting tools to create embedded zooms or regional configurations from an existing grid 62 --------------------------------------------------------------------------------------------------------- 63 (see :download:`NESTING README <../../../tools/NESTING/README>`). 64 60 65 61 66 Creating a completely new configuration … … 111 116 /* configuration name, configuration resolution */ 112 117 int ORCA, ORCA_index 113 /* global domain sizes */114 int jpiglo, jpjglo, jpkglo115 118 /* lateral global domain b.c. */ 116 int jperio119 int Iperio, Jperio, NFoldT, NFoldF 117 120 /* flags for z-coord, z-coord with partial steps and s-coord */ 118 121 int ln_zco, ln_zps, ln_sco -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/USR/usrdef_nam.F90
r14072 r14448 37 37 CONTAINS 38 38 39 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)39 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 40 40 !!---------------------------------------------------------------------- 41 41 !! *** ROUTINE dom_nam *** … … 49 49 !! ** input : - namusr_def namelist found in namelist_cfg 50 50 !!---------------------------------------------------------------------- 51 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 52 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 53 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 54 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 51 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 52 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 53 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 54 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 55 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 56 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 55 57 ! 56 58 INTEGER :: ios ! Local integer … … 82 84 kpk = jpkglo 83 85 ! ! Set the lateral boundary condition of the global domain 84 kperio = 0 ! GYRE configuration : closed domain 86 ldIperio = .FALSE. ; ldJperio = .FALSE. ! GYRE configuration : closed domain 87 ldNFold = .FALSE. ; cdNFtype = '-' 85 88 ! 86 89 ! ! control print … … 102 105 WRITE(numout,*) ' number of model levels jpkglo = ', kpk 103 106 WRITE(numout,*) ' ' 104 WRITE(numout,*) ' Lateral b.c. of the global domain set to closed jperio = ', kperio105 107 ENDIF 106 108 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/USR/usrdef_sbc.F90
r13295 r14448 181 181 wndm(ji,jj) = SQRT( zmod * zcoef ) 182 182 END_2D 183 CALL lbc_lnk _multi( 'usrdef_sbc', taum(:,:), 'T', 1.0_wp , wndm(:,:), 'T', 1.0_wp )183 CALL lbc_lnk( 'usrdef_sbc', taum(:,:), 'T', 1.0_wp , wndm(:,:), 'T', 1.0_wp ) 184 184 185 185 ! ---------------------------------- ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ZDF/zdfmfc.F90
r14072 r14448 376 376 ! 377 377 ! 378 CALL lbc_lnk _multi( 'zdfmfc', edmfm,'T',1., edmfa,'T',1., edmfb,'T',1., edmfc,'T',1., edmftra(:,:,:,jp_tem),'T',1., edmftra(:,:,:,jp_sal),'T',1.)378 CALL lbc_lnk( 'zdfmfc', edmfm,'T',1., edmfa,'T',1., edmfb,'T',1., edmfc,'T',1., edmftra(:,:,:,jp_tem),'T',1., edmftra(:,:,:,jp_sal),'T',1.) 379 379 ! 380 380 END SUBROUTINE tra_mfc -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ZDF/zdfosm.F90
r14215 r14448 1163 1163 END_3D 1164 1164 ! Lateral boundary conditions on ghamu and ghamv, currently on W-grid (sign unchanged), needed to caclulate gham[uv] on u and v grids 1165 CALL lbc_lnk _multi( 'zdfosm', p_avt, 'W', 1.0_wp , p_avm, 'W', 1.0_wp, &1166 &ghamu, 'W', 1.0_wp , ghamv, 'W', 1.0_wp )1165 CALL lbc_lnk( 'zdfosm', p_avt, 'W', 1.0_wp , p_avm, 'W', 1.0_wp, & 1166 & ghamu, 'W', 1.0_wp , ghamv, 'W', 1.0_wp ) 1167 1167 DO_3D( 0, 0, 0, 0, 2, jpkm1 ) 1168 1168 ghamu(ji,jj,jk) = ( ghamu(ji,jj,jk) + ghamu(ji+1,jj,jk) ) & … … 1176 1176 END_3D 1177 1177 ! Lateral boundary conditions on final outputs for hbl, on T-grid (sign unchanged) 1178 CALL lbc_lnk _multi( 'zdfosm', hbl, 'T', 1., dh, 'T', 1., hmle, 'T', 1. )1178 CALL lbc_lnk( 'zdfosm', hbl, 'T', 1., dh, 'T', 1., hmle, 'T', 1. ) 1179 1179 ! Lateral boundary conditions on final outputs for gham[ts], on W-grid (sign unchanged) 1180 1180 ! Lateral boundary conditions on final outputs for gham[uv], on [UV]-grid (sign changed) 1181 CALL lbc_lnk _multi( 'zdfosm', ghamt, 'W', 1.0_wp , ghams, 'W', 1.0_wp, &1182 &ghamu, 'U', -1.0_wp , ghamv, 'V', -1.0_wp )1181 CALL lbc_lnk( 'zdfosm', ghamt, 'W', 1.0_wp , ghams, 'W', 1.0_wp, & 1182 & ghamu, 'U', -1.0_wp , ghamv, 'V', -1.0_wp ) 1183 1183 1184 1184 IF(ln_dia_osm) THEN -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/ZDF/zdfphy.F90
r14072 r14448 323 323 ! !* Lateral boundary conditions (sign unchanged) 324 324 IF( l_zdfsh2 ) THEN 325 CALL lbc_lnk _multi( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp, &326 & avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp )325 CALL lbc_lnk( 'zdfphy', avm_k, 'W', 1.0_wp , avt_k, 'W', 1.0_wp, & 326 & avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) 327 327 ELSE 328 CALL lbc_lnk _multi( 'zdfphy', avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp )328 CALL lbc_lnk( 'zdfphy', avm , 'W', 1.0_wp , avt , 'W', 1.0_wp , avs , 'W', 1.0_wp ) 329 329 ENDIF 330 330 ! 331 331 IF( l_zdfdrg ) THEN ! drag have been updated (non-linear cases) 332 IF( ln_isfcav ) THEN ; CALL lbc_lnk _multi( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp ) ! top & bot drag333 ELSE ; CALL lbc_lnk 332 IF( ln_isfcav ) THEN ; CALL lbc_lnk( 'zdfphy', rCdU_top, 'T', 1.0_wp , rCdU_bot, 'T', 1.0_wp ) ! top & bot drag 333 ELSE ; CALL lbc_lnk( 'zdfphy', rCdU_bot, 'T', 1.0_wp ) ! bottom drag only 334 334 ENDIF 335 335 ENDIF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/lib_fortran.F90
r13327 r14448 220 220 ! 221 221 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 222 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & 222 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1) 223 223 & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box 224 224 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box … … 230 230 END_2D 231 231 CALL lbc_lnk( 'lib_fortran', p2d, 'T', 1.0_wp ) 232 ! no need for 2nd exchange when nn_hls = 2 233 IF( nn_hls /= 2 ) THEN 234 IF( nbondi /= -1 ) THEN 235 IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:) 236 IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:) 237 ENDIF 238 IF( nbondi /= 1 ) THEN 232 ! no need for 2nd exchange when nn_hls > 1 233 IF( nn_hls == 1 ) THEN 234 IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN ! 1st column was changed during the previous call to lbc_lnk 235 IF( MOD(mig( 1), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally 236 p2d( 1,:) = p2d( 2,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2 237 IF( MOD(mig( 1), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh 238 p2d( 2,:) = p2d( 1,:) ! previous lbc_lnk fix column 1 -> copy it to column 2 239 ENDIF 240 IF( mpiRnei(nn_hls,jpea) > -1 ) THEN 239 241 IF( MOD(mig(jpi-2), 3) == 1 ) p2d( jpi,:) = p2d(jpi-1,:) 240 242 IF( MOD(mig(jpi-2), 3) == 0 ) p2d(jpi-1,:) = p2d( jpi,:) 241 243 ENDIF 242 IF( nbondj /=-1 ) THEN244 IF( mpiRnei(nn_hls,jpso) > -1 ) THEN 243 245 IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2) 244 246 IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1) 245 247 ENDIF 246 IF( nbondj /=1 ) THEN248 IF( mpiRnei(nn_hls,jpno) > -1 ) THEN 247 249 IF( MOD(mjg(jpj-2), 3) == 1 ) p2d(:, jpj) = p2d(:,jpj-1) 248 250 IF( MOD(mjg(jpj-2), 3) == 0 ) p2d(:,jpj-1) = p2d(:, jpj) … … 274 276 ! 275 277 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 276 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & 278 IF( MOD(mig(ji), 3) == MOD(nn_hls, 3) .AND. & ! 1st bottom left corner always at (Nis0-1, Njs0-1) 277 279 & MOD(mjg(jj), 3) == MOD(nn_hls, 3) ) THEN ! bottom left corner of a 3x3 box 278 280 ji2 = MIN(mig(ji)+2, jpiglo) - nimpp + 1 ! right position of the box … … 285 287 END DO 286 288 CALL lbc_lnk( 'lib_fortran', p3d, 'T', 1.0_wp ) 287 ! no need for 2nd exchange when nn_hls = 2 288 IF( nn_hls /= 2 ) THEN 289 IF( nbondi /= -1 ) THEN 290 IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:) 291 IF( MOD(mig( 1), 3) == 2 ) p3d( 2,:,:) = p3d( 1,:,:) 292 ENDIF 293 IF( nbondi /= 1 ) THEN 289 ! no need for 2nd exchange when nn_hls > 1 290 IF( nn_hls == 1 ) THEN 291 IF( mpiRnei(nn_hls,jpwe) > -1 ) THEN ! 1st column was changed during the previous call to lbc_lnk 292 IF( MOD(mig( 1), 3) == 1 ) & ! 1st box start at i=1 -> column 1 to 3 correctly computed locally 293 p3d( 1,:,:) = p3d( 2,:,:) ! previous lbc_lnk corrupted column 1 -> put it back using column 2 294 IF( MOD(mig( 1), 3) == 2 ) & ! 1st box start at i=3 -> column 1 and 2 correctly computed on west neighbourh 295 p3d( 2,:,:) = p3d( 1,:,:) ! previous lbc_lnk fix column 1 -> copy it to column 2 296 ENDIF 297 IF( mpiRnei(nn_hls,jpea) > -1 ) THEN 294 298 IF( MOD(mig(jpi-2), 3) == 1 ) p3d( jpi,:,:) = p3d(jpi-1,:,:) 295 299 IF( MOD(mig(jpi-2), 3) == 0 ) p3d(jpi-1,:,:) = p3d( jpi,:,:) 296 300 ENDIF 297 IF( nbondj /=-1 ) THEN301 IF( mpiRnei(nn_hls,jpso) > -1 ) THEN 298 302 IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:) 299 303 IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:) 300 304 ENDIF 301 IF( nbondj /=1 ) THEN305 IF( mpiRnei(nn_hls,jpno) > -1 ) THEN 302 306 IF( MOD(mjg(jpj-2), 3) == 1 ) p3d(:, jpj,:) = p3d(:,jpj-1,:) 303 307 IF( MOD(mjg(jpj-2), 3) == 0 ) p3d(:,jpj-1,:) = p3d(:, jpj,:) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/module_example.F90
r14041 r14448 127 127 ! WARNING! the lbc_lnk call could not be compatible with the tiling approach 128 128 ! please refer to the manual for how to adapt your code 129 CALL lbc_lnk( 'module_example', avm, 'T', 1., ncsten=true ) ! Lateral boundary conditions (unchanged sign) 130 ! ! ncsten=false for 5-points stencil communication 131 ! ! ncsten=true (default) for 9-points stencil communication 129 CALL lbc_lnk( 'module_example', avm, 'T', 1. ) ! Lateral boundary conditions (unchanged sign) 132 130 ! 133 131 END SUBROUTINE exa_mpl -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/nemogcm.F90
r14239 r14448 378 378 ! 379 379 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 380 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)380 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 381 381 ELSE ! user-defined namelist 382 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)382 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 383 383 ENDIF 384 384 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/par_kind.F90
r13226 r14448 10 10 IMPLICIT NONE 11 11 PRIVATE 12 13 INTEGER, PUBLIC, PARAMETER :: jpbyt = 8 !: real size for mpp communications14 INTEGER, PUBLIC, PARAMETER :: jpbytda = 4 !: real size in input data files 4 or 815 12 16 13 ! Number model from which the SELECTED_*_KIND are requested: -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/par_oce.F90
r14072 r14448 91 91 92 92 ! halo with and starting/inding DO-loop indices 93 INTEGER, PUBLIC :: nn_hls !: halo width (applies to both rows and columns)94 INTEGER, PUBLIC :: Nis0 , Nis1, Nis1nxt2, Nis2 !: start I-index (_0: without halo, _1 or _2: with 1 or 2 halos)95 INTEGER, PUBLIC :: Nie0 , Nie1, Nie1nxt2, Nie2 !: end I-index (_0: without halo, _1 or _2: with 1 or 2 halos)96 INTEGER, PUBLIC :: Njs0 , Njs1, Njs1nxt2, Njs2 !: start J-index (_0: without halo, _1 or _2: with 1 or 2 halos)97 INTEGER, PUBLIC :: Nje0 , Nje1, Nje1nxt2, Nje2 !: end J-index (_0: without halo, _1 or _2: with 1 or 2 halos)98 INTEGER, PUBLIC :: Ni_0, Nj_0 , Ni_1, Nj_1, Ni_2, Nj_2 !: domain size (_0: without halo, _1 or _2: with 1 or 2 halos)99 INTEGER, PUBLIC :: Ni0glo, Nj0glo 93 INTEGER, PUBLIC :: nn_hls !: halo width (applies to both rows and columns) 94 INTEGER, PUBLIC :: Nis0 !: start I-index without halo 95 INTEGER, PUBLIC :: Nie0 !: end I-index without halo 96 INTEGER, PUBLIC :: Njs0 !: start J-index without halo 97 INTEGER, PUBLIC :: Nje0 !: end J-index without halo 98 INTEGER, PUBLIC :: Ni_0, Nj_0 !: local domain size without halo 99 INTEGER, PUBLIC :: Ni0glo, Nj0glo !: global domain size without halo 100 100 101 101 !!---------------------------------------------------------------------- -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/stpctl.F90
r14318 r14448 123 123 ! !== done by all processes at every time step ==! 124 124 ! 125 llmsk( 1:Nis1,:,:) = .FALSE.! exclude halos from the checked region126 llmsk(Nie 1:jpi,:,:) = .FALSE.127 llmsk(:, 1:Njs1,:) = .FALSE.128 llmsk(:,Nje 1:jpj,:) = .FALSE.125 llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region 126 llmsk(Nie0+1: jpi,:,:) = .FALSE. 127 llmsk(:, 1:nn_hls,:) = .FALSE. 128 llmsk(:,Nje0+1: jpj,:) = .FALSE. 129 129 ! 130 130 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp ! define only the inner domain -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/stpmlf.F90
r14239 r14448 508 508 # endif 509 509 ! ! local domain boundaries (T-point, unchanged sign) 510 CALL lbc_lnk _multi( 'finalize_lbc', puu(:,:,:, Kaa), 'U', -1., pvv(:,:,: ,Kaa), 'V', -1. &511 & 510 CALL lbc_lnk( 'finalize_lbc', puu(:,:,:, Kaa), 'U', -1., pvv(:,:,: ,Kaa), 'V', -1. & 511 & , pts(:,:,:,jp_tem,Kaa), 'T', 1., pts(:,:,:,jp_sal,Kaa), 'T', 1. ) 512 512 ! 513 513 ! !* BDY open boundaries -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OFF/nemogcm.F90
r14255 r14448 309 309 ! 310 310 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 311 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)311 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 312 312 ELSE ! user-defined namelist 313 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)313 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 314 314 ENDIF 315 315 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/SAO/nemogcm.F90
r14239 r14448 207 207 ! 208 208 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 209 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)209 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 210 210 ELSE ! user-defined namelist 211 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)211 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 212 212 ENDIF 213 213 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/SAS/nemogcm.F90
r14239 r14448 340 340 ! 341 341 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 342 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)342 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 343 343 ELSE ! user-defined namelist 344 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)344 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 345 345 ENDIF 346 346 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/SAS/stpctl.F90
r14318 r14448 122 122 ! !== done by all processes at every time step ==! 123 123 ! 124 llmsk( 1:Nis1,:) = .FALSE.! exclude halos from the checked region125 llmsk(Nie 1:jpi,:) = .FALSE.126 llmsk(:, 1:Njs1) = .FALSE.127 llmsk(:,Nje 1:jpj) = .FALSE.124 llmsk( 1:nn_hls,:) = .FALSE. ! exclude halos from the checked region 125 llmsk(Nie0+1: jpi,:) = .FALSE. 126 llmsk(:, 1:nn_hls) = .FALSE. 127 llmsk(:,Nje0+1: jpj) = .FALSE. 128 128 ! 129 129 llmsk(Nis0:Nie0,Njs0:Nje0) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! test only the inner domain -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/SWE/nemogcm.F90
r14239 r14448 261 261 ! 262 262 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 263 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)263 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 264 264 ELSE ! user-defined namelist 265 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)265 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 266 266 ENDIF 267 267 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/SWE/stpctl.F90
r14318 r14448 113 113 ! !== done by all processes at every time step ==! 114 114 ! 115 llmsk( 1:Nis1,:,:) = .FALSE.! exclude halos from the checked region116 llmsk(Nie 1:jpi,:,:) = .FALSE.117 llmsk(:, 1:Njs1,:) = .FALSE.118 llmsk(:,Nje 1:jpj,:) = .FALSE.115 llmsk( 1:nn_hls,:,:) = .FALSE. ! exclude halos from the checked region 116 llmsk(Nie0+1: jpi,:,:) = .FALSE. 117 llmsk(:, 1:nn_hls,:) = .FALSE. 118 llmsk(:,Nje0+1: jpj,:) = .FALSE. 119 119 ! 120 120 llmsk(Nis0:Nie0,Njs0:Nje0,1) = ssmask(Nis0:Nie0,Njs0:Nje0) == 1._wp ! define only the inner domain -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/SWE/stpmlf.F90
r14318 r14448 197 197 ENDIF 198 198 199 CALL lbc_lnk _multi( 'stp_MLF', uu(:,:,:,Nnn), 'U', -1., vv(:,:,:,Nnn), 'V', -1., & !* local domain boundaries200 & 199 CALL lbc_lnk( 'stp_MLF', uu(:,:,:,Nnn), 'U', -1., vv(:,:,:,Nnn), 'V', -1., & !* local domain boundaries 200 & uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. ) 201 201 202 202 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/SWE/stprk3.F90
r14318 r14448 171 171 ENDIF 172 172 ! 173 CALL lbc_lnk _multi( 'stp_RK3', uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. )173 CALL lbc_lnk( 'stp_RK3', uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. ) 174 174 ! 175 175 ! !== Swap time levels ==! … … 236 236 ENDIF 237 237 ! 238 CALL lbc_lnk _multi( 'stp_RK3', uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. )238 CALL lbc_lnk( 'stp_RK3', uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. ) 239 239 ! 240 240 ! !== Swap time levels ==! … … 299 299 ENDIF 300 300 ! 301 CALL lbc_lnk _multi( 'stp_RK3', uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. )301 CALL lbc_lnk( 'stp_RK3', uu(:,:,:,Naa), 'U', -1., vv(:,:,:,Naa), 'V', -1. ) 302 302 ! 303 303 ! !== Swap time levels ==! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/TOP/PISCES/P2Z/p2zbio.F90
r13295 r14448 340 340 IF( lk_iomput ) THEN 341 341 CALL lbc_lnk( 'p2zbio', zw2d(:,:,:),'T', 1.0_wp ) 342 CALL lbc_lnk _multi( 'p2zbio', zw3d(:,:,:,1),'T', 1.0_wp, zw3d(:,:,:,2),'T', 1.0_wp, zw3d(:,:,:,3),'T', 1.0_wp )342 CALL lbc_lnk( 'p2zbio', zw3d(:,:,:,1),'T', 1.0_wp, zw3d(:,:,:,2),'T', 1.0_wp, zw3d(:,:,:,3),'T', 1.0_wp ) 343 343 ! Save diagnostics 344 344 CALL iom_put( "TNO3PHY", zw2d(:,:,1) ) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/TOP/README.rst
r14239 r14448 376 376 .. code-block:: perl 377 377 378 bld::tool::fppkeys key_zdftke key_dynspg_tskey_xios key_top378 bld::tool::fppkeys key_xios key_top 379 379 inc <MYBGCPATH>/MYBGC.fcm 380 380 -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/TOP/TRP/trcadv.F90
r14086 r14448 131 131 CASE ( np_FCT ) ! FCT : 2nd / 4th order 132 132 IF (nn_hls.EQ.2) THEN 133 CALL lbc_lnk _multi( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1., ptr(:,:,:,:,Kmm), 'T', 1.)134 CALL lbc_lnk _multi( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.)133 CALL lbc_lnk( 'trcadv', ptr(:,:,:,:,Kbb), 'T', 1., ptr(:,:,:,:,Kmm), 'T', 1.) 134 CALL lbc_lnk( 'traadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1., zww(:,:,:), 'W', 1.) 135 135 #if defined key_loop_fusion 136 136 CALL tra_adv_fct_lf( kt, nittrc000,'TRC', rDt_trc, zuu, zvv, zww, Kbb, Kmm, ptr, jptra, Krhs, nn_fct_h, nn_fct_v ) … … 157 157 CASE ( np_QCK ) ! QUICKEST 158 158 IF (nn_hls.EQ.2) THEN 159 CALL lbc_lnk _multi( 'trcadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.)159 CALL lbc_lnk( 'trcadv', zuu(:,:,:), 'U', -1., zvv(:,:,:), 'V', -1.) 160 160 CALL lbc_lnk( 'traadv', ptr(:,:,:,:,Kbb), 'T', 1.) 161 161 END IF -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/TOP/TRP/trdmxl_trc.F90
r13497 r14448 419 419 !-- Lateral boundary conditions 420 420 IF ( cn_cfg .NE. 'gyre' ) THEN 421 CALL lbc_lnk _multi( 'trdmxl_trc', ztmltot(:,:,jn) , 'T', 1. , ztmlres(:,:,jn) , 'T', 1., &422 & ztmlatf(:,:,jn) , 'T', 1. , ztmlrad(:,:,jn) , 'T', 1. )421 CALL lbc_lnk( 'trdmxl_trc', ztmltot(:,:,jn) , 'T', 1. , ztmlres(:,:,jn) , 'T', 1., & 422 & ztmlatf(:,:,jn) , 'T', 1. , ztmlrad(:,:,jn) , 'T', 1. ) 423 423 ENDIF 424 424 … … 470 470 !-- Lateral boundary conditions 471 471 IF ( cn_cfg .NE. 'gyre' ) THEN ! other than GYRE configuration 472 CALL lbc_lnk _multi( 'trdmxl_trc', ztmltot2(:,:,jn), 'T', 1., ztmlres2(:,:,jn), 'T', 1. )472 CALL lbc_lnk( 'trdmxl_trc', ztmltot2(:,:,jn), 'T', 1., ztmlres2(:,:,jn), 'T', 1. ) 473 473 DO jl = 1, jpltrd_trc 474 474 CALL lbc_lnk( 'trdmxl_trc', ztmltrd2(:,:,jl,jn), 'T', 1. ) ! will be output in the NetCDF trends file -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/TOP/oce_trc.F90
r13333 r14448 19 19 USE par_oce , ONLY : jp_sal => jp_sal !: indice for salinity 20 20 USE par_oce , ONLY : nn_hls => nn_hls !: 21 USE par_oce , ONLY : Nis0 => Nis0 !: 22 USE par_oce , ONLY : Njs0 => Njs0 !: 23 USE par_oce , ONLY : Nie0 => Nie0 !: 24 USE par_oce , ONLY : Nje0 => Nje0 !: 25 USE par_oce , ONLY : Nis1 => Nis1 !: 26 USE par_oce , ONLY : Njs1 => Njs1 !: 27 USE par_oce , ONLY : Nie1 => Nie1 !: 28 USE par_oce , ONLY : Nje1 => Nje1 !: 29 USE par_oce , ONLY : Nis1nxt2 => Nis1nxt2 !: 30 USE par_oce , ONLY : Njs1nxt2 => Njs1nxt2 !: 31 USE par_oce , ONLY : Nie1nxt2 => Nie1nxt2 !: 32 USE par_oce , ONLY : Nje1nxt2 => Nje1nxt2 !: 33 USE par_oce , ONLY : Nis2 => Nis2 !: 34 USE par_oce , ONLY : Njs2 => Njs2 !: 35 USE par_oce , ONLY : Nie2 => Nie2 !: 36 USE par_oce , ONLY : Nje2 => Nje2 !: 37 USE par_oce , ONLY : Ni_0 => Ni_0 !: 38 USE par_oce , ONLY : Nj_0 => Nj_0 !: 39 USE par_oce , ONLY : Ni_1 => Ni_1 !: 40 USE par_oce , ONLY : Nj_1 => Nj_1 !: 41 USE par_oce , ONLY : Ni_2 => Ni_2 !: 42 USE par_oce , ONLY : Nj_2 => Nj_2 !: 21 USE par_oce , ONLY : Nis0 => Nis0 !: 22 USE par_oce , ONLY : Njs0 => Njs0 !: 23 USE par_oce , ONLY : Nie0 => Nie0 !: 24 USE par_oce , ONLY : Nje0 => Nje0 !: 25 USE par_oce , ONLY : Ni_0 => Ni_0 !: 26 USE par_oce , ONLY : Nj_0 => Nj_0 !: 43 27 44 28 USE in_out_manager !* IO manager * -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/BENCH/EXPREF/namelist_cfg_orca025_like
r14229 r14448 18 18 nn_jsize = 1206 !! 1049 ! number of point in j-direction of global(local) domain if >0 (<0) 19 19 nn_ksize = 75 ! total number of point in k-direction 20 nn_perio = 4 ! periodicity 20 ln_Iperio = .true. ! i-periodicity 21 ln_Jperio = .false. ! j-periodicity 22 ln_NFold = .true. ! North pole folding 23 cn_NFtype = 'T' ! Folding type: T or F 21 24 / 22 25 !----------------------------------------------------------------------- -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/BENCH/EXPREF/namelist_cfg_orca12_like
r14229 r14448 18 18 nn_jsize = 3146 ! number of point in j-direction of global(local) domain if >0 (<0) 19 19 nn_ksize = 75 ! total number of point in k-direction 20 nn_perio = 4 ! periodicity 20 ln_Iperio = .true. ! i-periodicity 21 ln_Jperio = .false. ! j-periodicity 22 ln_NFold = .true. ! North pole folding 23 cn_NFtype = 'T' ! Folding type: T or F 21 24 / 22 25 !----------------------------------------------------------------------- -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/BENCH/EXPREF/namelist_cfg_orca1_like
r14229 r14448 18 18 nn_jsize = 331 ! number of point in j-direction of global(local) domain if >0 (<0) 19 19 nn_ksize = 75 ! total number of point in k-direction 20 nn_perio = 6 ! periodicity 20 ln_Iperio = .true. ! i-periodicity 21 ln_Jperio = .false. ! j-periodicity 22 ln_NFold = .true. ! North pole folding 23 cn_NFtype = 'F' ! Folding type: T or F 21 24 / 22 25 !----------------------------------------------------------------------- -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/BENCH/MY_SRC/usrdef_nam.F90
r13286 r14448 29 29 CONTAINS 30 30 31 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)31 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 32 32 !!---------------------------------------------------------------------- 33 33 !! *** ROUTINE dom_nam *** … … 41 41 !! ** input : - namusr_def namelist found in namelist_cfg 42 42 !!---------------------------------------------------------------------- 43 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 44 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 45 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 46 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 47 ! 43 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 44 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 45 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 46 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 47 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 48 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 48 49 ! 49 50 INTEGER :: ios ! Local integer … … 52 53 INTEGER :: nn_jsize ! number of point in j-direction of global(local) domain if >0 (<0) 53 54 INTEGER :: nn_ksize ! total number of point in k-direction 54 INTEGER :: nn_perio ! periodicity55 55 ! !!* nammpp namelist *!! 56 56 INTEGER :: jpni, jpnj 57 LOGICAL :: ln_nnogather, ln_listonly 57 LOGICAL :: ln_listonly 58 LOGICAL :: ln_Iperio, ln_Jperio 59 LOGICAL :: ln_NFold 60 character(len=1) :: cn_NFtype 58 61 !! 59 NAMELIST/namusr_def/ nn_isize, nn_jsize, nn_ksize, nn_perio60 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly 62 NAMELIST/namusr_def/ nn_isize, nn_jsize, nn_ksize, ln_Iperio, ln_Jperio, ln_NFold, cn_NFtype 63 NAMELIST/nammpp/ jpni, jpnj, nn_hls, ln_nnogather, ln_listonly, nn_comm 61 64 !!---------------------------------------------------------------------- 62 65 ! … … 83 86 kpj = nn_jsize 84 87 ENDIF 88 kpk = nn_ksize 85 89 ! 86 kpk = nn_ksize 87 kperio = nn_perio 90 ldIperio = ln_Iperio ; ldJperio = ln_Jperio 91 ldNFold = ln_NFold ; cdNFtype = cn_NFtype 92 ! 88 93 ! ! control print 89 94 IF(lwp) THEN … … 107 112 ENDIF 108 113 WRITE(numout,*) ' global domain size-z nn_ksize = ', nn_ksize 109 WRITE(numout,*) ' LBC of the global domain kperio = ', kperio114 WRITE(numout,*) ' ' 110 115 ENDIF 111 116 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/BENCH/MY_SRC/usrdef_sbc.F90
r14273 r14448 110 110 END_2D 111 111 112 CALL lbc_lnk _multi( 'usrdef_sbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. )112 CALL lbc_lnk( 'usrdef_sbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) 113 113 #endif 114 114 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/BENCH/MY_SRC/usrdef_zgr.F90
r13286 r14448 197 197 ! 198 198 199 !!$ IF( jperio == 3 .OR. jperio == 4) THEN ! add a small island in the upper corners to avoid model instabilities...199 !!$ IF( c_NFtype == 'T' ) THEN ! add a small island in the upper corners to avoid model instabilities... 200 200 !!$ z2d(mi0( nn_hls):mi1( nn_hls+2 ),mj0(jpjglo-nn_hls-1):mj1(jpjglo-nn_hls+1)) = 0. 201 201 !!$ z2d(mi0(jpiglo-nn_hls):mi1(MIN(jpiglo,jpiglo-nn_hls+2)),mj0(jpjglo-nn_hls-1):mj1(jpjglo-nn_hls+1)) = 0. … … 203 203 !!$ ENDIF 204 204 !!$ ! 205 !!$ IF( jperio == 5 .OR. jperio == 6) THEN ! add a small island in the upper corners to avoid model instabilities...205 !!$ IF( c_NFtype == 'F' ) THEN ! add a small island in the upper corners to avoid model instabilities... 206 206 !!$ z2d(mi0( nn_hls):mi1( nn_hls+1),mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls+1)) = 0. 207 207 !!$ z2d(mi0(jpiglo-nn_hls):mi1(jpiglo-nn_hls+1),mj0(jpjglo-nn_hls):mj1(jpjglo-nn_hls+1)) = 0. … … 210 210 211 211 ! 212 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero ( here jperio=0 ==>> closed)212 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (closed boundaries) 213 213 ! 214 214 k_bot(:,:) = INT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/C1D_ASICS/MY_SRC/usrdef_nam.F90
r14021 r14448 39 39 CONTAINS 40 40 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 ) 42 42 !!---------------------------------------------------------------------- 43 43 !! *** ROUTINE dom_nam *** … … 51 51 !! ** input : - namusr_def namelist found in namelist_cfg 52 52 !!---------------------------------------------------------------------- 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 57 59 ! 58 60 INTEGER :: ios ! Local integer … … 72 74 kpi = 3 73 75 kpj = 3 74 kpk = 75 76 kpk = 75 75 77 ! ! 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 = '-' 77 80 ! 78 81 ! ! control print … … 90 93 WRITE(numout,*) ' jpjglo = ', kpj 91 94 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,*) ' ' 94 96 ENDIF 95 97 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/CANAL/EXPREF/namelist_cfg
r14229 r14448 49 49 ln_sshnoise = .FALSE. ! add random noise on initial ssh 50 50 rn_lambda = 50. ! gaussian lambda 51 nn_perio = 1 51 ln_Iperio = .true. ! i-periodicity 52 ln_Jperio = .false. ! j-periodicity 52 53 / 53 54 !----------------------------------------------------------------------- -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/CANAL/MY_SRC/usrdef_hgr.F90
r14223 r14448 64 64 ! 65 65 INTEGER :: ji, jj ! dummy loop indices 66 REAL(wp) :: zphi0, zlam0, zbeta, zf0 66 INTEGER :: ii0, ij0 ! dummy loop indices 67 REAL(wp) :: zbeta, zf0 67 68 REAL(wp) :: zti, ztj ! local scalars 68 69 !!------------------------------------------------------------------------------- … … 77 78 ! Position coordinates (in kilometers) 78 79 ! ========== 79 zlam0 = -REAL(Ni0glo, wp) * rn_0xratio * rn_dx80 zphi0 = -REAL(Nj0glo, wp) * rn_0yratio * rn_dy80 ii0 = NINT( REAL(Ni0glo, wp) * rn_0xratio ) 81 ij0 = NINT( REAL(Nj0glo, wp) * rn_0yratio ) 81 82 82 83 #if defined key_agrif 83 84 ! ! let lower left longitude and latitude from parent 84 85 IF (.NOT.Agrif_root()) THEN 85 zlam0 = (0.5_wp-(Agrif_parent(jpiglo)-1)/2)*Agrif_irhox()*rn_dx & 86 &+(Agrif_Ix()+nbghostcells-1)*Agrif_irhox()*rn_dx-(0.5_wp+nbghostcells)*rn_dx 87 zphi0 = (0.5_wp-(Agrif_parent(jpjglo)-1)/2)*Agrif_irhoy()*rn_dy & 88 &+(Agrif_Iy()+nbghostcells-1)*Agrif_irhoy()*rn_dy-(0.5_wp+nbghostcells)*rn_dy 86 to be coded... 89 87 ENDIF 90 88 #endif 91 89 92 90 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 93 zti = REAL( mig0(ji) , wp ) - 0.5_wp ! start at i=0.5in the global grid without halos94 ztj = REAL( mjg0(jj) , wp ) - 0.5_wp ! start at j=0.5in the global grid without halos91 zti = REAL( mig0(ji)-ii0, wp ) ! =0 at i=ii0 in the global grid without halos 92 ztj = REAL( mjg0(jj)-ij0, wp ) ! =0 at i=ij0 in the global grid without halos 95 93 96 plamt(ji,jj) = zlam0 +rn_dx * zti97 plamu(ji,jj) = zlam0 +rn_dx * ( zti + 0.5_wp )94 plamt(ji,jj) = rn_dx * zti 95 plamu(ji,jj) = rn_dx * ( zti + 0.5_wp ) 98 96 plamv(ji,jj) = plamt(ji,jj) 99 97 plamf(ji,jj) = plamu(ji,jj) 100 98 101 pphit(ji,jj) = zphi0 +rn_dy * ztj102 pphiv(ji,jj) = zphi0 +rn_dy * ( ztj + 0.5_wp )99 pphit(ji,jj) = rn_dy * ztj 100 pphiv(ji,jj) = rn_dy * ( ztj + 0.5_wp ) 103 101 pphiu(ji,jj) = pphit(ji,jj) 104 102 pphif(ji,jj) = pphiv(ji,jj) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/CANAL/MY_SRC/usrdef_istate.F90
r14224 r14448 239 239 ! 240 240 CALL lbc_lnk( 'usrdef_istate', pts , 'T', 1. ) 241 CALL lbc_lnk _multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. )241 CALL lbc_lnk( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. ) 242 242 243 243 END SUBROUTINE usr_def_istate -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/CANAL/MY_SRC/usrdef_nam.F90
r13472 r14448 50 50 LOGICAL , PUBLIC :: ln_sshnoise=.false. ! add random noise on initial ssh 51 51 REAL(wp), PUBLIC :: rn_lambda = 50. ! gaussian lambda 52 INTEGER , PUBLIC :: nn_perio = 0 ! periodicity of the channel (0=closed, 1=E-W)53 52 54 53 !!---------------------------------------------------------------------- … … 59 58 CONTAINS 60 59 61 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)60 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 62 61 !!---------------------------------------------------------------------- 63 62 !! *** ROUTINE dom_nam *** … … 71 70 !! ** input : - namusr_def namelist found in namelist_cfg 72 71 !!---------------------------------------------------------------------- 73 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 74 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 75 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 76 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 72 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 73 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 74 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 75 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 76 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 77 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 77 78 ! 78 79 INTEGER :: ios ! Local integer 79 80 REAL(wp):: zh ! Local scalars 81 LOGICAL :: ln_Iperio, ln_Jperio 80 82 !! 81 83 NAMELIST/namusr_def/ rn_domszx, rn_domszy, rn_domszz, rn_dx, rn_dy, rn_dz, rn_0xratio, rn_0yratio & 82 84 & , nn_fcase, rn_ppgphi0, rn_u10, rn_windszx, rn_windszy & !!, rn_uofac & 83 85 & , rn_vtxmax, rn_uzonal, rn_ujetszx, rn_ujetszy & 84 & , nn_botcase, nn_initcase, ln_sshnoise, rn_lambda, nn_perio86 & , nn_botcase, nn_initcase, ln_sshnoise, rn_lambda, ln_Iperio, ln_Jperio 85 87 !!---------------------------------------------------------------------- 86 88 ! … … 102 104 #endif 103 105 ! 104 IF(lwm) WRITE( numond, namusr_def )105 !106 106 cd_cfg = 'EW_CANAL' ! name & resolution (not used) 107 107 kk_cfg = INT( rn_dx ) … … 109 109 IF( Agrif_Root() ) THEN ! Global Domain size: EW_CANAL global domain is 1800 km x 1800 Km x 5000 m 110 110 kpi = NINT( rn_domszx / rn_dx ) + 1 111 kpj = NINT( rn_domszy / rn_dy ) + 3111 kpj = NINT( rn_domszy / rn_dy ) + 1 112 112 ELSE ! Global Domain size: add nbghostcells + 1 "land" point on each side 113 113 kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2 … … 117 117 ! 118 118 zh = (kpk-1)*rn_dz 119 ! ! Set the lateral boundary condition of the global domain120 kperio = 1 ! EW_CANAL configuration : closed basin121 119 ! ! control print 122 120 IF(lwp) THEN … … 149 147 WRITE(numout,*) ' add random noise on initial ssh ln_sshnoise= ', ln_sshnoise 150 148 WRITE(numout,*) ' Gaussian lambda parameter rn_lambda = ', rn_lambda 151 WRITE(numout,*) ' Periodicity of the basin nn_perio = ', nn_perio 149 WRITE(numout,*) ' i and j Periodicity ln_Iperio, ln_Jperio = ', ln_Iperio, ln_Jperio 150 WRITE(numout,*) ' ' 152 151 ENDIF 153 152 ! ! Set the lateral boundary condition of the global domain 154 kperio = nn_perio ! EW_CANAL configuration : closed basin 153 ldIperio = ln_Iperio ; ldJperio = ln_Jperio ! CANAL configuration 154 ldNFold = .FALSE. ; cdNFtype = '-' 155 155 ! 156 156 END SUBROUTINE usr_def_nam -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/CANAL/MY_SRC/usrdef_zgr.F90
r13472 r14448 202 202 END SELECT 203 203 ! 204 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero ( here jperio=0 ==>> closed)204 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (closed boundaries) 205 205 ! 206 206 k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/DOME/MY_SRC/usrdef_nam.F90
r14254 r14448 40 40 CONTAINS 41 41 42 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)42 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 43 43 !!---------------------------------------------------------------------- 44 44 !! *** ROUTINE dom_nam *** … … 52 52 !! ** input : - namusr_def namelist found in namelist_cfg 53 53 !!---------------------------------------------------------------------- 54 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 55 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 56 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 57 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 54 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 55 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 56 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 57 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 58 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 59 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 58 60 ! 59 61 INTEGER :: ios ! Local integer … … 97 99 zh = (kpk-1)*rn_dz 98 100 ! ! Set the lateral boundary condition of the global domain 99 kperio = 0 ! DOME configuration : closed basin 101 ldIperio = .FALSE. ; ldJperio = .FALSE. ! DOME configuration : closed domain 102 ldNFold = .FALSE. ; cdNFtype = '-' 103 ! 100 104 ! ! control print 101 105 IF(lwp) THEN … … 118 122 WRITE(numout,*) ' Coriolis frequency rn_f0 = ', rn_f0, ' s-1' 119 123 WRITE(numout,*) ' ' 120 WRITE(numout,*) ' Lateral boundary condition of the global domain'121 WRITE(numout,*) ' DOME : closed basin jperio = ', kperio122 124 ENDIF 123 125 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/DOME/MY_SRC/usrdef_zgr.F90
r14261 r14448 98 98 END DO 99 99 END DO 100 CALL lbc_lnk _multi( 'usrdef_zgr', zhu, 'U', 1.0_wp, zhv, 'V', 1.0_wp, zhf, 'F', 1.0_wp)100 CALL lbc_lnk( 'usrdef_zgr', zhu, 'U', 1.0_wp, zhv, 'V', 1.0_wp, zhf, 'F', 1.0_wp) 101 101 ! 102 102 CALL zgr_z1d( pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d ) ! Reference z-coordinate system … … 106 106 ! 107 107 ! no ocean cavities : top ocean level is ONE, except over land 108 ! the ocean basin surrounded by land (1 grid-point) set through lbc_lnk call as jperio=0108 ! the ocean basin surrounded by land (1+nn_hls grid-point) set through lbc_lnk call 109 109 z2d(:,:) = 1._wp ! surface ocean is the 1st level 110 110 WHERE (gphit(:,:)>0._wp) z2d(:,:) = 0._wp 111 111 ! Dig inlet: 112 112 WHERE ((gphit(:,:)>0._wp).AND.(glamt(:,:)>-50._wp).AND.(glamt(:,:)<50._wp)) z2d(:,:) = 1._wp 113 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin since jperio = 0 (see userdef_nam.F90)113 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin, see userdef_nam.F90 114 114 k_top(:,:) = NINT( z2d(:,:) ) 115 115 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/ICB/MY_SRC/usrdef_nam.F90
r13899 r14448 42 42 CONTAINS 43 43 44 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)44 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 45 45 !!---------------------------------------------------------------------- 46 46 !! *** ROUTINE dom_nam *** … … 54 54 !! ** input : - namusr_def namelist found in namelist_cfg 55 55 !!---------------------------------------------------------------------- 56 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 57 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 58 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 59 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 56 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 57 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 58 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 59 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 60 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 61 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 60 62 ! 61 63 INTEGER :: ios ! Local integer … … 78 80 ! 79 81 ! ! Set the lateral boundary condition of the global domain 80 kperio = 0 ! ICB configuration : box 82 ldIperio = .FALSE. ; ldJperio = .FALSE. ! ICB configuration : closed domain 83 ldNFold = .FALSE. ; cdNFtype = '-' 81 84 ! 82 85 ! ! control print … … 99 102 WRITE(numout,*) ' jpkglo = ', kpk 100 103 WRITE(numout,*) ' ' 101 WRITE(numout,*) ' Lateral boundary condition of the global domain'102 WRITE(numout,*) ' ICB : closed basin jperio = ', kperio103 104 ENDIF 104 105 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/ICE_ADV1D/MY_SRC/usrdef_nam.F90
r13286 r14448 39 39 CONTAINS 40 40 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 ) 42 42 !!---------------------------------------------------------------------- 43 43 !! *** ROUTINE dom_nam *** … … 51 51 !! ** input : - namusr_def namelist found in namelist_cfg 52 52 !!---------------------------------------------------------------------- 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 57 59 ! 58 60 INTEGER :: ios ! Local integer … … 78 80 zly = kpj*rn_dy*1.e-3 79 81 ! ! Set the lateral boundary condition of the global domain 80 kperio = 0 ! ICE_ADV1D configuration : bi-periodic basin 82 ldIperio = .FALSE. ; ldJperio = .FALSE. ! ICE_ADV1D configuration : closed domain 83 ldNFold = .FALSE. ; cdNFtype = '-' 84 ! 81 85 ! ! control print 82 86 IF(lwp) THEN … … 95 99 WRITE(numout,*) ' Coriolis:', ln_corio 96 100 WRITE(numout,*) ' ' 97 WRITE(numout,*) ' Lateral boundary condition of the global domain'98 WRITE(numout,*) ' ICE_ADV1D : closed basin jperio = ', kperio99 101 ENDIF 100 102 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/ICE_ADV2D/MY_SRC/usrdef_nam.F90
r13286 r14448 40 40 CONTAINS 41 41 42 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)42 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 43 43 !!---------------------------------------------------------------------- 44 44 !! *** ROUTINE dom_nam *** … … 52 52 !! ** input : - namusr_def namelist found in namelist_cfg 53 53 !!---------------------------------------------------------------------- 54 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 55 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 56 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 57 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 54 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 55 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 56 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 57 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 58 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 59 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 58 60 ! 59 61 INTEGER :: ios ! Local integer … … 96 98 zly = kpj*rn_dy*1.e-3 97 99 ! 98 IF( Agrif_Root() ) THEN ; kperio = 7 ! ICE_AGRIFconfiguration : bi-periodic basin99 ELSE ; kperio = 0! closed periodicity for the zoom100 IF( Agrif_Root() ) THEN ; ldIperio = .TRUE. ; ldJperio = .TRUE. ! ICE_ADV2D configuration : bi-periodic basin 101 ELSE ; ldIperio = .FALSE. ; ldJperio = .FALSE. ! closed periodicity for the zoom 100 102 ENDIF 103 ldNFold = .FALSE. ; cdNFtype = '-' 104 ! 101 105 ! ! control print 102 106 IF(lwp) THEN … … 115 119 WRITE(numout,*) ' Coriolis:', ln_corio 116 120 WRITE(numout,*) ' ' 117 WRITE(numout,*) ' Lateral boundary condition of the global domain'118 WRITE(numout,*) ' ICE_ADV2D : bi-periodic basin jperio = ', kperio119 121 ENDIF 120 122 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/ICE_AGRIF/MY_SRC/usrdef_nam.F90
r14223 r14448 40 40 CONTAINS 41 41 42 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)42 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 43 43 !!---------------------------------------------------------------------- 44 44 !! *** ROUTINE dom_nam *** … … 52 52 !! ** input : - namusr_def namelist found in namelist_cfg 53 53 !!---------------------------------------------------------------------- 54 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 55 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 56 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 57 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 54 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 55 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 56 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 57 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 58 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 59 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 58 60 ! 59 61 INTEGER :: ios ! Local integer … … 98 100 zly = kpj*rn_dy*1.e-3 99 101 ! 100 IF( Agrif_Root() ) THEN ; kperio = 7! ICE_AGRIF configuration : bi-periodic basin101 ELSE ; kperio = 0! closed periodicity for the zoom102 IF( Agrif_Root() ) THEN ; ldIperio = .TRUE. ; ldJperio = .TRUE. ! ICE_AGRIF configuration : bi-periodic basin 103 ELSE ; ldIperio = .FALSE. ; ldJperio = .FALSE. ! closed periodicity for the zoom 102 104 ENDIF 105 ldNFold = .FALSE. ; cdNFtype = '-' 106 ! 103 107 ! ! control print 104 108 IF(lwp) THEN … … 117 121 WRITE(numout,*) ' Coriolis:', ln_corio 118 122 WRITE(numout,*) ' ' 119 WRITE(numout,*) ' Lateral boundary condition of the global domain'120 WRITE(numout,*) ' ICE_AGRIF : bi-periodic basin jperio = ', kperio121 123 ENDIF 122 124 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/ICE_RHEO/MY_SRC/icedyn_rhg_eap.F90
r14120 r14448 354 354 355 355 END_2D 356 CALL lbc_lnk _multi( 'icedyn_rhg_eap', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp )356 CALL lbc_lnk( 'icedyn_rhg_eap', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp ) 357 357 ! 358 358 ! !== Landfast ice parameterization ==! … … 492 492 zs2(ji,jj) = ( zs2(ji,jj) * zalph1 + zstressmtmp ) * z1_alph1 493 493 END_2D 494 CALL lbc_lnk _multi( 'icedyn_rhg_eap', zstress12tmp, 'T', 1.0_wp , paniso_11, 'T', 1.0_wp , paniso_12, 'T', 1.0_wp)494 CALL lbc_lnk( 'icedyn_rhg_eap', zstress12tmp, 'T', 1.0_wp , paniso_11, 'T', 1.0_wp , paniso_12, 'T', 1.0_wp) 495 495 496 496 ! Save beta at T-points for further computations … … 520 520 521 521 END_2D 522 CALL lbc_lnk _multi( 'icedyn_rhg_eap', zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp, zs12, 'F', 1.0_wp )522 CALL lbc_lnk( 'icedyn_rhg_eap', zs1, 'T', 1.0_wp, zs2, 'T', 1.0_wp, zs12, 'F', 1.0_wp ) 523 523 524 524 ! --- Ice internal stresses (Appendix C of Hunke and Dukowicz, 2002) --- ! … … 832 832 833 833 END_2D 834 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, &835 & 836 & 834 CALL lbc_lnk( 'icedyn_rhg_eap', pshear_i, 'T', 1.0_wp, pdivu_i, 'T', 1.0_wp, pdelta_i, 'T', 1.0_wp, & 835 & zten_i, 'T', 1.0_wp, zs1 , 'T', 1.0_wp, zs2 , 'T', 1.0_wp, & 836 & zs12, 'F', 1.0_wp ) 837 837 838 838 ! --- Store the stress tensor for the next time step --- ! … … 849 849 & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN 850 850 ! 851 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, &852 & 851 CALL lbc_lnk( 'icedyn_rhg_eap', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, ztaux_ai, 'U', -1.0_wp, & 852 & ztauy_ai, 'V', -1.0_wp, ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 853 853 ! 854 854 CALL iom_put( 'utau_oi' , ztaux_oi * aimsk00 ) … … 934 934 IF( iom_use('yield11') .OR. iom_use('yield12') .OR. iom_use('yield22')) THEN 935 935 936 CALL lbc_lnk _multi( 'icedyn_rhg_eap', zyield11, 'T', 1.0_wp, zyield22, 'T', 1.0_wp, zyield12, 'T', 1.0_wp )936 CALL lbc_lnk( 'icedyn_rhg_eap', zyield11, 'T', 1.0_wp, zyield22, 'T', 1.0_wp, zyield12, 'T', 1.0_wp ) 937 937 938 938 CALL iom_put( 'yield11', zyield11 * aimsk00 ) … … 951 951 & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN 952 952 ! 953 CALL lbc_lnk _multi( 'icedyn_rhg_eap', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, &954 & 955 & 953 CALL lbc_lnk( 'icedyn_rhg_eap', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & 954 & zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, & 955 & zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) 956 956 957 957 CALL iom_put( 'dssh_dx' , zspgU * aimsk00 ) ! Sea-surface tilt term in force balance (x) … … 985 985 END_2D 986 986 987 CALL lbc_lnk _multi( 'icedyn_rhg_eap', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, &988 & 989 & 987 CALL lbc_lnk( 'icedyn_rhg_eap', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & 988 & zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & 989 & zdiag_xatrp , 'U', -1.0_wp, zdiag_yatrp , 'V', -1.0_wp ) 990 990 991 991 CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/ICE_RHEO/MY_SRC/icedyn_rhg_evp.F90
r14021 r14448 320 320 321 321 END_2D 322 CALL lbc_lnk _multi( 'icedyn_rhg_evp', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp )322 CALL lbc_lnk( 'icedyn_rhg_evp', zmf, 'T', 1.0_wp, zdt_m, 'T', 1.0_wp ) 323 323 ! 324 324 ! !== Landfast ice parameterization ==! … … 770 770 771 771 END_2D 772 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, &773 & 772 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, & 773 & zs1 , 'T', 1._wp, zs2 , 'T', 1._wp, zs12 , 'F', 1._wp ) 774 774 775 775 ! --- Store the stress tensor for the next time step --- ! … … 786 786 & iom_use('utau_bi') .OR. iom_use('vtau_bi') ) THEN 787 787 ! 788 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, & 789 & ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 788 CALL lbc_lnk( 'icedyn_rhg_evp', ztaux_oi, 'U', -1.0_wp, ztauy_oi, 'V', -1.0_wp, & 789 & ztaux_ai, 'U', -1.0_wp, ztauy_ai, 'V', -1.0_wp, & 790 & ztaux_bi, 'U', -1.0_wp, ztauy_bi, 'V', -1.0_wp ) 790 791 ! 791 792 CALL iom_put( 'utau_oi' , ztaux_oi * zmsk00 ) … … 871 872 & iom_use('corstrx') .OR. iom_use('corstry') .OR. iom_use('intstrx') .OR. iom_use('intstry') ) THEN 872 873 ! 873 CALL lbc_lnk _multi( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, &874 & 874 CALL lbc_lnk( 'icedyn_rhg_evp', zspgU, 'U', -1.0_wp, zspgV, 'V', -1.0_wp, & 875 & zCorU, 'U', -1.0_wp, zCorV, 'V', -1.0_wp, zfU, 'U', -1.0_wp, zfV, 'V', -1.0_wp ) 875 876 876 877 CALL iom_put( 'dssh_dx' , zspgU * zmsk00 ) ! Sea-surface tilt term in force balance (x) … … 904 905 END_2D 905 906 906 CALL lbc_lnk _multi( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, &907 & 908 & 907 CALL lbc_lnk( 'icedyn_rhg_evp', zdiag_xmtrp_ice, 'U', -1.0_wp, zdiag_ymtrp_ice, 'V', -1.0_wp, & 908 & zdiag_xmtrp_snw, 'U', -1.0_wp, zdiag_ymtrp_snw, 'V', -1.0_wp, & 909 & zdiag_xatrp , 'U', -1.0_wp, zdiag_yatrp , 'V', -1.0_wp ) 909 910 910 911 CALL iom_put( 'xmtrpice' , zdiag_xmtrp_ice ) ! X-component of sea-ice mass transport (kg/s) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/ICE_RHEO/MY_SRC/usrdef_nam.F90
r14021 r14448 40 40 CONTAINS 41 41 42 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)42 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 43 43 !!---------------------------------------------------------------------- 44 44 !! *** ROUTINE dom_nam *** … … 52 52 !! ** input : - namusr_def namelist found in namelist_cfg 53 53 !!---------------------------------------------------------------------- 54 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 55 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 56 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 57 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 54 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 55 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 56 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 57 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 58 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 59 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 58 60 ! 59 61 INTEGER :: ios ! Local integer … … 81 83 zly = kpj*rn_dy*1.e-3 82 84 ! 83 kperio = 0 ! closed periodicity for the zoom 85 ldIperio = .FALSE. ; ldJperio = .FALSE. ! ICE_RHEO configuration : closed domain 86 ldNFold = .FALSE. ; cdNFtype = '-' 87 ! 84 88 ! ! control print 85 89 IF(lwp) THEN … … 98 102 WRITE(numout,*) ' Coriolis:', ln_corio 99 103 WRITE(numout,*) ' ' 100 WRITE(numout,*) ' Lateral boundary condition of the global domain'101 WRITE(numout,*) ' ICE_RHEO closed basin jperio = ', kperio102 104 ENDIF 103 105 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/ICE_RHEO/MY_SRC/usrdef_sbc.F90
r14273 r14448 126 126 windv(ji,jj) = Umax/sqrt(d*1000)*(d-2*mjg(jj)*res)/((d-2*mig(ji)*res)**2+(d-2*mjg(jj)*res)**2*Rwind**2)**(1/4)*Rwind*min(kt*30./21600,1.) 127 127 END_2D 128 CALL lbc_lnk _multi( 'usrdef_sbc', windu, 'U', -1., windv, 'V', -1. )128 CALL lbc_lnk( 'usrdef_sbc', windu, 'U', -1., windv, 'V', -1. ) 129 129 130 130 wndm_ice(:,:) = 0._wp !!gm brutal.... … … 156 156 & * ( 0.5 * (windv(ji,jj+1) + windv(ji,jj) ) - r_vfac * v_ice(ji,jj) ) 157 157 END_2D 158 CALL lbc_lnk _multi( 'usrdef_sbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. )158 CALL lbc_lnk( 'usrdef_sbc', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) 159 159 ! 160 160 END SUBROUTINE usrdef_sbc_ice_tau -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/ISOMIP/MY_SRC/usrdef_nam.F90
r13286 r14448 41 41 CONTAINS 42 42 43 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)43 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 44 44 !!---------------------------------------------------------------------- 45 45 !! *** ROUTINE dom_nam *** … … 53 53 !! ** input : - namusr_def namelist found in namelist_cfg 54 54 !!---------------------------------------------------------------------- 55 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 56 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 57 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 58 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 55 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 56 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 57 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 58 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 59 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 60 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 59 61 ! 60 62 INTEGER :: ios ! Local integer … … 77 79 ! 78 80 ! ! Set the lateral boundary condition of the global domain 79 kperio = 0 ! ISOMIP configuration : close basin 81 ldIperio = .FALSE. ; ldJperio = .FALSE. ! ISOMIP configuration : closed domain 82 ldNFold = .FALSE. ; cdNFtype = '-' 80 83 ! 81 84 ! ! control print … … 98 101 WRITE(numout,*) ' jpkglo = ', kpk 99 102 WRITE(numout,*) ' ' 100 WRITE(numout,*) ' Lateral boundary condition of the global domain'101 WRITE(numout,*) ' ISOMIP : closed basin jperio = ', kperio102 103 ENDIF 103 104 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/LOCK_EXCHANGE/MY_SRC/usrdef_nam.F90
r13286 r14448 37 37 CONTAINS 38 38 39 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)39 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 40 40 !!---------------------------------------------------------------------- 41 41 !! *** ROUTINE dom_nam *** … … 49 49 !! ** input : - namusr_def namelist found in namelist_cfg 50 50 !!---------------------------------------------------------------------- 51 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 52 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 53 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 54 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 51 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 52 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 53 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 54 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 55 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 56 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 55 57 ! 56 58 INTEGER :: ios ! Local integer … … 73 75 kpk = INT( 20. / rn_dz ) + 1 74 76 ! ! Set the lateral boundary condition of the global domain 75 kperio = 0 ! LOCK_EXCHANGE configuration : closed domain 77 ldIperio = .FALSE. ; ldJperio = .FALSE. ! LOCK_EXCHANGE configuration : closed domain 78 ldNFold = .FALSE. ; cdNFtype = '-' 76 79 ! 77 80 ! ! control print … … 88 91 WRITE(numout,*) ' jpkglo = ', kpk 89 92 WRITE(numout,*) ' ' 90 WRITE(numout,*) ' Lateral boundary condition of the global domain'91 WRITE(numout,*) ' closed jperio = ', kperio92 93 ENDIF 93 94 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/LOCK_EXCHANGE/MY_SRC/usrdef_zgr.F90
r12377 r14448 84 84 ! 85 85 ! no ocean cavities : top ocean level is ONE, except over land 86 ! the ocean basin surrounded by land (1 grid-point) set through lbc_lnk call as jperio=086 ! the ocean basin surrounded by land (1+nn_hls grid-points) set through lbc_lnk call 87 87 z2d(:,:) = 1._wp ! surface ocean is the 1st level 88 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin since jperio = 0 (see userdef_nam.F90)88 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin, see userdef_nam.F90 89 89 k_top(:,:) = NINT( z2d(:,:) ) 90 90 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/OVERFLOW/MY_SRC/usrdef_nam.F90
r13286 r14448 38 38 CONTAINS 39 39 40 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)40 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 41 41 !!---------------------------------------------------------------------- 42 42 !! *** ROUTINE dom_nam *** … … 50 50 !! ** input : - namusr_def namelist found in namelist_cfg 51 51 !!---------------------------------------------------------------------- 52 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 53 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 54 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 55 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 52 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 53 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 54 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 55 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 56 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 57 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 56 58 ! 57 59 INTEGER :: ios ! Local integer … … 88 90 WRITE(numout,*) ' Nj0glo = ', kpj 89 91 WRITE(numout,*) ' jpkglo = ', kpk 92 WRITE(numout,*) ' ' 90 93 ! 91 94 ! ! Set the lateral boundary condition of the global domain 92 kperio = 0 ! OVERFLOW configuration : close basin 93 ! 94 WRITE(numout,*) ' ' 95 WRITE(numout,*) ' Lateral boundary condition of the global domain' 96 WRITE(numout,*) ' OVERFLOW : closed basin jperio = ', kperio 95 ldIperio = .FALSE. ; ldJperio = .FALSE. ! OVERFLOW configuration : closed domain 96 ldNFold = .FALSE. ; cdNFtype = '-' 97 97 ! 98 98 END SUBROUTINE usr_def_nam -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/OVERFLOW/MY_SRC/usrdef_zgr.F90
r14053 r14448 110 110 ! 111 111 ! no ocean cavities : top ocean level is ONE, except over land 112 ! the ocean basin surrounded by land (1 grid-point) set through lbc_lnk call as jperio=0112 ! the ocean basin surrounded by land (1+nn_hls grid-points) set through lbc_lnk call 113 113 z2d(:,:) = 1._wp ! surface ocean is the 1st level 114 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin since jperio = 0 (see userdef_nam.F90)114 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin, see userdef_nam.F90 115 115 k_top(:,:) = NINT( z2d(:,:) ) 116 116 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/README.rst
r14226 r14448 206 206 :labelprefix: T 207 207 208 ICE_RHEO 209 -------- 210 | 211 212 BENCH 213 ----- 214 | Benchmark configuration. Allow to run any configuration (including ORCA type or BDY) with idealized grid 215 and initial state so it does not need any input file other than the namelists. 216 As usual, all configuration changes can be done through the namelist. 217 We provide 3 example of namelist_cfg to mimic ORCA1, OR025 or ORCA12 configurations. 218 By default do not produce any output file. An extensive description of BENCH will be abailable in 219 Irrmann et al. 2021. 220 208 221 CPL_OASIS 209 222 --------- 210 223 | This test case checks the OASIS interface in OCE/SBC, allowing to set up 211 a coupled configuration through OASIS. See CPL_OASIS/README.md for more information.224 a coupled configuration through OASIS. See CPL_OASIS/README.md for more information. 212 225 213 226 TSUNAMI 214 227 --------- 215 228 | just use dynspg_ts to simulate the propagation of an ssh anomaly (cosinus) in a box configuration 216 with flat bottom and jpk=2 229 with flat bottom and jpk=2. 217 230 218 231 DONUT 219 232 ----- 220 | Donut shaped configuration to test MPI decomposition with bdy 233 | Donut shaped configuration to test MPI decomposition with bdy. 234 235 C1D_ASICS 236 --------- 237 | 238 239 DOME 240 ---- 241 | 242 243 ICB 244 ---- 245 | ICB is a very idealized configuration used to test and debug the icb module. 246 The configuration is box with a shallow shelf (40m) on the east and west part of the domain 247 with a deep central trough (> 100m). 248 ICB are generating using the test capability of the icb model along a E-W line (this can easily be tuned). 249 250 STATION_ASF 251 ----------- 252 | this demonstration test case can be used to perform a sanity test of the SBCBLK interface of 253 NEMO. It will test all the bulk-parameterization algorithms using an idealized 254 forcing that includes a wide range of *SSX / surface atmospheric state* 255 conditions to detect potential error / inconsistencies. Both a short report and 256 boolean output: *passed* or *failed* is provided as an output. 257 258 SWG 259 --- 260 | Square bassin blown with an analytical wind. Vertical structure allows only one mode 261 associated with reduced gravity to develop. This configuration is based on Adcroft & Marshall 1998. 262 Also run with RK3 time stepping. -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/STATION_ASF/MY_SRC/icesbc.F90
r14072 r14448 91 91 vtau_ice(ji,jj) = vtau_ice(ji,jj) * xcplmask(ji,jj,0) + zvtau_ice(ji,jj) * ( 1. - xcplmask(ji,jj,0) ) 92 92 END_2D 93 CALL lbc_lnk _multi( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp )93 CALL lbc_lnk( 'icesbc', utau_ice, 'U', -1.0_wp, vtau_ice, 'V', -1.0_wp ) 94 94 ENDIF 95 95 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/STATION_ASF/MY_SRC/nemogcm.F90
r14239 r14448 243 243 ! 244 244 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 245 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)245 CALL domain_cfg ( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 246 246 ELSE ! user-defined namelist 247 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, jperio)247 CALL usr_def_nam( cn_cfg, nn_cfg, Ni0glo, Nj0glo, jpkglo, l_Iperio, l_Jperio, l_NFold, c_NFtype ) 248 248 ENDIF 249 249 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/STATION_ASF/MY_SRC/stpctl.F90
r14318 r14448 113 113 ! !== done by all processes at every time step ==! 114 114 ! 115 llmsk( 1:Nis1,:) = .FALSE.! exclude halos from the checked region116 llmsk(Nie 1:jpi,:) = .FALSE.117 llmsk(:, 1:Njs1) = .FALSE.118 llmsk(:,Nje 1:jpj) = .FALSE.115 llmsk( 1:nn_hls,:) = .FALSE. ! exclude halos from the checked region 116 llmsk(Nie0+1: jpi,:) = .FALSE. 117 llmsk(:, 1:nn_hls) = .FALSE. 118 llmsk(:,Nje0+1: jpj) = .FALSE. 119 119 ! 120 120 llmsk(Nis0:Nie0,Njs0:Nje0) = tmask(Nis0:Nie0,Njs0:Nje0,1) == 1._wp ! test only the inner domain -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/STATION_ASF/MY_SRC/usrdef_nam.F90
r14072 r14448 37 37 CONTAINS 38 38 39 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)39 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 40 40 !!---------------------------------------------------------------------- 41 41 !! *** ROUTINE dom_nam *** … … 49 49 !! ** input : - namusr_def namelist found in namelist_cfg 50 50 !!---------------------------------------------------------------------- 51 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 52 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 53 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 54 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 51 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 52 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 53 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 54 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 55 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 56 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 55 57 ! 56 58 INTEGER :: ios ! Local integer … … 73 75 ! 74 76 ! ! Set the lateral boundary condition of the global domain 75 kperio = 7 ! C1D configuration : 3x3 basin with cyclic Est-West and Norht-South condition 77 ldIperio = .TRUE. ; ldJperio = .true. ! C1D configuration : 3x3 basin with cyclic Est-West and Norht-South condition 78 ldNFold = .FALSE. ; cdNFtype = '-' 76 79 ! 77 80 ! ! control print … … 85 88 WRITE(numout,*) ' number of model levels kpk = ', kpk 86 89 WRITE(numout,*) ' ' 87 WRITE(numout,*) ' Lateral b.c. of the domain set to jperio = ', kperio88 90 ENDIF 89 91 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/SWG/MY_SRC/usrdef_nam.F90
r13752 r14448 57 57 CONTAINS 58 58 59 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)59 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 60 60 !!---------------------------------------------------------------------- 61 61 !! *** ROUTINE dom_nam *** … … 69 69 !! ** input : - namusr_def namelist found in namelist_cfg 70 70 !!---------------------------------------------------------------------- 71 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 72 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 73 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 74 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 71 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 72 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 73 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 74 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 75 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 76 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 75 77 ! 76 78 INTEGER :: ios ! Local integer … … 110 112 kpk = jpkglo 111 113 ! ! Set the lateral boundary condition of the global domain 112 kperio = 0 ! SWG configuration : closed domain 114 ldIperio = .FALSE. ; ldJperio = .FALSE. ! SWG configuration : closed domain 115 ldNFold = .FALSE. ; cdNFtype = '-' 113 116 ! 114 117 # if defined key_bvp … … 131 134 WRITE(numout,*) ' number of model levels jpkglo = ', kpk 132 135 WRITE(numout,*) ' ' 133 WRITE(numout,*) ' Lateral b.c. of the global domain set to closed jperio = ', kperio134 136 ENDIF 135 137 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/SWG/MY_SRC/usrdef_sbc.F90
r13752 r14448 104 104 END DO 105 105 106 CALL lbc_lnk _multi( 'usrdef_sbc', taum(:,:), 'T', 1. , wndm(:,:), 'T', 1. )106 CALL lbc_lnk( 'usrdef_sbc', taum(:,:), 'T', 1. , wndm(:,:), 'T', 1. ) 107 107 ! 108 108 END SUBROUTINE usrdef_sbc_oce -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/SWG/MY_SRC/usrdef_zgr.F90
r14204 r14448 190 190 z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom 191 191 ! 192 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (here jperio=0 ==>> closed) 193 ! 194 ! 192 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (closed boundaries) 193 ! 195 194 zylim0 = 10000._wp ! +10km 196 195 zylim1 = 2010000._wp ! 2010km -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/TSUNAMI/EXPREF/namelist_cfg
r14297 r14448 29 29 nn_fcase = 0 ! Coriolis frequency(f) computation (0:f0, 1:Beta plan, 2:real) 30 30 rn_ppgphi0 = 38.5 ! Reference latitude [degrees] 31 nn_perio = 7 31 ln_Iperio = .true. ! i-periodicity 32 ln_Jperio = .true. ! j-periodicity 32 33 / 33 34 !----------------------------------------------------------------------- -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/TSUNAMI/MY_SRC/usrdef_hgr.F90
r14225 r14448 64 64 ! 65 65 INTEGER :: ji, jj ! dummy loop indices 66 REAL(wp) :: zphi0, zlam0, zbeta, zf0 66 INTEGER :: ii0, ij0 ! dummy loop indices 67 REAL(wp) :: zbeta, zf0 67 68 REAL(wp) :: zti, ztj ! local scalars 68 69 !!------------------------------------------------------------------------------- … … 77 78 ! Position coordinates (in kilometers) 78 79 ! ========== 79 zlam0 = -REAL(Ni0glo, wp) * rn_0xratio * rn_dx80 zphi0 = -REAL(Nj0glo, wp) * rn_0yratio * rn_dy80 ii0 = NINT( REAL(Ni0glo, wp) * rn_0xratio ) 81 ij0 = NINT( REAL(Nj0glo, wp) * rn_0yratio ) 81 82 82 83 #if defined key_agrif 83 84 ! ! let lower left longitude and latitude from parent 84 85 IF (.NOT.Agrif_root()) THEN 85 zlam0 = (0.5_wp-(Agrif_parent(jpiglo)-1)/2)*Agrif_irhox()*rn_dx & 86 &+(Agrif_Ix()+nbghostcells-1)*Agrif_irhox()*rn_dx-(0.5_wp+nbghostcells)*rn_dx 87 zphi0 = (0.5_wp-(Agrif_parent(jpjglo)-1)/2)*Agrif_irhoy()*rn_dy & 88 &+(Agrif_Iy()+nbghostcells-1)*Agrif_irhoy()*rn_dy-(0.5_wp+nbghostcells)*rn_dy 86 to be coded... 89 87 ENDIF 90 88 #endif 91 89 92 90 DO_2D( nn_hls, nn_hls, nn_hls, nn_hls ) 93 zti = REAL( mig0(ji) , wp ) - 0.5_wp ! start at i=0.5in the global grid without halos94 ztj = REAL( mjg0(jj) , wp ) - 0.5_wp ! start at j=0.5in the global grid without halos91 zti = REAL( mig0(ji)-ii0, wp ) ! =0 at i=ii0 in the global grid without halos 92 ztj = REAL( mjg0(jj)-ij0, wp ) ! =0 at i=ij0 in the global grid without halos 95 93 96 plamt(ji,jj) = zlam0 +rn_dx * zti97 plamu(ji,jj) = zlam0 +rn_dx * ( zti + 0.5_wp )94 plamt(ji,jj) = rn_dx * zti 95 plamu(ji,jj) = rn_dx * ( zti + 0.5_wp ) 98 96 plamv(ji,jj) = plamt(ji,jj) 99 97 plamf(ji,jj) = plamu(ji,jj) 100 98 101 pphit(ji,jj) = zphi0 +rn_dy * ztj102 pphiv(ji,jj) = zphi0 +rn_dy * ( ztj + 0.5_wp )99 pphit(ji,jj) = rn_dy * ztj 100 pphiv(ji,jj) = rn_dy * ( ztj + 0.5_wp ) 103 101 pphiu(ji,jj) = pphit(ji,jj) 104 102 pphif(ji,jj) = pphiv(ji,jj) -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/TSUNAMI/MY_SRC/usrdef_nam.F90
r14297 r14448 37 37 INTEGER , PUBLIC :: nn_fcase = 1 ! F computation (0:f0, 1:Beta, 2:real) 38 38 REAL(wp), PUBLIC :: rn_ppgphi0 = 38.5 ! reference latitude for beta-plane 39 INTEGER , PUBLIC :: nn_perio = 0 ! periodicity of the channel (0=closed, 1=E-W)40 39 41 40 !!---------------------------------------------------------------------- … … 46 45 CONTAINS 47 46 48 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)47 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 49 48 !!---------------------------------------------------------------------- 50 49 !! *** ROUTINE dom_nam *** … … 58 57 !! ** input : - namusr_def namelist found in namelist_cfg 59 58 !!---------------------------------------------------------------------- 60 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 61 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 62 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 63 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 59 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 60 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 61 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 62 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 63 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 64 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 64 65 ! 65 66 INTEGER :: ios ! Local integer 67 LOGICAL :: ln_Iperio, ln_Jperio 66 68 !! 67 69 NAMELIST/namusr_def/ rn_domszx, rn_domszy, rn_domszz, rn_dx, rn_dy, rn_0xratio, rn_0yratio & 68 & , nn_fcase, rn_ppgphi0, nn_perio70 & , nn_fcase, rn_ppgphi0, ln_Iperio, ln_Jperio 69 71 !!---------------------------------------------------------------------- 70 72 ! … … 85 87 #endif 86 88 ! 87 IF(lwm) WRITE( numond, namusr_def )88 !89 89 cd_cfg = 'TSUNAMI' ! name & resolution (not used) 90 90 kk_cfg = INT( rn_dx ) … … 92 92 IF( Agrif_Root() ) THEN ! Global Domain size: TSUNAMI global domain is 1800 km x 1800 Km x 5000 m 93 93 kpi = NINT( rn_domszx / rn_dx ) + 1 94 kpj = NINT( rn_domszy / rn_dy ) + 394 kpj = NINT( rn_domszy / rn_dy ) + 1 95 95 ELSE ! Global Domain size: add nbghostcells + 1 "land" point on each side 96 96 kpi = nbcellsx + nbghostcells_x + nbghostcells_x + 2 … … 98 98 ENDIF 99 99 kpk = 2 100 ! ! Set the lateral boundary condition of the global domain 101 kperio = 1 ! TSUNAMI configuration : closed basin 102 ! ! control print 100 ! ! Set the lateral boundary condition of the global domain 101 ! 102 ldIperio = ln_Iperio ; ldJperio = ln_Jperio 103 ldNFold = .FALSE. ; cdNFtype = '-' 104 ! 105 ! ! control print 103 106 IF(lwp) THEN 104 107 WRITE(numout,*) ' ' … … 115 118 WRITE(numout,*) ' F computation nn_fcase = ', nn_fcase 116 119 WRITE(numout,*) ' Reference latitude rn_ppgphi0 = ', rn_ppgphi0 117 WRITE(numout,*) ' Periodicity of the basin nn_perio = ', nn_perio120 WRITE(numout,*) ' ' 118 121 ENDIF 119 ! ! Set the lateral boundary condition of the global domain120 kperio = nn_perio ! TSUNAMI configuration : closed basin121 122 ! 122 123 END SUBROUTINE usr_def_nam -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/TSUNAMI/MY_SRC/usrdef_sbc.F90
r14225 r14448 3 3 !! *** MODULE usrdef_sbc *** 4 4 !! 5 !! === CANALconfiguration ===5 !! === TSUNAMI configuration === 6 6 !! 7 7 !! User defined : surface forcing of a user configuration … … 44 44 !! condition, i.e. the momentum, heat and freshwater fluxes. 45 45 !! 46 !! ** Method : all 0 fields, for CANALcase46 !! ** Method : all 0 fields, for TSUNAMI case 47 47 !! CAUTION : never mask the surface stress field ! 48 48 !! … … 57 57 IF( kt == nit000 ) THEN 58 58 ! 59 IF(lwp) WRITE(numout,*)' usr_sbc : EW_CANALcase: surface forcing'59 IF(lwp) WRITE(numout,*)' usr_sbc : TSUNAMI case: surface forcing' 60 60 IF(lwp) WRITE(numout,*)' ~~~~~~~~~~~ vtau = taum = wndm = qns = qsr = emp = sfx = 0' 61 61 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/VORTEX/MY_SRC/usrdef_istate.F90
r14133 r14448 123 123 END_2D 124 124 ! 125 CALL lbc_lnk _multi( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. )125 CALL lbc_lnk( 'usrdef_istate', pu, 'U', -1., pv, 'V', -1. ) 126 126 ! 127 127 END SUBROUTINE usr_def_istate -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/VORTEX/MY_SRC/usrdef_nam.F90
r14086 r14448 40 40 CONTAINS 41 41 42 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)42 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 43 43 !!---------------------------------------------------------------------- 44 44 !! *** ROUTINE dom_nam *** … … 52 52 !! ** input : - namusr_def namelist found in namelist_cfg 53 53 !!---------------------------------------------------------------------- 54 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 55 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 56 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 57 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 54 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 55 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 56 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 57 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 58 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 59 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 58 60 ! 59 61 INTEGER :: ios ! Local integer … … 96 98 zh = (kpk-1)*rn_dz 97 99 ! ! Set the lateral boundary condition of the global domain 98 kperio = 0 ! VORTEX configuration : closed basin 100 ldIperio = .FALSE. ; ldJperio = .FALSE. ! VORTEX configuration : closed domain 101 ldNFold = .FALSE. ; cdNFtype = '-' 102 ! 99 103 ! ! control print 100 104 IF(lwp) THEN … … 115 119 WRITE(numout,*) ' Reference latitude rn_ppgphi0 = ', rn_ppgphi0 116 120 WRITE(numout,*) ' ' 117 WRITE(numout,*) ' Lateral boundary condition of the global domain'118 WRITE(numout,*) ' VORTEX : closed basin jperio = ', kperio119 121 ENDIF 120 122 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/VORTEX/MY_SRC/usrdef_zgr.F90
r12740 r14448 190 190 z2d(:,:) = REAL( jpkm1 , wp ) ! flat bottom 191 191 ! 192 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero ( here jperio=0 ==>> closed)192 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (closed boundaries) 193 193 ! 194 194 k_bot(:,:) = NINT( z2d(:,:) ) ! =jpkm1 over the ocean point, =0 elsewhere -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/WAD/MY_SRC/usrdef_nam.F90
r13286 r14448 38 38 CONTAINS 39 39 40 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio)40 SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, ldIperio, ldJperio, ldNFold, cdNFtype ) 41 41 !!---------------------------------------------------------------------- 42 42 !! *** ROUTINE dom_nam *** … … 50 50 !! ** input : - namusr_def namelist found in namelist_cfg 51 51 !!---------------------------------------------------------------------- 52 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 53 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 54 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 55 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 52 CHARACTER(len=*), INTENT(out) :: cd_cfg ! configuration name 53 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 54 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 55 LOGICAL , INTENT(out) :: ldIperio, ldJperio ! i- and j- periodicity 56 LOGICAL , INTENT(out) :: ldNFold ! North pole folding 57 CHARACTER(len=1), INTENT(out) :: cdNFtype ! Folding type: T or F 56 58 ! 57 59 INTEGER :: ios ! Local integer … … 75 77 kpk = INT( 10. / rn_dz ) + 1 76 78 ! ! Set the lateral boundary condition of the global domain 77 kperio = 0 ! WAD_TEST_CASES configuration : closed domain 79 ldIperio = .FALSE. ; ldJperio = .FALSE. ! WAD_TEST_CASES configuration : closed domain 80 ldNFold = .FALSE. ; cdNFtype = '-' 78 81 IF( nn_wad_test == 8 ) THEN 79 kperio = 7 ! North-South cyclic test82 ldIperio = .TRUE. ; ldJperio = .TRUE. ! WAD_TEST_CASES configuration : bi-periodic 80 83 kpi = kpi - 2 ! no closed boundary 81 84 kpj = kpj - 2 ! no closed boundary … … 95 98 WRITE(numout,*) ' jpkglo = ', kpk 96 99 WRITE(numout,*) ' ' 97 WRITE(numout,*) ' Lateral boundary condition of the global domain'98 WRITE(numout,*) ' closed jperio = ', kperio99 100 ENDIF 100 101 ! -
NEMO/branches/2021/dev_r14383_PISCES_NEWDEV_PISCO/tests/WAD/MY_SRC/usrdef_zgr.F90
r13295 r14448 260 260 ! 261 261 ! no ocean cavities : top ocean level is ONE, except over land 262 ! the ocean basin surrounnded by land (1 grid-point) set through lbc_lnk call as jperio=0262 ! the ocean basin surrounnded by land (1+nn_hls grid-points) set through lbc_lnk call 263 263 z2d(:,:) = 1._wp ! surface ocean is the 1st level 264 264 z2d(mi0(1):mi1(1),:) = 0._wp … … 267 267 z2d(:,mj0(jpjglo):mj1(jpjglo)) = 0._wp 268 268 269 270 271 272 273 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin since jperio = 0 (see userdef_nam.F90) 269 CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! closed basin, see userdef_nam.F90 274 270 k_top(:,:) = NINT( z2d(:,:) ) 275 271 !
Note: See TracChangeset
for help on using the changeset viewer.