Changeset 7646 for trunk/NEMOGCM/NEMO/OPA_SRC/DOM
- Timestamp:
- 2017-02-06T10:25:03+01:00 (7 years ago)
- Location:
- trunk/NEMOGCM/NEMO/OPA_SRC/DOM
- Files:
-
- 3 deleted
- 15 edited
- 1 copied
-
closea.F90 (deleted)
-
daymod.F90 (modified) (6 diffs)
-
depth_e3.F90 (copied) (copied from branches/2016/dev_merge_2016/NEMOGCM/NEMO/OPA_SRC/DOM/depth_e3.F90)
-
dom_oce.F90 (modified) (11 diffs)
-
domain.F90 (modified) (14 diffs)
-
domcfg.F90 (deleted)
-
domhgr.F90 (modified) (7 diffs)
-
dommsk.F90 (modified) (8 diffs)
-
domngb.F90 (modified) (1 diff)
-
domstp.F90 (deleted)
-
domvvl.F90 (modified) (3 diffs)
-
domwri.F90 (modified) (9 diffs)
-
domzgr.F90 (modified) (7 diffs)
-
dtatsd.F90 (modified) (5 diffs)
-
iscplhsb.F90 (modified) (1 diff)
-
iscplini.F90 (modified) (1 diff)
-
iscplrst.F90 (modified) (7 diffs)
-
istate.F90 (modified) (5 diffs)
-
phycst.F90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90
r6140 r7646 2 2 !!====================================================================== 3 3 !! *** MODULE daymod *** 4 !! Ocean :calendar4 !! Ocean : management of the model calendar 5 5 !!===================================================================== 6 6 !! History : OPA ! 1994-09 (M. Pontaud M. Imbard) Original code … … 16 16 !!---------------------------------------------------------------------- 17 17 !! day : calendar 18 !! 19 !! ------------------------------- 20 !! ----------- WARNING ----------- 21 !! 22 !! we suppose that the time step is deviding the number of second of in a day 23 !! ---> MOD( rday, rdt ) == 0 24 !! 25 !! ----------- WARNING ----------- 26 !! ------------------------------- 27 !! 18 !!---------------------------------------------------------------------- 19 !! ----------- WARNING ----------- 20 !! ------------------------------- 21 !! sbcmod assume that the time step is dividing the number of second of 22 !! in a day, i.e. ===> MOD( rday, rdt ) == 0 23 !! except when user defined forcing is used (see sbcmod.F90) 28 24 !!---------------------------------------------------------------------- 29 25 USE dom_oce ! ocean space and time domain 30 26 USE phycst ! physical constants 27 USE ioipsl , ONLY : ymds2ju ! for calendar 28 USE trc_oce , ONLY : l_offline ! offline flag 29 ! 31 30 USE in_out_manager ! I/O manager 31 USE prtctl ! Print control 32 32 USE iom ! 33 USE ioipsl , ONLY : ymds2ju ! for calendar34 USE prtctl ! Print control35 USE trc_oce , ONLY : lk_offline ! offline flag36 33 USE timing ! Timing 37 34 USE restart ! restart … … 47 44 48 45 !!---------------------------------------------------------------------- 49 !! NEMO/OPA 3.3 , NEMO Consortium (2010)46 !! NEMO/OPA 4.0 , NEMO Consortium (2016) 50 47 !! $Id$ 51 48 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 70 67 !! - nmonth_len, nyear_len, nmonth_half, nmonth_end through day_mth 71 68 !!---------------------------------------------------------------------- 72 INTEGER :: inbday, idweek 73 REAL(wp) :: zjul 69 INTEGER :: inbday, idweek ! local integers 70 REAL(wp) :: zjul ! local scalar 74 71 !!---------------------------------------------------------------------- 75 72 ! … … 79 76 & 'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) 80 77 ENDIF 81 ! all calendar staff is based on the fact that MOD( rday, rdt ) == 0 82 IF( MOD( rday , rdt ) /= 0. ) CALL ctl_stop( 'the time step must devide the number of second of in a day' ) 83 IF( MOD( rday , 2. ) /= 0. ) CALL ctl_stop( 'the number of second of in a day must be an even number' ) 84 IF( MOD( rdt , 2. ) /= 0. ) CALL ctl_stop( 'the time step (in second) must be an even number' ) 85 nsecd = NINT(rday ) 86 nsecd05 = NINT(0.5 * rday ) 87 ndt = NINT( rdt ) 88 ndt05 = NINT(0.5 * rdt ) 89 90 IF( .NOT. lk_offline ) CALL day_rst( nit000, 'READ' ) 78 nsecd = NINT( rday ) 79 nsecd05 = NINT( 0.5 * rday ) 80 ndt = NINT( rdt ) 81 ndt05 = NINT( 0.5 * rdt ) 82 83 IF( .NOT. l_offline ) CALL day_rst( nit000, 'READ' ) 91 84 92 85 ! set the calandar from ndastp (read in restart file and namelist) 93 94 86 nyear = ndastp / 10000 95 87 nmonth = ( ndastp - (nyear * 10000) ) / 100 … … 281 273 ENDIF 282 274 283 IF( .NOT. l k_offline ) CALL rst_opn( kt ) ! Open the restart file if needed and control lrst_oce275 IF( .NOT. l_offline ) CALL rst_opn( kt ) ! Open the restart file if needed and control lrst_oce 284 276 IF( lrst_oce ) CALL day_rst( kt, 'WRITE' ) ! write day restart information 285 277 ! -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90
r6140 r7646 29 29 !! time & space domain namelist 30 30 !! ---------------------------- 31 ! !!* Namelist namdom : time & space domain * 32 INTEGER , PUBLIC :: nn_bathy !: = 0/1 ,compute/read the bathymetry file 33 REAL(wp), PUBLIC :: rn_bathy !: depth of flat bottom (active if nn_bathy=0; if =0 depth=jpkm1) 34 REAL(wp), PUBLIC :: rn_hmin !: minimum ocean depth (>0) or minimum number of ocean levels (<0) 35 REAL(wp), PUBLIC :: rn_isfhmin !: threshold to discriminate grounded ice to floating ice 36 REAL(wp), PUBLIC :: rn_e3zps_min !: miminum thickness for partial steps (meters) 37 REAL(wp), PUBLIC :: rn_e3zps_rat !: minimum thickness ration for partial steps 38 INTEGER , PUBLIC :: nn_msh !: = 1 create a mesh-mask file 39 REAL(wp), PUBLIC :: rn_atfp !: asselin time filter parameter 40 REAL(wp), PUBLIC :: rn_rdt !: time step for the dynamics and tracer 41 INTEGER , PUBLIC :: nn_closea !: =0 suppress closed sea/lake from the ORCA domain or not (=1) 42 INTEGER , PUBLIC :: nn_euler !: =0 start with forward time step or not (=1) 31 ! !!* Namelist namdom : time & space domain * 32 LOGICAL , PUBLIC :: ln_linssh !: =T linear free surface ==>> model level are fixed in time 33 INTEGER , PUBLIC :: nn_closea !: =0 suppress closed sea/lake from the ORCA domain or not (=1) 34 INTEGER , PUBLIC :: nn_msh !: >0 create a mesh-mask file (mesh_mask.nc) 35 REAL(wp), PUBLIC :: rn_isfhmin !: threshold to discriminate grounded ice to floating ice 36 REAL(wp), PUBLIC :: rn_rdt !: time step for the dynamics and tracer 37 REAL(wp), PUBLIC :: rn_atfp !: asselin time filter parameter 38 INTEGER , PUBLIC :: nn_euler !: =0 start with forward time step or not (=1) 43 39 LOGICAL , PUBLIC :: ln_iscpl !: coupling with ice sheet 44 LOGICAL , PUBLIC :: ln_crs 40 LOGICAL , PUBLIC :: ln_crs !: Apply grid coarsening to dynamical model output or online passive tracers 45 41 46 42 !! Free surface parameters 47 43 !! ======================= 48 LOGICAL , PUBLIC :: ln_dynspg_exp 49 LOGICAL , PUBLIC :: ln_dynspg_ts 44 LOGICAL , PUBLIC :: ln_dynspg_exp !: Explicit free surface flag 45 LOGICAL , PUBLIC :: ln_dynspg_ts !: Split-Explicit free surface flag 50 46 51 47 !! Time splitting parameters 52 48 !! ========================= 53 LOGICAL, PUBLIC :: ln_bt_fw !: Forward integration of barotropic sub-stepping 54 LOGICAL, PUBLIC :: ln_bt_av !: Time averaging of barotropic variables 55 LOGICAL, PUBLIC :: ln_bt_auto !: Set number of barotropic iterations automatically 56 INTEGER, PUBLIC :: nn_bt_flt !: Filter choice 57 INTEGER, PUBLIC :: nn_baro !: Number of barotropic iterations during one baroclinic step (rdt) 58 REAL(wp), PUBLIC :: rn_bt_cmax !: Maximum allowed courant number (used if ln_bt_auto=T) 59 60 !! Horizontal grid parameters for domhgr 61 !! ===================================== 62 INTEGER :: jphgr_msh !: type of horizontal mesh 63 ! ! = 0 curvilinear coordinate on the sphere read in coordinate.nc 64 ! ! = 1 geographical mesh on the sphere with regular grid-spacing 65 ! ! = 2 f-plane with regular grid-spacing 66 ! ! = 3 beta-plane with regular grid-spacing 67 ! ! = 4 Mercator grid with T/U point at the equator 68 69 REAL(wp) :: ppglam0 !: longitude of first raw and column T-point (jphgr_msh = 1) 70 REAL(wp) :: ppgphi0 !: latitude of first raw and column T-point (jphgr_msh = 1) 71 ! ! used for Coriolis & Beta parameters (jphgr_msh = 2 or 3) 72 REAL(wp) :: ppe1_deg !: zonal grid-spacing (degrees) 73 REAL(wp) :: ppe2_deg !: meridional grid-spacing (degrees) 74 REAL(wp) :: ppe1_m !: zonal grid-spacing (degrees) 75 REAL(wp) :: ppe2_m !: meridional grid-spacing (degrees) 76 77 !! Vertical grid parameter for domzgr 78 !! ================================== 79 REAL(wp) :: ppsur !: ORCA r4, r2 and r05 coefficients 80 REAL(wp) :: ppa0 !: (default coefficients) 81 REAL(wp) :: ppa1 !: 82 REAL(wp) :: ppkth !: 83 REAL(wp) :: ppacr !: 84 ! 85 ! If both ppa0 ppa1 and ppsur are specified to 0, then 86 ! they are computed from ppdzmin, pphmax , ppkth, ppacr in dom_zgr 87 REAL(wp) :: ppdzmin !: Minimum vertical spacing 88 REAL(wp) :: pphmax !: Maximum depth 89 ! 90 LOGICAL :: ldbletanh !: Use/do not use double tanf function for vertical coordinates 91 REAL(wp) :: ppa2 !: Double tanh function parameters 92 REAL(wp) :: ppkth2 !: 93 REAL(wp) :: ppacr2 !: 94 95 ! !! old non-DOCTOR names still used in the model 96 INTEGER , PUBLIC :: ntopo !: = 0/1 ,compute/read the bathymetry file 97 REAL(wp), PUBLIC :: e3zps_min !: miminum thickness for partial steps (meters) 98 REAL(wp), PUBLIC :: e3zps_rat !: minimum thickness ration for partial steps 99 INTEGER , PUBLIC :: nmsh !: = 1 create a mesh-mask file 100 REAL(wp), PUBLIC :: atfp !: asselin time filter parameter 101 REAL(wp), PUBLIC :: rdt !: time step for the dynamics and tracer 102 103 ! !!! associated variables 104 INTEGER , PUBLIC :: neuler !: restart euler forward option (0=Euler) 105 REAL(wp), PUBLIC :: atfp1 !: asselin time filter coeff. (atfp1= 1-2*atfp) 106 REAL(wp), PUBLIC :: r2dt !: = 2*rdt except at nit000 (=rdt) if neuler=0 49 LOGICAL, PUBLIC :: ln_bt_fw !: Forward integration of barotropic sub-stepping 50 LOGICAL, PUBLIC :: ln_bt_av !: Time averaging of barotropic variables 51 LOGICAL, PUBLIC :: ln_bt_auto !: Set number of barotropic iterations automatically 52 INTEGER, PUBLIC :: nn_bt_flt !: Filter choice 53 INTEGER, PUBLIC :: nn_baro !: Number of barotropic iterations during one baroclinic step (rdt) 54 REAL(wp), PUBLIC :: rn_bt_cmax !: Maximum allowed courant number (used if ln_bt_auto=T) 55 56 57 ! !! old non-DOCTOR names still used in the model 58 REAL(wp), PUBLIC :: atfp !: asselin time filter parameter 59 REAL(wp), PUBLIC :: rdt !: time step for the dynamics and tracer 60 61 ! !!! associated variables 62 INTEGER , PUBLIC :: neuler !: restart euler forward option (0=Euler) 63 REAL(wp), PUBLIC :: r2dt !: = 2*rdt except at nit000 (=rdt) if neuler=0 107 64 108 65 !!---------------------------------------------------------------------- 109 66 !! space domain parameters 110 67 !!---------------------------------------------------------------------- 111 LOGICAL, PUBLIC :: lzoom = .FALSE. !: zoom flag 112 LOGICAL, PUBLIC :: lzoom_e = .FALSE. !: East zoom type flag 113 LOGICAL, PUBLIC :: lzoom_w = .FALSE. !: West zoom type flag 114 LOGICAL, PUBLIC :: lzoom_s = .FALSE. !: South zoom type flag 115 LOGICAL, PUBLIC :: lzoom_n = .FALSE. !: North zoom type flag 116 117 ! !!! domain parameters linked to mpp 118 INTEGER, PUBLIC :: nperio !: type of lateral boundary condition 119 INTEGER, PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom 120 INTEGER, PUBLIC :: nreci, nrecj !: overlap region in i and j 121 INTEGER, PUBLIC :: nproc !: number for local processor 122 INTEGER, PUBLIC :: narea !: number for local area 123 INTEGER, PUBLIC :: nbondi, nbondj !: mark of i- and j-direction local boundaries 68 INTEGER, PUBLIC :: jperio !: Global domain lateral boundary type (between 0 and 6) 69 ! ! = 0 closed ; = 1 cyclic East-West 70 ! ! = 2 equatorial symmetric ; = 3 North fold T-point pivot 71 ! ! = 4 cyclic East-West AND North fold T-point pivot 72 ! ! = 5 North fold F-point pivot 73 ! ! = 6 cyclic East-West AND North fold F-point pivot 74 INTEGER, PUBLIC :: nperio !: Local domain lateral boundary type (deduced from jperio and MPP decomposition) 75 76 ! ! domain MPP decomposition parameters 77 INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom 78 INTEGER , PUBLIC :: nreci, nrecj !: overlap region in i and j 79 INTEGER , PUBLIC :: nproc !: number for local processor 80 INTEGER , PUBLIC :: narea !: number for local area 81 INTEGER , PUBLIC :: nbondi, nbondj !: mark of i- and j-direction local boundaries 124 82 INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy(:) !: mark i-direction local boundaries for BDY open boundaries 125 83 INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy(:) !: mark j-direction local boundaries for BDY open boundaries … … 140 98 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain i-index 141 99 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain j-index 142 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global ==> local domain i-index !!bug ==> other solution?143 ! ! (mi0=1 and mi1=0 if the global indexis not in the local domain)144 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global ==> local domain j-index !!bug ==> other solution?145 ! ! (mi0=1 and mi1=0 if the global indexis not in the local domain)100 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global ==> local domain i-index (mi0=1 and mi1=0 if the global index 101 ! ! is not in the local domain) 102 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global ==> local domain j-index (mj0=1 and mj1=0 if the global index 103 ! ! is not in the local domain) 146 104 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor 147 105 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence … … 154 112 !! horizontal curvilinear coordinate and scale factors 155 113 !! --------------------------------------------------------------------- 156 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: glamt , glamu, glamv , glamf !: longitude at t, u, v, f-points [degree]157 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: gphit , gphiu, gphiv , gphif !: latitude at t, u, v, f-points [degree]114 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: glamt , glamu, glamv , glamf !: longitude at t, u, v, f-points [degree] 115 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: gphit , gphiu, gphiv , gphif !: latitude at t, u, v, f-points [degree] 158 116 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1t , e2t , r1_e1t, r1_e2t !: t-point horizontal scale factors [m] 159 117 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u , e2u , r1_e1u, r1_e2u !: horizontal scale factors at u-point [m] … … 161 119 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f , e2f , r1_e1f, r1_e2f !: horizontal scale factors at f-point [m] 162 120 ! 163 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point164 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point165 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point166 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point121 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2t , r1_e1e2t !: associated metrics at t-point 122 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2u , r1_e1e2u , e2_e1u !: associated metrics at u-point 123 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2v , r1_e1e2v , e1_e2v !: associated metrics at v-point 124 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: e1e2f , r1_e1e2f !: associated metrics at f-point 167 125 ! 168 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ff !: coriolis factor [1/s] 169 126 REAL(wp), PUBLIC, ALLOCATABLE, SAVE , DIMENSION(:,:) :: ff_f, ff_t !: coriolis factor at f- and t-point [1/s] 170 127 !!---------------------------------------------------------------------- 171 128 !! vertical coordinate and scale factors 172 129 !! --------------------------------------------------------------------- 173 ! !!* Namelist namzgr : vertical coordinate *174 130 LOGICAL, PUBLIC :: ln_zco !: z-coordinate - full step 175 131 LOGICAL, PUBLIC :: ln_zps !: z-coordinate - partial step 176 132 LOGICAL, PUBLIC :: ln_sco !: s-coordinate or hybrid z-s coordinate 177 133 LOGICAL, PUBLIC :: ln_isfcav !: presence of ISF 178 LOGICAL, PUBLIC :: ln_linssh !: variable grid flag179 180 134 ! ! ref. ! before ! now ! after ! 181 135 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_0 , e3t_b , e3t_n , e3t_a !: t- vert. scale factor [m] … … 207 161 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gdept_1d, gdepw_1d !: reference depth of t- and w-points (m) 208 162 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_1d , e3w_1d !: reference vertical scale factors at T- and W-pts (m) 209 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3tp , e3wp !: ocean bottom level thickness at T and W points 210 211 !!gm This should be removed from here.... ==>>> only used in domzgr at initialization phase 212 !! s-coordinate and hybrid z-s-coordinate 213 !! =----------------======--------------- 214 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gsigt, gsigw !: model level depth coefficient at t-, w-levels (analytic) 215 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gsi3w !: model level depth coefficient at w-level (sum of gsigw) 216 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: esigt, esigw !: vertical scale factor coef. at t-, w-levels 217 218 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbatv , hbatf !: ocean depth at the vertical of v--f 219 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbatt , hbatu !: t--u points (m) 220 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: scosrf, scobot !: ocean surface and bottom topographies 221 ! ! (if deviating from coordinate surfaces in HYBRID) 222 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hifv , hiff !: interface depth between stretching at v--f 223 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hift , hifu !: and quasi-uniform spacing t--u points (m) 224 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rx1 !: Maximum grid stiffness ratio 225 !!gm end 226 227 !!---------------------------------------------------------------------- 228 !! masks, bathymetry 163 164 165 !!---------------------------------------------------------------------- 166 !! masks, top and bottom ocean point position 229 167 !! --------------------------------------------------------------------- 230 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbathy !: number of ocean level (=0, 1, ... , jpk-1) 231 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt !: vertical index of the bottom last T- ocean level 232 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbku, mbkv !: vertical index of the bottom last U- and W- ocean level 233 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bathy !: ocean depth (meters) 168 !!gm Proposition of new name for top/bottom vertical indices 169 ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mtk_t, mtk_u, mtk_v !: top first wet T-, U-, V-, F-level (ISF) 170 ! INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbk_t, mbk_u, mbk_v !: bottom last wet T-, U- and V-level 171 !!gm 172 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt, mbku, mbkv !: bottom last wet T-, U- and V-level 234 173 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior domain T-point mask 235 174 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_h !: internal domain T-point mask (Figure 8.5 NEMO book) 236 175 237 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfdep !: top first ocean level 238 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: first wet T-, U-, V-, F- oceanlevel (ISF)239 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfdep !: Iceshelf draft 240 241 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask , ssfmask!: surface mask at T-,U-, V- and F-pts176 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfdep !: top first ocean level (ISF) 177 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF) 178 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfdep !: Iceshelf draft (ISF) 179 180 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask !: surface mask at T-,U-, V- and F-pts 242 181 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask !: land/ocean mask at T-, U-, V- and F-pts 243 182 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts … … 270 209 271 210 !!---------------------------------------------------------------------- 272 !! mpp reproducibility273 !!----------------------------------------------------------------------274 #if defined key_mpp_rep275 LOGICAL, PUBLIC, PARAMETER :: lk_mpp_rep = .TRUE. !: agrif flag276 #else277 LOGICAL, PUBLIC, PARAMETER :: lk_mpp_rep = .FALSE. !: agrif flag278 #endif279 280 !!----------------------------------------------------------------------281 211 !! agrif domain 282 212 !!---------------------------------------------------------------------- … … 289 219 !!---------------------------------------------------------------------- 290 220 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 291 !! $Id$ 221 !! $Id$ 292 222 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 293 223 !!---------------------------------------------------------------------- … … 309 239 INTEGER FUNCTION dom_oce_alloc() 310 240 !!---------------------------------------------------------------------- 311 INTEGER, DIMENSION(1 3) :: ierr241 INTEGER, DIMENSION(12) :: ierr 312 242 !!---------------------------------------------------------------------- 313 243 ierr(:) = 0 … … 319 249 & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , & 320 250 & nleit(jpnij) , nlejt(jpnij) , & 321 & mi0(jpi dta) , mi1 (jpidta), mj0(jpjdta) , mj1 (jpjdta),&322 & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(2) )251 & mi0(jpiglo) , mi1 (jpiglo), mj0(jpjglo) , mj1 (jpjglo) , & 252 & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(2) ) 323 253 ! 324 254 ALLOCATE( glamt(jpi,jpj) , glamu(jpi,jpj) , glamv(jpi,jpj) , glamf(jpi,jpj) , & … … 332 262 & e1e2v(jpi,jpj) , r1_e1e2v(jpi,jpj) , e1_e2v(jpi,jpj) , & 333 263 & e1e2f(jpi,jpj) , r1_e1e2f(jpi,jpj) , & 334 & ff (jpi,jpj), STAT=ierr(3) )335 ! 336 ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) , &264 & ff_f (jpi,jpj) , ff_t (jpi,jpj) , STAT=ierr(3) ) 265 ! 266 ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) , & 337 267 & gdept_b(jpi,jpj,jpk) , gdepw_b(jpi,jpj,jpk) , & 338 268 & gdept_n(jpi,jpj,jpk) , gdepw_n(jpi,jpj,jpk) , gde3w_n(jpi,jpj,jpk) , STAT=ierr(4) ) … … 353 283 ! 354 284 ! 355 ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , & 356 & e3t_1d (jpk) , e3w_1d (jpk) , e3tp (jpi,jpj), e3wp(jpi,jpj) , & 357 & gsigt (jpk) , gsigw (jpk) , gsi3w(jpk) , & 358 & esigt (jpk) , esigw (jpk) , STAT=ierr(7) ) 359 ! 360 ALLOCATE( hbatv (jpi,jpj) , hbatf (jpi,jpj) , & 361 & hbatt (jpi,jpj) , hbatu (jpi,jpj) , & 362 & scosrf(jpi,jpj) , scobot(jpi,jpj) , & 363 & hifv (jpi,jpj) , hiff (jpi,jpj) , & 364 & hift (jpi,jpj) , hifu (jpi,jpj) , rx1(jpi,jpj) , STAT=ierr(8) ) 365 366 ALLOCATE( mbathy(jpi,jpj) , bathy (jpi,jpj) , & 367 & tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 368 & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , ssfmask(jpi,jpj) , & 369 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(9) ) 370 371 ! (ISF) Allocation of basic array 372 ALLOCATE( misfdep(jpi,jpj) , risfdep(jpi,jpj), & 373 & mikt(jpi,jpj), miku(jpi,jpj), mikv(jpi,jpj) , & 374 & mikf(jpi,jpj), STAT=ierr(10) ) 375 376 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk), & 377 & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk), STAT=ierr(11) ) 378 285 ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(7) ) 286 ! 287 ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & 288 & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , & 289 & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(9) ) 290 ! 291 ALLOCATE( misfdep(jpi,jpj) , mikt(jpi,jpj) , miku(jpi,jpj) , & 292 & risfdep(jpi,jpj) , mikv(jpi,jpj) , mikf(jpi,jpj) , STAT=ierr(10) ) 293 ! 294 ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & 295 & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(11) ) 296 ! 379 297 ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) ) 380 298 ! -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90
r6981 r7646 14 14 !! 3.6 ! 2013 ( J. Simeon, C. Calone, G. Madec, C. Ethe ) Online coarsening of outputs 15 15 !! 3.7 ! 2015-11 (G. Madec, A. Coward) time varying zgr by default 16 !! 4.0 ! 2016-10 (G. Madec, S. Flavoni) domain configuration / user defined interface 16 17 !!---------------------------------------------------------------------- 17 18 18 19 !!---------------------------------------------------------------------- 19 !! dom_init : initialize the space and time domain 20 !! dom_nam : read and contral domain namelists 21 !! dom_ctl : control print for the ocean domain 22 !! dom_stiff : diagnose maximum grid stiffness/hydrostatic consistency (s-coordinate) 20 !! dom_init : initialize the space and time domain 21 !! dom_glo : initialize global domain <--> local domain indices 22 !! dom_nam : read and contral domain namelists 23 !! dom_ctl : control print for the ocean domain 24 !! domain_cfg : read the global domain size in domain configuration file 25 !! cfg_write : create the domain configuration file 23 26 !!---------------------------------------------------------------------- 24 USE oce ! ocean variables 25 USE dom_oce ! domain: ocean 26 USE sbc_oce ! surface boundary condition: ocean 27 USE phycst ! physical constants 28 USE closea ! closed seas 29 USE domhgr ! domain: set the horizontal mesh 30 USE domzgr ! domain: set the vertical mesh 31 USE domstp ! domain: set the time-step 32 USE dommsk ! domain: set the mask system 33 USE domwri ! domain: write the meshmask file 34 USE domvvl ! variable volume 35 USE c1d ! 1D vertical configuration 36 USE dyncor_c1d ! Coriolis term (c1d case) (cor_c1d routine) 27 USE oce ! ocean variables 28 USE dom_oce ! domain: ocean 29 USE sbc_oce ! surface boundary condition: ocean 30 USE trc_oce ! shared ocean & passive tracers variab 31 USE phycst ! physical constants 32 USE usrdef_closea ! closed seas 33 USE domhgr ! domain: set the horizontal mesh 34 USE domzgr ! domain: set the vertical mesh 35 USE dommsk ! domain: set the mask system 36 USE domwri ! domain: write the meshmask file 37 USE domvvl ! variable volume 38 USE c1d ! 1D configuration 39 USE domc1d ! 1D configuration: column location 40 USE dyncor_c1d ! 1D configuration: Coriolis term (cor_c1d routine) 41 USE wet_dry ! wetting and drying 37 42 ! 38 USE in_out_manager ! I/O manager 39 USE wrk_nemo ! Memory Allocation 40 USE lib_mpp ! distributed memory computing library 41 USE lbclnk ! ocean lateral boundary condition (or mpp link) 42 USE timing ! Timing 43 USE in_out_manager ! I/O manager 44 USE iom ! I/O library 45 USE lbclnk ! ocean lateral boundary condition (or mpp link) 46 USE lib_mpp ! distributed memory computing library 47 USE wrk_nemo ! Memory Allocation 48 USE timing ! Timing 43 49 44 50 IMPLICIT NONE 45 51 PRIVATE 46 52 47 PUBLIC dom_init ! called by opa.F90 53 PUBLIC dom_init ! called by nemogcm.F90 54 PUBLIC domain_cfg ! called by nemogcm.F90 48 55 49 56 !!------------------------------------------------------------------------- … … 66 73 !! and scale factors, and the coriolis factor 67 74 !! - dom_zgr: define the vertical coordinate and the bathymetry 68 !! - dom_stp: defined the model time step 69 !! - dom_wri: create the meshmask file if nmsh=1 75 !! - dom_wri: create the meshmask file if nn_msh=1 70 76 !! - 1D configuration, move Coriolis, u and v at T-point 71 77 !!---------------------------------------------------------------------- 72 INTEGER :: jk ! dummy loop indices 73 INTEGER :: iconf = 0 ! local integers 74 REAL(wp), POINTER, DIMENSION(:,:) :: z1_hu_0, z1_hv_0 78 INTEGER :: ji, jj, jk, ik ! dummy loop indices 79 INTEGER :: iconf = 0 ! local integers 80 CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" 81 INTEGER , DIMENSION(jpi,jpj) :: ik_top , ik_bot ! top and bottom ocean level 82 REAL(wp), DIMENSION(jpi,jpj) :: z1_hu_0, z1_hv_0 75 83 !!---------------------------------------------------------------------- 76 84 ! 77 85 IF( nn_timing == 1 ) CALL timing_start('dom_init') 78 86 ! 79 IF(lwp) THEN 87 IF(lwp) THEN ! Ocean domain Parameters (control print) 80 88 WRITE(numout,*) 81 89 WRITE(numout,*) 'dom_init : domain initialization' 82 90 WRITE(numout,*) '~~~~~~~~' 83 ENDIF 84 ! 85 ! !== Reference coordinate system ==! 86 ! 87 CALL dom_nam ! read namelist ( namrun, namdom ) 88 CALL dom_clo ! Closed seas and lake 89 CALL dom_hgr ! Horizontal mesh 90 CALL dom_zgr ! Vertical mesh and bathymetry 91 CALL dom_msk ! Masks 92 IF( ln_sco ) CALL dom_stiff ! Maximum stiffness ratio/hydrostatic consistency 93 ! 94 ht_0(:,:) = e3t_0(:,:,1) * tmask(:,:,1) ! Reference ocean thickness 95 hu_0(:,:) = e3u_0(:,:,1) * umask(:,:,1) 96 hv_0(:,:) = e3v_0(:,:,1) * vmask(:,:,1) 97 DO jk = 2, jpk 91 ! 92 WRITE(numout,*) ' Domain info' 93 WRITE(numout,*) ' dimension of model:' 94 WRITE(numout,*) ' Local domain Global domain Data domain ' 95 WRITE(numout,cform) ' ',' jpi : ', jpi, ' jpiglo : ', jpiglo 96 WRITE(numout,cform) ' ',' jpj : ', jpj, ' jpjglo : ', jpjglo 97 WRITE(numout,cform) ' ',' jpk : ', jpk, ' jpkglo : ', jpkglo 98 WRITE(numout,cform) ' ' ,' jpij : ', jpij 99 WRITE(numout,*) ' mpp local domain info (mpp):' 100 WRITE(numout,*) ' jpni : ', jpni, ' jpreci : ', jpreci 101 WRITE(numout,*) ' jpnj : ', jpnj, ' jprecj : ', jprecj 102 WRITE(numout,*) ' jpnij : ', jpnij 103 WRITE(numout,*) ' lateral boundary of the Global domain : jperio = ', jperio 104 SELECT CASE ( jperio ) 105 CASE( 0 ) ; WRITE(numout,*) ' (i.e. closed)' 106 CASE( 1 ) ; WRITE(numout,*) ' (i.e. cyclic east-west)' 107 CASE( 2 ) ; WRITE(numout,*) ' (i.e. equatorial symmetric)' 108 CASE( 3 ) ; WRITE(numout,*) ' (i.e. north fold with T-point pivot)' 109 CASE( 4 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north fold with T-point pivot)' 110 CASE( 5 ) ; WRITE(numout,*) ' (i.e. north fold with F-point pivot)' 111 CASE( 6 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north fold with F-point pivot)' 112 CASE DEFAULT 113 CALL ctl_stop( 'jperio is out of range' ) 114 END SELECT 115 WRITE(numout,*) ' Ocean model configuration used:' 116 WRITE(numout,*) ' cn_cfg = ', cn_cfg 117 WRITE(numout,*) ' nn_cfg = ', nn_cfg 118 ENDIF 119 ! 120 ! 121 !!gm This should be removed with the new configuration interface 122 IF( lk_c1d .AND. ln_c1d_locpt ) CALL dom_c1d( rn_lat1d, rn_lon1d ) 123 !!gm end 124 ! 125 ! !== Reference coordinate system ==! 126 ! 127 CALL dom_glo ! global domain versus local domain 128 CALL dom_nam ! read namelist ( namrun, namdom ) 129 CALL dom_clo( cn_cfg, nn_cfg ) ! Closed seas and lake 130 CALL dom_hgr ! Horizontal mesh 131 CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry 132 IF( nn_closea == 0 ) CALL clo_bat( ik_top, ik_bot ) !== remove closed seas or lakes ==! 133 CALL dom_msk( ik_top, ik_bot ) ! Masks 134 ! 135 DO jj = 1, jpj ! depth of the iceshelves 136 DO ji = 1, jpi 137 ik = mikt(ji,jj) 138 risfdep(ji,jj) = gdepw_0(ji,jj,ik) 139 END DO 140 END DO 141 ! 142 ht_0(:,:) = 0._wp ! Reference ocean thickness 143 hu_0(:,:) = 0._wp 144 hv_0(:,:) = 0._wp 145 DO jk = 1, jpk 98 146 ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) 99 147 hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) … … 101 149 END DO 102 150 ! 103 ! !== time varying part of coordinate system ==! 104 ! 105 IF( ln_linssh ) THEN ! Fix in time : set to the reference one for all 151 ! !== time varying part of coordinate system ==! 152 ! 153 IF( ln_linssh ) THEN != Fix in time : set to the reference one for all 154 ! 106 155 ! before ! now ! after ! 107 156 gdept_b = gdept_0 ; gdept_n = gdept_0 ! --- ! depth of grid-points … … 117 166 e3vw_b = e3vw_0 ; e3vw_n = e3vw_0 ! --- ! 118 167 ! 119 CALL wrk_alloc( jpi,jpj, z1_hu_0, z1_hv_0 )120 !121 168 z1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) ) ! _i mask due to ISF 122 169 z1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) … … 129 176 r1_hv_b = z1_hv_0 ; r1_hv_n = z1_hv_0 ; r1_hv_a = z1_hv_0 ! 130 177 ! 131 CALL wrk_dealloc( jpi,jpj, z1_hu_0, z1_hv_0 ) 132 ! 133 ELSE ! time varying : initialize before/now/after variables 134 ! 135 CALL dom_vvl_init 178 ! 179 ELSE != time varying : initialize before/now/after variables 180 ! 181 IF( .NOT.l_offline ) CALL dom_vvl_init 136 182 ! 137 183 ENDIF … … 139 185 IF( lk_c1d ) CALL cor_c1d ! 1D configuration: Coriolis set at T-point 140 186 ! 141 CALL dom_stp ! time step 142 IF( nmsh /= 0 .AND. .NOT. ln_iscpl ) CALL dom_wri ! Create a domain file 143 IF( nmsh /= 0 .AND. ln_iscpl .AND. .NOT. ln_rstart ) CALL dom_wri ! Create a domain file 187 IF( nn_msh > 0 .AND. .NOT. ln_iscpl ) CALL dom_wri ! Create a domain file 188 IF( nn_msh > 0 .AND. ln_iscpl .AND. .NOT. ln_rstart ) CALL dom_wri ! Create a domain file 144 189 IF( .NOT.ln_rstart ) CALL dom_ctl ! Domain control 145 190 ! 191 192 IF(lwp) THEN 193 WRITE(numout,*) 194 WRITE(numout,*) 'dom_init : end of domain initialization nn_msh=', nn_msh 195 WRITE(numout,*) 196 ENDIF 197 ! 198 IF( ln_write_cfg ) CALL cfg_write ! create the configuration file 199 ! 146 200 IF( nn_timing == 1 ) CALL timing_stop('dom_init') 147 201 ! 148 202 END SUBROUTINE dom_init 203 204 205 SUBROUTINE dom_glo 206 !!---------------------------------------------------------------------- 207 !! *** ROUTINE dom_glo *** 208 !! 209 !! ** Purpose : initialization of global domain <--> local domain indices 210 !! 211 !! ** Method : 212 !! 213 !! ** Action : - mig , mjg : local domain indices ==> global domain indices 214 !! - mi0 , mi1 : global domain indices ==> local domain indices 215 !! - mj0,, mj1 (global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) 216 !!---------------------------------------------------------------------- 217 INTEGER :: ji, jj ! dummy loop argument 218 !!---------------------------------------------------------------------- 219 ! 220 DO ji = 1, jpi ! local domain indices ==> global domain indices 221 mig(ji) = ji + nimpp - 1 222 END DO 223 DO jj = 1, jpj 224 mjg(jj) = jj + njmpp - 1 225 END DO 226 ! ! global domain indices ==> local domain indices 227 ! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the 228 ! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain. 229 DO ji = 1, jpiglo 230 mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) ) 231 mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi ) ) 232 END DO 233 DO jj = 1, jpjglo 234 mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) ) 235 mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj ) ) 236 END DO 237 IF(lwp) THEN ! control print 238 WRITE(numout,*) 239 WRITE(numout,*) 'dom_glo : domain: global <<==>> local ' 240 WRITE(numout,*) '~~~~~~~ ' 241 WRITE(numout,*) ' global domain: jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpkglo = ', jpkglo 242 WRITE(numout,*) ' local domain: jpi = ', jpi , ' jpj = ', jpj , ' jpk = ', jpk 243 WRITE(numout,*) 244 WRITE(numout,*) ' conversion from local to global domain indices (and vise versa) done' 245 IF( nn_print >= 1 ) THEN 246 WRITE(numout,*) 247 WRITE(numout,*) ' conversion local ==> global i-index domain' 248 WRITE(numout,25) (mig(ji),ji = 1,jpi) 249 WRITE(numout,*) 250 WRITE(numout,*) ' conversion global ==> local i-index domain' 251 WRITE(numout,*) ' starting index' 252 WRITE(numout,25) (mi0(ji),ji = 1,jpiglo) 253 WRITE(numout,*) ' ending index' 254 WRITE(numout,25) (mi1(ji),ji = 1,jpiglo) 255 WRITE(numout,*) 256 WRITE(numout,*) ' conversion local ==> global j-index domain' 257 WRITE(numout,25) (mjg(jj),jj = 1,jpj) 258 WRITE(numout,*) 259 WRITE(numout,*) ' conversion global ==> local j-index domain' 260 WRITE(numout,*) ' starting index' 261 WRITE(numout,25) (mj0(jj),jj = 1,jpjglo) 262 WRITE(numout,*) ' ending index' 263 WRITE(numout,25) (mj1(jj),jj = 1,jpjglo) 264 ENDIF 265 ENDIF 266 25 FORMAT( 100(10x,19i4,/) ) 267 ! 268 END SUBROUTINE dom_glo 149 269 150 270 … … 161 281 USE ioipsl 162 282 NAMELIST/namrun/ cn_ocerst_indir, cn_ocerst_outdir, nn_stocklist, ln_rst_list, & 163 283 & nn_no , cn_exp , cn_ocerst_in, cn_ocerst_out, ln_rstart , nn_rstctl , & 164 284 & nn_it000, nn_itend , nn_date0 , nn_time0 , nn_leapy , nn_istate , & 165 285 & nn_stock, nn_write , ln_mskland , ln_clobber , nn_chunksz, nn_euler , & 166 286 & ln_cfmeta, ln_iscpl 167 NAMELIST/namdom/ nn_bathy, rn_bathy , rn_e3zps_min, rn_e3zps_rat, nn_msh, rn_hmin, rn_isfhmin, & 168 & rn_atfp , rn_rdt , nn_closea , ln_crs , jphgr_msh , & 169 & ppglam0, ppgphi0, ppe1_deg, ppe2_deg, ppe1_m, ppe2_m, & 170 & ppsur, ppa0, ppa1, ppkth, ppacr, ppdzmin, pphmax, ldbletanh, & 171 & ppa2, ppkth2, ppacr2 287 NAMELIST/namdom/ ln_linssh, nn_closea, nn_msh, rn_isfhmin, rn_rdt, rn_atfp, ln_crs 172 288 #if defined key_netcdf4 173 289 NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip … … 175 291 INTEGER :: ios ! Local integer output status for namelist read 176 292 !!---------------------------------------------------------------------- 177 293 ! 178 294 REWIND( numnam_ref ) ! Namelist namrun in reference namelist : Parameters of the run 179 295 READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) 180 296 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist', lwp ) 181 297 ! 182 298 REWIND( numnam_cfg ) ! Namelist namrun in configuration namelist : Parameters of the run 183 299 READ ( numnam_cfg, namrun, IOSTAT = ios, ERR = 902 ) … … 235 351 neuler = 0 236 352 ENDIF 237 238 353 ! ! control of output frequency 239 354 IF ( nstock == 0 .OR. nstock > nitend ) THEN … … 269 384 READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) 270 385 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist', lwp ) 271 272 386 ! 273 387 REWIND( numnam_cfg ) ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep) … … 279 393 WRITE(numout,*) 280 394 WRITE(numout,*) ' Namelist namdom : space & time domain' 281 WRITE(numout,*) ' flag read/compute bathymetry nn_bathy = ', nn_bathy 282 WRITE(numout,*) ' Depth (if =0 bathy=jpkm1) rn_bathy = ', rn_bathy 283 WRITE(numout,*) ' min depth of the ocean (>0) or rn_hmin = ', rn_hmin 284 WRITE(numout,*) ' min number of ocean level (<0) ' 285 WRITE(numout,*) ' treshold to open the isf cavity rn_isfhmin = ', rn_isfhmin, ' (m)' 286 WRITE(numout,*) ' minimum thickness of partial rn_e3zps_min = ', rn_e3zps_min, ' (m)' 287 WRITE(numout,*) ' step level rn_e3zps_rat = ', rn_e3zps_rat 288 WRITE(numout,*) ' create mesh/mask file(s) nn_msh = ', nn_msh 395 WRITE(numout,*) ' linear free surface (=T) ln_linssh = ', ln_linssh 396 WRITE(numout,*) ' suppression of closed seas (=0) nn_closea = ', nn_closea 397 WRITE(numout,*) ' create mesh/mask file(s) nn_msh = ', nn_msh 289 398 WRITE(numout,*) ' = 0 no file created ' 290 399 WRITE(numout,*) ' = 1 mesh_mask ' 291 400 WRITE(numout,*) ' = 2 mesh and mask ' 292 401 WRITE(numout,*) ' = 3 mesh_hgr, msh_zgr and mask' 293 WRITE(numout,*) ' ocean time step rn_rdt = ', rn_rdt 294 WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp 295 WRITE(numout,*) ' suppression of closed seas (=0) nn_closea = ', nn_closea 296 WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs 297 WRITE(numout,*) ' type of horizontal mesh jphgr_msh = ', jphgr_msh 298 WRITE(numout,*) ' longitude of first raw and column T-point ppglam0 = ', ppglam0 299 WRITE(numout,*) ' latitude of first raw and column T-point ppgphi0 = ', ppgphi0 300 WRITE(numout,*) ' zonal grid-spacing (degrees) ppe1_deg = ', ppe1_deg 301 WRITE(numout,*) ' meridional grid-spacing (degrees) ppe2_deg = ', ppe2_deg 302 WRITE(numout,*) ' zonal grid-spacing (degrees) ppe1_m = ', ppe1_m 303 WRITE(numout,*) ' meridional grid-spacing (degrees) ppe2_m = ', ppe2_m 304 WRITE(numout,*) ' ORCA r4, r2 and r05 coefficients ppsur = ', ppsur 305 WRITE(numout,*) ' ppa0 = ', ppa0 306 WRITE(numout,*) ' ppa1 = ', ppa1 307 WRITE(numout,*) ' ppkth = ', ppkth 308 WRITE(numout,*) ' ppacr = ', ppacr 309 WRITE(numout,*) ' Minimum vertical spacing ppdzmin = ', ppdzmin 310 WRITE(numout,*) ' Maximum depth pphmax = ', pphmax 311 WRITE(numout,*) ' Use double tanf function for vertical coordinates ldbletanh = ', ldbletanh 312 WRITE(numout,*) ' Double tanh function parameters ppa2 = ', ppa2 313 WRITE(numout,*) ' ppkth2 = ', ppkth2 314 WRITE(numout,*) ' ppacr2 = ', ppacr2 315 ENDIF 316 ! 317 ntopo = nn_bathy ! conversion DOCTOR names into model names (this should disappear soon) 318 e3zps_min = rn_e3zps_min 319 e3zps_rat = rn_e3zps_rat 320 nmsh = nn_msh 402 WRITE(numout,*) ' treshold to open the isf cavity rn_isfhmin = ', rn_isfhmin, ' (m)' 403 WRITE(numout,*) ' ocean time step rn_rdt = ', rn_rdt 404 WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp 405 WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs 406 ENDIF 407 408 call flush( numout ) 409 ! 410 ! ! ! conversion DOCTOR names into model names (this should disappear soon) 321 411 atfp = rn_atfp 322 412 rdt = rn_rdt … … 327 417 READ ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) 328 418 907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist', lwp ) 329 419 ! 330 420 REWIND( numnam_cfg ) ! Namelist namnc4 in configuration namelist : NETCDF 331 421 READ ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 ) … … 378 468 ze1max = MAXVAL( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 379 469 ze2max = MAXVAL( e2t(:,:), mask = tmask_i(:,:) == 1._wp ) 380 470 ! 381 471 iloc = MINLOC( e1t(:,:), mask = tmask_i(:,:) == 1._wp ) 382 472 iimi1 = iloc(1) + nimpp - 1 … … 405 495 406 496 407 SUBROUTINE dom_stiff 408 !!---------------------------------------------------------------------- 409 !! *** ROUTINE dom_stiff *** 410 !! 411 !! ** Purpose : Diagnose maximum grid stiffness/hydrostatic consistency 412 !! 413 !! ** Method : Compute Haney (1991) hydrostatic condition ratio 414 !! Save the maximum in the vertical direction 415 !! (this number is only relevant in s-coordinates) 416 !! 417 !! Haney, R. L., 1991: On the pressure gradient force 418 !! over steep topography in sigma coordinate ocean models. 419 !! J. Phys. Oceanogr., 21, 610???619. 420 !!---------------------------------------------------------------------- 421 INTEGER :: ji, jj, jk 422 REAL(wp) :: zrxmax 423 REAL(wp), DIMENSION(4) :: zr1 424 !!---------------------------------------------------------------------- 425 rx1(:,:) = 0._wp 426 zrxmax = 0._wp 427 zr1(:) = 0._wp 428 ! 429 DO ji = 2, jpim1 430 DO jj = 2, jpjm1 431 DO jk = 1, jpkm1 432 zr1(1) = ABS( ( gdepw_0(ji ,jj,jk )-gdepw_0(ji-1,jj,jk ) & 433 & +gdepw_0(ji ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) ) & 434 & / ( gdepw_0(ji ,jj,jk )+gdepw_0(ji-1,jj,jk ) & 435 & -gdepw_0(ji ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) + rsmall ) ) * umask(ji-1,jj,jk) 436 zr1(2) = ABS( ( gdepw_0(ji+1,jj,jk )-gdepw_0(ji ,jj,jk ) & 437 & +gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji ,jj,jk+1) ) & 438 & / ( gdepw_0(ji+1,jj,jk )+gdepw_0(ji ,jj,jk ) & 439 & -gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji ,jj,jk+1) + rsmall ) ) * umask(ji ,jj,jk) 440 zr1(3) = ABS( ( gdepw_0(ji,jj+1,jk )-gdepw_0(ji,jj ,jk ) & 441 & +gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj ,jk+1) ) & 442 & / ( gdepw_0(ji,jj+1,jk )+gdepw_0(ji,jj ,jk ) & 443 & -gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj ,jk+1) + rsmall ) ) * vmask(ji,jj ,jk) 444 zr1(4) = ABS( ( gdepw_0(ji,jj ,jk )-gdepw_0(ji,jj-1,jk ) & 445 & +gdepw_0(ji,jj ,jk+1)-gdepw_0(ji,jj-1,jk+1) ) & 446 & / ( gdepw_0(ji,jj ,jk )+gdepw_0(ji,jj-1,jk ) & 447 & -gdepw_0(ji,jj ,jk+1)-gdepw_0(ji,jj-1,jk+1) + rsmall ) ) * vmask(ji,jj-1,jk) 448 zrxmax = MAXVAL( zr1(1:4) ) 449 rx1(ji,jj) = MAX( rx1(ji,jj) , zrxmax ) 450 END DO 451 END DO 452 END DO 453 CALL lbc_lnk( rx1, 'T', 1. ) 454 ! 455 zrxmax = MAXVAL( rx1 ) 456 ! 457 IF( lk_mpp ) CALL mpp_max( zrxmax ) ! max over the global domain 458 ! 459 IF(lwp) THEN 460 WRITE(numout,*) 461 WRITE(numout,*) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax 462 WRITE(numout,*) '~~~~~~~~~' 463 ENDIF 464 ! 465 END SUBROUTINE dom_stiff 497 SUBROUTINE domain_cfg( ldtxt, cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) 498 !!---------------------------------------------------------------------- 499 !! *** ROUTINE dom_nam *** 500 !! 501 !! ** Purpose : read the domain size in domain configuration file 502 !! 503 !! ** Method : 504 !! 505 !!---------------------------------------------------------------------- 506 CHARACTER(len=*), DIMENSION(:), INTENT(out) :: ldtxt ! stored print information 507 CHARACTER(len=*) , INTENT(out) :: cd_cfg ! configuration name 508 INTEGER , INTENT(out) :: kk_cfg ! configuration resolution 509 INTEGER , INTENT(out) :: kpi, kpj, kpk ! global domain sizes 510 INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. 511 ! 512 INTEGER :: inum, ii ! local integer 513 REAL(wp) :: zorca_res ! local scalars 514 REAL(wp) :: ziglo, zjglo, zkglo, zperio ! - - 515 !!---------------------------------------------------------------------- 516 ! 517 ii = 1 518 WRITE(ldtxt(ii),*) ' ' ; ii = ii+1 519 WRITE(ldtxt(ii),*) 'domain_cfg : domain size read in ', TRIM( cn_domcfg ), ' file' ; ii = ii+1 520 WRITE(ldtxt(ii),*) '~~~~~~~~~~ ' ; ii = ii+1 521 ! 522 CALL iom_open( cn_domcfg, inum ) 523 ! 524 ! !- ORCA family specificity 525 IF( iom_varid( inum, 'ORCA' , ldstop = .FALSE. ) > 0 .AND. & 526 & iom_varid( inum, 'ORCA_index' , ldstop = .FALSE. ) > 0 ) THEN 527 ! 528 cd_cfg = 'ORCA' 529 CALL iom_get( inum, 'ORCA_index', zorca_res ) ; kk_cfg = INT( zorca_res ) 530 ! 531 WRITE(ldtxt(ii),*) ' ' ; ii = ii+1 532 WRITE(ldtxt(ii),*) ' ==>>> ORCA configuration ' ; ii = ii+1 533 WRITE(ldtxt(ii),*) ' ' ; ii = ii+1 534 ! 535 ELSE !- cd_cfg & k_cfg are not used 536 cd_cfg = 'UNKNOWN' 537 kk_cfg = -9999999 538 !- or they may be present as global attributes 539 !- (netcdf only) 540 IF( iom_file(inum)%iolib == jpnf90 ) THEN 541 CALL iom_getatt( inum, 'cn_cfg', cd_cfg ) ! returns ! if not found 542 CALL iom_getatt( inum, 'nn_cfg', kk_cfg ) ! returns -999 if not found 543 IF( TRIM(cd_cfg) .EQ. '!') cd_cfg = 'UNKNOWN' 544 IF( kk_cfg .EQ. -999 ) kk_cfg = -9999999 545 ENDIF 546 ! 547 ENDIF 548 ! 549 CALL iom_get( inum, 'jpiglo', ziglo ) ; kpi = INT( ziglo ) 550 CALL iom_get( inum, 'jpjglo', zjglo ) ; kpj = INT( zjglo ) 551 CALL iom_get( inum, 'jpkglo', zkglo ) ; kpk = INT( zkglo ) 552 CALL iom_get( inum, 'jperio', zperio ) ; kperio = INT( zperio ) 553 CALL iom_close( inum ) 554 ! 555 WRITE(ldtxt(ii),*) ' cn_cfg = ', TRIM(cd_cfg), ' nn_cfg = ', kk_cfg ; ii = ii+1 556 WRITE(ldtxt(ii),*) ' jpiglo = ', kpi ; ii = ii+1 557 WRITE(ldtxt(ii),*) ' jpjglo = ', kpj ; ii = ii+1 558 WRITE(ldtxt(ii),*) ' jpkglo = ', kpk ; ii = ii+1 559 WRITE(ldtxt(ii),*) ' type of global domain lateral boundary jperio = ', kperio ; ii = ii+1 560 ! 561 END SUBROUTINE domain_cfg 562 563 564 SUBROUTINE cfg_write 565 !!---------------------------------------------------------------------- 566 !! *** ROUTINE cfg_write *** 567 !! 568 !! ** Purpose : Create the "cn_domcfg_out" file, a NetCDF file which 569 !! contains all the ocean domain informations required to 570 !! define an ocean configuration. 571 !! 572 !! ** Method : Write in a file all the arrays required to set up an 573 !! ocean configuration. 574 !! 575 !! ** output file : domcfg_out.nc : domain size, characteristics, horizontal 576 !! mesh, Coriolis parameter, and vertical scale factors 577 !! NB: also contain ORCA family information 578 !!---------------------------------------------------------------------- 579 INTEGER :: ji, jj, jk ! dummy loop indices 580 INTEGER :: izco, izps, isco, icav 581 INTEGER :: inum ! local units 582 CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) 583 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! workspace 584 !!---------------------------------------------------------------------- 585 ! 586 IF(lwp) WRITE(numout,*) 587 IF(lwp) WRITE(numout,*) 'cfg_write : create the domain configuration file (', TRIM(cn_domcfg_out),'.nc)' 588 IF(lwp) WRITE(numout,*) '~~~~~~~~~' 589 ! 590 ! ! ============================= ! 591 ! ! create 'domcfg_out.nc' file ! 592 ! ! ============================= ! 593 ! 594 clnam = 'domcfg_out' ! filename (configuration information) 595 CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib ) 596 597 ! 598 ! !== ORCA family specificities ==! 599 IF( cn_cfg == "ORCA" ) THEN 600 CALL iom_rstput( 0, 0, inum, 'ORCA' , 1._wp , ktype = jp_i4 ) 601 CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 ) 602 ENDIF 603 ! 604 ! !== global domain size ==! 605 ! 606 CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 ) 607 CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 ) 608 CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpk , wp), ktype = jp_i4 ) 609 ! 610 ! !== domain characteristics ==! 611 ! 612 ! ! lateral boundary of the global domain 613 CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 ) 614 ! 615 ! ! type of vertical coordinate 616 IF( ln_zco ) THEN ; izco = 1 ; ELSE ; izco = 0 ; ENDIF 617 IF( ln_zps ) THEN ; izps = 1 ; ELSE ; izps = 0 ; ENDIF 618 IF( ln_sco ) THEN ; isco = 1 ; ELSE ; isco = 0 ; ENDIF 619 CALL iom_rstput( 0, 0, inum, 'ln_zco' , REAL( izco, wp), ktype = jp_i4 ) 620 CALL iom_rstput( 0, 0, inum, 'ln_zps' , REAL( izps, wp), ktype = jp_i4 ) 621 CALL iom_rstput( 0, 0, inum, 'ln_sco' , REAL( isco, wp), ktype = jp_i4 ) 622 ! 623 ! ! ocean cavities under iceshelves 624 IF( ln_isfcav ) THEN ; icav = 1 ; ELSE ; icav = 0 ; ENDIF 625 CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 ) 626 ! 627 ! !== horizontal mesh ! 628 ! 629 CALL iom_rstput( 0, 0, inum, 'glamt', glamt, ktype = jp_r8 ) ! latitude 630 CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 ) 631 CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 ) 632 CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 ) 633 ! 634 CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 ) ! longitude 635 CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 ) 636 CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 ) 637 CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 ) 638 ! 639 CALL iom_rstput( 0, 0, inum, 'e1t' , e1t , ktype = jp_r8 ) ! i-scale factors (e1.) 640 CALL iom_rstput( 0, 0, inum, 'e1u' , e1u , ktype = jp_r8 ) 641 CALL iom_rstput( 0, 0, inum, 'e1v' , e1v , ktype = jp_r8 ) 642 CALL iom_rstput( 0, 0, inum, 'e1f' , e1f , ktype = jp_r8 ) 643 ! 644 CALL iom_rstput( 0, 0, inum, 'e2t' , e2t , ktype = jp_r8 ) ! j-scale factors (e2.) 645 CALL iom_rstput( 0, 0, inum, 'e2u' , e2u , ktype = jp_r8 ) 646 CALL iom_rstput( 0, 0, inum, 'e2v' , e2v , ktype = jp_r8 ) 647 CALL iom_rstput( 0, 0, inum, 'e2f' , e2f , ktype = jp_r8 ) 648 ! 649 CALL iom_rstput( 0, 0, inum, 'ff_f' , ff_f , ktype = jp_r8 ) ! coriolis factor 650 CALL iom_rstput( 0, 0, inum, 'ff_t' , ff_t , ktype = jp_r8 ) 651 ! 652 ! !== vertical mesh ==! 653 ! 654 CALL iom_rstput( 0, 0, inum, 'e3t_1d' , e3t_1d , ktype = jp_r8 ) ! reference 1D-coordinate 655 CALL iom_rstput( 0, 0, inum, 'e3w_1d' , e3w_1d , ktype = jp_r8 ) 656 ! 657 CALL iom_rstput( 0, 0, inum, 'e3t_0' , e3t_0 , ktype = jp_r8 ) ! vertical scale factors 658 CALL iom_rstput( 0, 0, inum, 'e3u_0' , e3u_0 , ktype = jp_r8 ) 659 CALL iom_rstput( 0, 0, inum, 'e3v_0' , e3v_0 , ktype = jp_r8 ) 660 CALL iom_rstput( 0, 0, inum, 'e3f_0' , e3f_0 , ktype = jp_r8 ) 661 CALL iom_rstput( 0, 0, inum, 'e3w_0' , e3w_0 , ktype = jp_r8 ) 662 CALL iom_rstput( 0, 0, inum, 'e3uw_0' , e3uw_0 , ktype = jp_r8 ) 663 CALL iom_rstput( 0, 0, inum, 'e3vw_0' , e3vw_0 , ktype = jp_r8 ) 664 ! 665 ! !== wet top and bottom level ==! (caution: multiplied by ssmask) 666 ! 667 CALL iom_rstput( 0, 0, inum, 'top_level' , REAL( mikt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points (ISF) 668 CALL iom_rstput( 0, 0, inum, 'bottom_level' , REAL( mbkt, wp )*ssmask , ktype = jp_i4 ) ! nb of ocean T-points 669 ! 670 IF( ln_sco ) THEN ! s-coordinate: store grid stiffness ratio (Not required anyway) 671 CALL dom_stiff( z2d ) 672 CALL iom_rstput( 0, 0, inum, 'stiffness', z2d ) ! ! Max. grid stiffness ratio 673 ENDIF 674 ! 675 IF( ln_wd ) THEN ! wetting and drying domain 676 CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 ) 677 CALL iom_rstput( 0, 0, inum, 'ht_wd' , ht_wd , ktype = jp_r8 ) 678 ENDIF 679 ! 680 ! Add some global attributes ( netcdf only ) 681 IF( iom_file(inum)%iolib == jpnf90 ) THEN 682 CALL iom_putatt( inum, 'nn_cfg', nn_cfg ) 683 CALL iom_putatt( inum, 'cn_cfg', TRIM(cn_cfg) ) 684 ENDIF 685 ! 686 ! ! ============================ 687 ! ! close the files 688 ! ! ============================ 689 CALL iom_close( inum ) 690 ! 691 END SUBROUTINE cfg_write 466 692 467 693 !!====================================================================== -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90
r6140 r7646 16 16 !! 3.7 ! 2015-09 (G. Madec, S. Flavoni) add cell surface and their inverse 17 17 !! add optional read of e1e2u & e1e2v 18 !! - ! 2016-04 (S. Flavoni, G. Madec) new configuration interface: read or usrdef.F90 18 19 !!---------------------------------------------------------------------- 19 20 20 21 !!---------------------------------------------------------------------- 21 22 !! dom_hgr : initialize the horizontal mesh 22 !! hgr_read : read "coordinate" NetCDFfile23 !! hgr_read : read horizontal information in the domain configuration file 23 24 !!---------------------------------------------------------------------- 24 25 USE dom_oce ! ocean space and time domain 26 USE par_oce ! ocean space and time domain 25 27 USE phycst ! physical constants 26 USE domwri ! write 'meshmask.nc' & 'coordinate_e1e2u_v.nc' files28 USE usrdef_hgr ! User defined routine 27 29 ! 28 30 USE in_out_manager ! I/O manager 31 USE iom ! I/O library 29 32 USE lib_mpp ! MPP library 30 33 USE timing ! Timing … … 33 36 PRIVATE 34 37 35 REAL(wp) :: glam0, gphi0 ! variables corresponding to parameters ppglam0 ppgphi0 set in par_oce36 37 38 PUBLIC dom_hgr ! called by domain.F90 38 39 39 40 !!---------------------------------------------------------------------- 40 !! NEMO/OPA 3.7 , NEMO Consortium (201 4)41 !! NEMO/OPA 3.7 , NEMO Consortium (2016) 41 42 !! $Id$ 42 43 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 48 49 !! *** ROUTINE dom_hgr *** 49 50 !! 50 !! ** Purpose : Compute the geographical position (in degre) of the 51 !! model grid-points, the horizontal scale factors (in meters) and 52 !! the Coriolis factor (in s-1). 53 !! 54 !! ** Method : The geographical position of the model grid-points is 55 !! defined from analytical functions, fslam and fsphi, the deriva- 56 !! tives of which gives the horizontal scale factors e1,e2. 57 !! Defining two function fslam and fsphi and their derivatives in 58 !! the two horizontal directions (fse1 and fse2), the model grid- 59 !! point position and scale factors are given by: 60 !! t-point: 61 !! glamt(i,j) = fslam(i ,j ) e1t(i,j) = fse1(i ,j ) 62 !! gphit(i,j) = fsphi(i ,j ) e2t(i,j) = fse2(i ,j ) 63 !! u-point: 64 !! glamu(i,j) = fslam(i+1/2,j ) e1u(i,j) = fse1(i+1/2,j ) 65 !! gphiu(i,j) = fsphi(i+1/2,j ) e2u(i,j) = fse2(i+1/2,j ) 66 !! v-point: 67 !! glamv(i,j) = fslam(i ,j+1/2) e1v(i,j) = fse1(i ,j+1/2) 68 !! gphiv(i,j) = fsphi(i ,j+1/2) e2v(i,j) = fse2(i ,j+1/2) 69 !! f-point: 70 !! glamf(i,j) = fslam(i+1/2,j+1/2) e1f(i,j) = fse1(i+1/2,j+1/2) 71 !! gphif(i,j) = fsphi(i+1/2,j+1/2) e2f(i,j) = fse2(i+1/2,j+1/2) 72 !! Where fse1 and fse2 are defined by: 73 !! fse1(i,j) = ra * rad * SQRT( (cos(phi) di(fslam))**2 74 !! + di(fsphi) **2 )(i,j) 75 !! fse2(i,j) = ra * rad * SQRT( (cos(phi) dj(fslam))**2 76 !! + dj(fsphi) **2 )(i,j) 77 !! 78 !! The coriolis factor is given at z-point by: 79 !! ff = 2.*omega*sin(gphif) (in s-1) 80 !! 81 !! This routine is given as an example, it must be modified 82 !! following the user s desiderata. nevertheless, the output as 83 !! well as the way to compute the model grid-point position and 84 !! horizontal scale factors must be respected in order to insure 85 !! second order accuracy schemes. 86 !! 87 !! N.B. If the domain is periodic, verify that scale factors are also 88 !! periodic, and the coriolis term again. 89 !! 90 !! ** Action : - define glamt, glamu, glamv, glamf: longitude of t-, 91 !! u-, v- and f-points (in degre) 92 !! - define gphit, gphiu, gphiv, gphit: latitude of t-, 93 !! u-, v- and f-points (in degre) 94 !! define e1t, e2t, e1u, e2u, e1v, e2v, e1f, e2f: horizontal 95 !! scale factors (in meters) at t-, u-, v-, and f-points. 96 !! define ff: coriolis factor at f-point 97 !! 98 !! References : Marti, Madec and Delecluse, 1992, JGR 99 !! Madec, Imbard, 1996, Clim. Dyn. 100 !!---------------------------------------------------------------------- 101 INTEGER :: ji, jj ! dummy loop indices 102 INTEGER :: ii0, ii1, ij0, ij1 ! temporary integers 103 INTEGER :: ijeq ! index of equator T point (used in case 4) 104 REAL(wp) :: zti, zui, zvi, zfi ! local scalars 105 REAL(wp) :: ztj, zuj, zvj, zfj ! - - 106 REAL(wp) :: zphi0, zbeta, znorme ! 107 REAL(wp) :: zarg, zf0, zminff, zmaxff 108 REAL(wp) :: zlam1, zcos_alpha, zim1 , zjm1 , ze1, ze1deg 109 REAL(wp) :: zphi1, zsin_alpha, zim05, zjm05 110 INTEGER :: isrow ! index for ORCA1 starting row 111 INTEGER :: ie1e2u_v ! fag for u- & v-surface read in coordinate file or not 51 !! ** Purpose : Read or compute the geographical position (in degrees) 52 !! of the model grid-points, the horizontal scale factors (in meters), 53 !! the associated horizontal metrics, and the Coriolis factor (in s-1). 54 !! 55 !! ** Method : Controlled by ln_read_cfg logical 56 !! =T : all needed arrays are read in mesh_mask.nc file 57 !! =F : user-defined configuration, all needed arrays 58 !! are computed in usr-def_hgr subroutine 59 !! 60 !! If Coriolis factor is neither read nor computed (iff=0) 61 !! it is computed from gphit assuming that the mesh is 62 !! defined on the sphere : 63 !! ff = 2.*omega*sin(gphif) (in s-1) 64 !! 65 !! If u- & v-surfaces are neither read nor computed (ie1e2u_v=0) 66 !! (i.e. no use of reduced scale factors in some straits) 67 !! they are computed from e1u, e2u, e1v and e2v as: 68 !! e1e2u = e1u*e2u and e1e2v = e1v*e2v 69 !! 70 !! ** Action : - define longitude & latitude of t-, u-, v- and f-points (in degrees) 71 !! - define Coriolis parameter at f-point (in 1/s) 72 !! - define i- & j-scale factors at t-, u-, v- and f-points (in meters) 73 !! - define associated horizontal metrics at t-, u-, v- and f-points 74 !! (inverse of scale factors 1/e1 & 1/e2, surface e1*e2, ratios e1/e2 & e2/e1) 75 !!---------------------------------------------------------------------- 76 INTEGER :: ji, jj ! dummy loop indices 77 INTEGER :: ie1e2u_v ! flag for u- & v-surfaces 78 INTEGER :: iff ! flag for Coriolis parameter 112 79 !!---------------------------------------------------------------------- 113 80 ! … … 117 84 WRITE(numout,*) 118 85 WRITE(numout,*) 'dom_hgr : define the horizontal mesh from ithe following par_oce parameters ' 119 WRITE(numout,*) '~~~~~~~ type of horizontal mesh jphgr_msh = ', jphgr_msh 120 WRITE(numout,*) ' position of the first row and ppglam0 = ', ppglam0 121 WRITE(numout,*) ' column grid-point (degrees) ppgphi0 = ', ppgphi0 122 WRITE(numout,*) ' zonal grid-spacing (degrees) ppe1_deg = ', ppe1_deg 123 WRITE(numout,*) ' meridional grid-spacing (degrees) ppe2_deg = ', ppe2_deg 124 WRITE(numout,*) ' zonal grid-spacing (meters) ppe1_m = ', ppe1_m 125 WRITE(numout,*) ' meridional grid-spacing (meters) ppe2_m = ', ppe2_m 126 ENDIF 127 ! 128 ! 129 SELECT CASE( jphgr_msh ) ! type of horizontal mesh 130 ! 131 CASE ( 0 ) !== read in coordinate.nc file ==! 132 ! 86 WRITE(numout,*) '~~~~~~~ ' 87 WRITE(numout,*) ' namcfg : read (=T) or user defined (=F) configuration ln_read_cfg = ', ln_read_cfg 88 ENDIF 89 ! 90 ! 91 IF( ln_read_cfg ) THEN !== read in mesh_mask.nc file ==! 133 92 IF(lwp) WRITE(numout,*) 134 IF(lwp) WRITE(numout,*) ' curvilinear coordinate on the sphere read in "coordinate" file' 135 ! 136 ie1e2u_v = 0 ! set to unread e1e2u and e1e2v 137 ! 138 CALL hgr_read( ie1e2u_v ) ! read the coordinate.nc file 139 ! 140 IF( ie1e2u_v == 0 ) THEN ! e1e2u and e1e2v have not been read: compute them 141 ! ! e2u and e1v does not include a reduction in some strait: apply reduction 142 e1e2u (:,:) = e1u(:,:) * e2u(:,:) 143 e1e2v (:,:) = e1v(:,:) * e2v(:,:) 93 IF(lwp) WRITE(numout,*) ' read horizontal mesh in ', TRIM( cn_domcfg ), ' file' 94 ! 95 CALL hgr_read ( glamt , glamu , glamv , glamf , & ! geographic position (required) 96 & gphit , gphiu , gphiv , gphif , & ! - - 97 & iff , ff_f , ff_t , & ! Coriolis parameter (if not on the sphere) 98 & e1t , e1u , e1v , e1f , & ! scale factors (required) 99 & e2t , e2u , e2v , e2f , & ! - - - 100 & ie1e2u_v , e1e2u , e1e2v ) ! u- & v-surfaces (if gridsize reduction in some straits) 101 ! 102 ELSE !== User defined configuration ==! 103 IF(lwp) WRITE(numout,*) 104 IF(lwp) WRITE(numout,*) ' User defined horizontal mesh (usr_def_hgr)' 105 ! 106 CALL usr_def_hgr( glamt , glamu , glamv , glamf , & ! geographic position (required) 107 & gphit , gphiu , gphiv , gphif , & ! 108 & iff , ff_f , ff_t , & ! Coriolis parameter (if domain not on the sphere) 109 & e1t , e1u , e1v , e1f , & ! scale factors (required) 110 & e2t , e2u , e2v , e2f , & ! 111 & ie1e2u_v , e1e2u , e1e2v ) ! u- & v-surfaces (if gridsize reduction is used in strait(s)) 112 ! 113 ENDIF 114 ! 115 ! !== Coriolis parameter ==! (if necessary) 116 ! 117 IF( iff == 0 ) THEN ! Coriolis parameter has not been defined 118 IF(lwp) WRITE(numout,*) ' Coriolis parameter calculated on the sphere from gphif & gphit' 119 ff_f(:,:) = 2. * omega * SIN( rad * gphif(:,:) ) ! compute it on the sphere at f-point 120 ff_t(:,:) = 2. * omega * SIN( rad * gphit(:,:) ) ! - - - at t-point 121 ELSE 122 IF( ln_read_cfg ) THEN 123 IF(lwp) WRITE(numout,*) ' Coriolis parameter have been read in ', TRIM( cn_domcfg ), ' file' 124 ELSE 125 IF(lwp) WRITE(numout,*) ' Coriolis parameter have been set in usr_def_hgr routine' 144 126 ENDIF 145 ! 146 CASE ( 1 ) !== geographical mesh on the sphere with regular (in degree) grid-spacing ==! 147 ! 148 IF(lwp) WRITE(numout,*) 149 IF(lwp) WRITE(numout,*) ' geographical mesh on the sphere with regular grid-spacing' 150 IF(lwp) WRITE(numout,*) ' given by ppe1_deg and ppe2_deg' 151 ! 152 DO jj = 1, jpj 153 DO ji = 1, jpi 154 zti = REAL( ji - 1 + nimpp - 1 ) ; ztj = REAL( jj - 1 + njmpp - 1 ) 155 zui = REAL( ji - 1 + nimpp - 1 ) + 0.5 ; zuj = REAL( jj - 1 + njmpp - 1 ) 156 zvi = REAL( ji - 1 + nimpp - 1 ) ; zvj = REAL( jj - 1 + njmpp - 1 ) + 0.5 157 zfi = REAL( ji - 1 + nimpp - 1 ) + 0.5 ; zfj = REAL( jj - 1 + njmpp - 1 ) + 0.5 158 ! Longitude 159 glamt(ji,jj) = ppglam0 + ppe1_deg * zti 160 glamu(ji,jj) = ppglam0 + ppe1_deg * zui 161 glamv(ji,jj) = ppglam0 + ppe1_deg * zvi 162 glamf(ji,jj) = ppglam0 + ppe1_deg * zfi 163 ! Latitude 164 gphit(ji,jj) = ppgphi0 + ppe2_deg * ztj 165 gphiu(ji,jj) = ppgphi0 + ppe2_deg * zuj 166 gphiv(ji,jj) = ppgphi0 + ppe2_deg * zvj 167 gphif(ji,jj) = ppgphi0 + ppe2_deg * zfj 168 ! e1 169 e1t(ji,jj) = ra * rad * COS( rad * gphit(ji,jj) ) * ppe1_deg 170 e1u(ji,jj) = ra * rad * COS( rad * gphiu(ji,jj) ) * ppe1_deg 171 e1v(ji,jj) = ra * rad * COS( rad * gphiv(ji,jj) ) * ppe1_deg 172 e1f(ji,jj) = ra * rad * COS( rad * gphif(ji,jj) ) * ppe1_deg 173 ! e2 174 e2t(ji,jj) = ra * rad * ppe2_deg 175 e2u(ji,jj) = ra * rad * ppe2_deg 176 e2v(ji,jj) = ra * rad * ppe2_deg 177 e2f(ji,jj) = ra * rad * ppe2_deg 178 END DO 179 END DO 180 ! 181 CASE ( 2:3 ) !== f- or beta-plane with regular grid-spacing ==! 182 ! 183 IF(lwp) WRITE(numout,*) 184 IF(lwp) WRITE(numout,*) ' f- or beta-plane with regular grid-spacing' 185 IF(lwp) WRITE(numout,*) ' given by ppe1_m and ppe2_m' 186 ! 187 ! Position coordinates (in kilometers) 188 ! ========== 189 glam0 = 0._wp 190 gphi0 = - ppe2_m * 1.e-3 191 ! 192 #if defined key_agrif 193 IF ( cp_cfg == 'eel' .AND. jp_cfg == 6 ) THEN ! for EEL6 configuration only 194 IF( .NOT. Agrif_Root() ) THEN 195 glam0 = Agrif_Parent(glam0) + (Agrif_ix())*Agrif_Parent(ppe1_m) * 1.e-3 196 gphi0 = Agrif_Parent(gphi0) + (Agrif_iy())*Agrif_Parent(ppe2_m) * 1.e-3 197 ppe1_m = Agrif_Parent(ppe1_m)/Agrif_Rhox() 198 ppe2_m = Agrif_Parent(ppe2_m)/Agrif_Rhoy() 199 ENDIF 200 ENDIF 201 #endif 202 DO jj = 1, jpj 203 DO ji = 1, jpi 204 glamt(ji,jj) = glam0 + ppe1_m * 1.e-3 * ( REAL( ji - 1 + nimpp - 1 ) ) 205 glamu(ji,jj) = glam0 + ppe1_m * 1.e-3 * ( REAL( ji - 1 + nimpp - 1 ) + 0.5 ) 206 glamv(ji,jj) = glamt(ji,jj) 207 glamf(ji,jj) = glamu(ji,jj) 208 ! 209 gphit(ji,jj) = gphi0 + ppe2_m * 1.e-3 * ( REAL( jj - 1 + njmpp - 1 ) ) 210 gphiu(ji,jj) = gphit(ji,jj) 211 gphiv(ji,jj) = gphi0 + ppe2_m * 1.e-3 * ( REAL( jj - 1 + njmpp - 1 ) + 0.5 ) 212 gphif(ji,jj) = gphiv(ji,jj) 213 END DO 214 END DO 215 ! 216 ! Horizontal scale factors (in meters) 217 ! ====== 218 e1t(:,:) = ppe1_m ; e2t(:,:) = ppe2_m 219 e1u(:,:) = ppe1_m ; e2u(:,:) = ppe2_m 220 e1v(:,:) = ppe1_m ; e2v(:,:) = ppe2_m 221 e1f(:,:) = ppe1_m ; e2f(:,:) = ppe2_m 222 ! 223 CASE ( 4 ) !== geographical mesh on the sphere, isotropic MERCATOR type ==! 224 ! 225 IF(lwp) WRITE(numout,*) 226 IF(lwp) WRITE(numout,*) ' geographical mesh on the sphere, MERCATOR type' 227 IF(lwp) WRITE(numout,*) ' longitudinal/latitudinal spacing given by ppe1_deg' 228 IF ( ppgphi0 == -90 ) CALL ctl_stop( ' Mercator grid cannot start at south pole !!!! ' ) 229 ! 230 ! Find index corresponding to the equator, given the grid spacing e1_deg 231 ! and the (approximate) southern latitude ppgphi0. 232 ! This way we ensure that the equator is at a "T / U" point, when in the domain. 233 ! The formula should work even if the equator is outside the domain. 234 zarg = rpi / 4. - rpi / 180. * ppgphi0 / 2. 235 ijeq = ABS( 180./rpi * LOG( COS( zarg ) / SIN( zarg ) ) / ppe1_deg ) 236 IF( ppgphi0 > 0 ) ijeq = -ijeq 237 ! 238 IF(lwp) WRITE(numout,*) ' Index of the equator on the MERCATOR grid:', ijeq 239 ! 240 DO jj = 1, jpj 241 DO ji = 1, jpi 242 zti = REAL( ji - 1 + nimpp - 1 ) ; ztj = REAL( jj - ijeq + njmpp - 1 ) 243 zui = REAL( ji - 1 + nimpp - 1 ) + 0.5 ; zuj = REAL( jj - ijeq + njmpp - 1 ) 244 zvi = REAL( ji - 1 + nimpp - 1 ) ; zvj = REAL( jj - ijeq + njmpp - 1 ) + 0.5 245 zfi = REAL( ji - 1 + nimpp - 1 ) + 0.5 ; zfj = REAL( jj - ijeq + njmpp - 1 ) + 0.5 246 ! Longitude 247 glamt(ji,jj) = ppglam0 + ppe1_deg * zti 248 glamu(ji,jj) = ppglam0 + ppe1_deg * zui 249 glamv(ji,jj) = ppglam0 + ppe1_deg * zvi 250 glamf(ji,jj) = ppglam0 + ppe1_deg * zfi 251 ! Latitude 252 gphit(ji,jj) = 1./rad * ASIN ( TANH( ppe1_deg *rad* ztj ) ) 253 gphiu(ji,jj) = 1./rad * ASIN ( TANH( ppe1_deg *rad* zuj ) ) 254 gphiv(ji,jj) = 1./rad * ASIN ( TANH( ppe1_deg *rad* zvj ) ) 255 gphif(ji,jj) = 1./rad * ASIN ( TANH( ppe1_deg *rad* zfj ) ) 256 ! e1 257 e1t(ji,jj) = ra * rad * COS( rad * gphit(ji,jj) ) * ppe1_deg 258 e1u(ji,jj) = ra * rad * COS( rad * gphiu(ji,jj) ) * ppe1_deg 259 e1v(ji,jj) = ra * rad * COS( rad * gphiv(ji,jj) ) * ppe1_deg 260 e1f(ji,jj) = ra * rad * COS( rad * gphif(ji,jj) ) * ppe1_deg 261 ! e2 262 e2t(ji,jj) = ra * rad * COS( rad * gphit(ji,jj) ) * ppe1_deg 263 e2u(ji,jj) = ra * rad * COS( rad * gphiu(ji,jj) ) * ppe1_deg 264 e2v(ji,jj) = ra * rad * COS( rad * gphiv(ji,jj) ) * ppe1_deg 265 e2f(ji,jj) = ra * rad * COS( rad * gphif(ji,jj) ) * ppe1_deg 266 END DO 267 END DO 268 ! 269 CASE ( 5 ) !== beta-plane with regular grid-spacing and rotated domain ==! (GYRE configuration) 270 ! 271 IF(lwp) WRITE(numout,*) 272 IF(lwp) WRITE(numout,*) ' beta-plane with regular grid-spacing and rotated domain (GYRE configuration)' 273 IF(lwp) WRITE(numout,*) ' given by ppe1_m and ppe2_m' 274 ! 275 ! Position coordinates (in kilometers) 276 ! ========== 277 ! 278 ! angle 45deg and ze1=106.e+3 / jp_cfg forced -> zlam1 = -85deg, zphi1 = 29degN 279 zlam1 = -85._wp 280 zphi1 = 29._wp 281 ! resolution in meters 282 ze1 = 106000. / REAL( jp_cfg , wp ) 283 ! benchmark: forced the resolution to be about 100 km 284 IF( nbench /= 0 ) ze1 = 106000._wp 285 zsin_alpha = - SQRT( 2._wp ) * 0.5_wp 286 zcos_alpha = SQRT( 2._wp ) * 0.5_wp 287 ze1deg = ze1 / (ra * rad) 288 IF( nbench /= 0 ) ze1deg = ze1deg / REAL( jp_cfg , wp ) ! benchmark: keep the lat/+lon 289 ! ! at the right jp_cfg resolution 290 glam0 = zlam1 + zcos_alpha * ze1deg * REAL( jpjglo-2 , wp ) 291 gphi0 = zphi1 + zsin_alpha * ze1deg * REAL( jpjglo-2 , wp ) 292 ! 293 IF( nprint==1 .AND. lwp ) THEN 294 WRITE(numout,*) ' ze1', ze1, 'cosalpha', zcos_alpha, 'sinalpha', zsin_alpha 295 WRITE(numout,*) ' ze1deg', ze1deg, 'glam0', glam0, 'gphi0', gphi0 296 ENDIF 297 ! 298 DO jj = 1, jpj 299 DO ji = 1, jpi 300 zim1 = REAL( ji + nimpp - 1 ) - 1. ; zim05 = REAL( ji + nimpp - 1 ) - 1.5 301 zjm1 = REAL( jj + njmpp - 1 ) - 1. ; zjm05 = REAL( jj + njmpp - 1 ) - 1.5 302 ! 303 glamf(ji,jj) = glam0 + zim1 * ze1deg * zcos_alpha + zjm1 * ze1deg * zsin_alpha 304 gphif(ji,jj) = gphi0 - zim1 * ze1deg * zsin_alpha + zjm1 * ze1deg * zcos_alpha 305 ! 306 glamt(ji,jj) = glam0 + zim05 * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha 307 gphit(ji,jj) = gphi0 - zim05 * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha 308 ! 309 glamu(ji,jj) = glam0 + zim1 * ze1deg * zcos_alpha + zjm05 * ze1deg * zsin_alpha 310 gphiu(ji,jj) = gphi0 - zim1 * ze1deg * zsin_alpha + zjm05 * ze1deg * zcos_alpha 311 ! 312 glamv(ji,jj) = glam0 + zim05 * ze1deg * zcos_alpha + zjm1 * ze1deg * zsin_alpha 313 gphiv(ji,jj) = gphi0 - zim05 * ze1deg * zsin_alpha + zjm1 * ze1deg * zcos_alpha 314 END DO 315 END DO 316 ! 317 ! Horizontal scale factors (in meters) 318 ! ====== 319 e1t(:,:) = ze1 ; e2t(:,:) = ze1 320 e1u(:,:) = ze1 ; e2u(:,:) = ze1 321 e1v(:,:) = ze1 ; e2v(:,:) = ze1 322 e1f(:,:) = ze1 ; e2f(:,:) = ze1 323 ! 324 CASE DEFAULT 325 WRITE(ctmp1,*) ' bad flag value for jphgr_msh = ', jphgr_msh 326 CALL ctl_stop( ctmp1 ) 327 ! 328 END SELECT 329 330 ! associated horizontal metrics 331 ! ----------------------------- 127 ENDIF 128 129 ! 130 ! !== associated horizontal metrics ==! 332 131 ! 333 132 r1_e1t(:,:) = 1._wp / e1t(:,:) ; r1_e2t (:,:) = 1._wp / e2t(:,:) … … 338 137 e1e2t (:,:) = e1t(:,:) * e2t(:,:) ; r1_e1e2t(:,:) = 1._wp / e1e2t(:,:) 339 138 e1e2f (:,:) = e1f(:,:) * e2f(:,:) ; r1_e1e2f(:,:) = 1._wp / e1e2f(:,:) 340 IF( jphgr_msh /= 0 ) THEN ! e1e2u and e1e2v have not been set: compute them 341 e1e2u (:,:) = e1u(:,:) * e2u(:,:) 139 IF( ie1e2u_v == 0 ) THEN ! u- & v-surfaces have not been defined 140 IF(lwp) WRITE(numout,*) ' u- & v-surfaces calculated as e1 e2 product' 141 e1e2u (:,:) = e1u(:,:) * e2u(:,:) ! compute them 342 142 e1e2v (:,:) = e1v(:,:) * e2v(:,:) 343 ENDIF 344 r1_e1e2u(:,:) = 1._wp / e1e2u(:,:) ! compute their invert in both cases 143 ELSE 144 IF(lwp) WRITE(numout,*) ' u- & v-surfaces have been read in "mesh_mask" file:' 145 IF(lwp) WRITE(numout,*) ' grid size reduction in strait(s) is used' 146 ENDIF 147 r1_e1e2u(:,:) = 1._wp / e1e2u(:,:) ! compute their invert in any cases 345 148 r1_e1e2v(:,:) = 1._wp / e1e2v(:,:) 346 149 ! 347 150 e2_e1u(:,:) = e2u(:,:) / e1u(:,:) 348 151 e1_e2v(:,:) = e1v(:,:) / e2v(:,:) 349 350 IF( lwp .AND. nn_print >=1 .AND. .NOT.ln_rstart ) THEN ! Control print : Grid informations (if not restart) 351 WRITE(numout,*) 352 WRITE(numout,*) ' longitude and e1 scale factors' 353 WRITE(numout,*) ' ------------------------------' 354 WRITE(numout,9300) ( ji, glamt(ji,1), glamu(ji,1), & 355 glamv(ji,1), glamf(ji,1), & 356 e1t(ji,1), e1u(ji,1), & 357 e1v(ji,1), e1f(ji,1), ji = 1, jpi,10) 358 9300 FORMAT( 1x, i4, f8.2,1x, f8.2,1x, f8.2,1x, f8.2, 1x, & 359 f19.10, 1x, f19.10, 1x, f19.10, 1x, f19.10 ) 360 ! 361 WRITE(numout,*) 362 WRITE(numout,*) ' latitude and e2 scale factors' 363 WRITE(numout,*) ' -----------------------------' 364 WRITE(numout,9300) ( jj, gphit(1,jj), gphiu(1,jj), & 365 & gphiv(1,jj), gphif(1,jj), & 366 & e2t (1,jj), e2u (1,jj), & 367 & e2v (1,jj), e2f (1,jj), jj = 1, jpj, 10 ) 368 ENDIF 369 370 371 ! ================= ! 372 ! Coriolis factor ! 373 ! ================= ! 374 375 SELECT CASE( jphgr_msh ) ! type of horizontal mesh 376 ! 377 CASE ( 0, 1, 4 ) ! mesh on the sphere 378 ! 379 ff(:,:) = 2. * omega * SIN( rad * gphif(:,:) ) 380 ! 381 CASE ( 2 ) ! f-plane at ppgphi0 382 ! 383 ff(:,:) = 2. * omega * SIN( rad * ppgphi0 ) 384 ! 385 IF(lwp) WRITE(numout,*) ' f-plane: Coriolis parameter = constant = ', ff(1,1) 386 ! 387 CASE ( 3 ) ! beta-plane 388 ! 389 zbeta = 2. * omega * COS( rad * ppgphi0 ) / ra ! beta at latitude ppgphi0 390 zphi0 = ppgphi0 - REAL( jpjglo/2) * ppe2_m / ( ra * rad ) ! latitude of the first row F-points 391 ! 392 #if defined key_agrif 393 IF( cp_cfg == 'eel' .AND. jp_cfg == 6 ) THEN ! for EEL6 configuration only 394 IF( .NOT.Agrif_Root() ) THEN 395 zphi0 = ppgphi0 - REAL( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m) / (ra * rad) 396 ENDIF 397 ENDIF 398 #endif 399 zf0 = 2. * omega * SIN( rad * zphi0 ) ! compute f0 1st point south 400 ! 401 ff(:,:) = ( zf0 + zbeta * gphif(:,:) * 1.e+3 ) ! f = f0 +beta* y ( y=0 at south) 402 ! 403 IF(lwp) THEN 404 WRITE(numout,*) 405 WRITE(numout,*) ' Beta-plane: Beta parameter = constant = ', ff(nldi,nldj) 406 WRITE(numout,*) ' Coriolis parameter varies from ', ff(nldi,nldj),' to ', ff(nldi,nlej) 407 ENDIF 408 IF( lk_mpp ) THEN 409 zminff=ff(nldi,nldj) 410 zmaxff=ff(nldi,nlej) 411 CALL mpp_min( zminff ) ! min over the global domain 412 CALL mpp_max( zmaxff ) ! max over the global domain 413 IF(lwp) WRITE(numout,*) ' Coriolis parameter varies globally from ', zminff,' to ', zmaxff 414 END IF 415 ! 416 CASE ( 5 ) ! beta-plane and rotated domain (gyre configuration) 417 ! 418 zbeta = 2. * omega * COS( rad * ppgphi0 ) / ra ! beta at latitude ppgphi0 419 zphi0 = 15._wp ! latitude of the first row F-points 420 zf0 = 2. * omega * SIN( rad * zphi0 ) ! compute f0 1st point south 421 ! 422 ff(:,:) = ( zf0 + zbeta * ABS( gphif(:,:) - zphi0 ) * rad * ra ) ! f = f0 +beta* y ( y=0 at south) 423 ! 424 IF(lwp) THEN 425 WRITE(numout,*) 426 WRITE(numout,*) ' Beta-plane and rotated domain : ' 427 WRITE(numout,*) ' Coriolis parameter varies in this processor from ', ff(nldi,nldj),' to ', ff(nldi,nlej) 428 ENDIF 429 ! 430 IF( lk_mpp ) THEN 431 zminff=ff(nldi,nldj) 432 zmaxff=ff(nldi,nlej) 433 CALL mpp_min( zminff ) ! min over the global domain 434 CALL mpp_max( zmaxff ) ! max over the global domain 435 IF(lwp) WRITE(numout,*) ' Coriolis parameter varies globally from ', zminff,' to ', zmaxff 436 END IF 437 ! 438 END SELECT 439 440 441 ! Control of domain for symetrical condition 442 ! ------------------------------------------ 443 ! The equator line must be the latitude coordinate axe 444 445 IF( nperio == 2 ) THEN 446 znorme = SQRT( SUM( gphiu(:,2) * gphiu(:,2) ) ) / REAL( jpi ) 447 IF( znorme > 1.e-13 ) CALL ctl_stop( ' ===>>>> : symmetrical condition: rerun with good equator line' ) 448 ENDIF 152 ! 449 153 ! 450 154 IF( nn_timing == 1 ) CALL timing_stop('dom_hgr') … … 453 157 454 158 455 SUBROUTINE hgr_read( ke1e2u_v ) 159 SUBROUTINE hgr_read( plamt , plamu , plamv , plamf , & ! gridpoints position (required) 160 & pphit , pphiu , pphiv , pphif , & 161 & kff , pff_f , pff_t , & ! Coriolis parameter (if not on the sphere) 162 & pe1t , pe1u , pe1v , pe1f , & ! scale factors (required) 163 & pe2t , pe2u , pe2v , pe2f , & 164 & ke1e2u_v , pe1e2u , pe1e2v ) ! u- & v-surfaces (if gridsize reduction in some straits) 456 165 !!--------------------------------------------------------------------- 457 166 !! *** ROUTINE hgr_read *** 458 167 !! 459 !! ** Purpose : Read a coordinate file in NetCDF format using IOM 460 !! 461 !!---------------------------------------------------------------------- 462 USE iom 463 !! 464 INTEGER, INTENT( inout ) :: ke1e2u_v ! fag: e1e2u & e1e2v read in coordinate file (=1) or not (=0) 465 ! 466 INTEGER :: inum ! temporary logical unit 168 !! ** Purpose : Read a mesh_mask file in NetCDF format using IOM 169 !! 170 !!---------------------------------------------------------------------- 171 REAL(wp), DIMENSION(:,:), INTENT(out) :: plamt, plamu, plamv, plamf ! longitude outputs 172 REAL(wp), DIMENSION(:,:), INTENT(out) :: pphit, pphiu, pphiv, pphif ! latitude outputs 173 INTEGER , INTENT(out) :: kff ! =1 Coriolis parameter read here, =0 otherwise 174 REAL(wp), DIMENSION(:,:), INTENT(out) :: pff_f, pff_t ! Coriolis factor at f-point (if found in file) 175 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1t, pe1u, pe1v, pe1f ! i-scale factors 176 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2u, pe2v, pe2f ! j-scale factors 177 INTEGER , INTENT(out) :: ke1e2u_v ! =1 u- & v-surfaces read here, =0 otherwise 178 REAL(wp), DIMENSION(:,:), INTENT(out) :: pe1e2u, pe1e2v ! u- & v-surfaces (if found in file) 179 ! 180 INTEGER :: inum ! logical unit 467 181 !!---------------------------------------------------------------------- 468 182 ! 469 183 IF(lwp) THEN 470 184 WRITE(numout,*) 471 WRITE(numout,*) 'hgr_read : read the horizontal coordinates '185 WRITE(numout,*) 'hgr_read : read the horizontal coordinates in mesh_mask' 472 186 WRITE(numout,*) '~~~~~~~~ jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpk = ', jpk 473 187 ENDIF 474 188 ! 475 CALL iom_open( 'coordinates', inum ) 476 ! 477 CALL iom_get( inum, jpdom_data, 'glamt', glamt, lrowattr=ln_use_jattr ) 478 CALL iom_get( inum, jpdom_data, 'glamu', glamu, lrowattr=ln_use_jattr ) 479 CALL iom_get( inum, jpdom_data, 'glamv', glamv, lrowattr=ln_use_jattr ) 480 CALL iom_get( inum, jpdom_data, 'glamf', glamf, lrowattr=ln_use_jattr ) 481 ! 482 CALL iom_get( inum, jpdom_data, 'gphit', gphit, lrowattr=ln_use_jattr ) 483 CALL iom_get( inum, jpdom_data, 'gphiu', gphiu, lrowattr=ln_use_jattr ) 484 CALL iom_get( inum, jpdom_data, 'gphiv', gphiv, lrowattr=ln_use_jattr ) 485 CALL iom_get( inum, jpdom_data, 'gphif', gphif, lrowattr=ln_use_jattr ) 486 ! 487 CALL iom_get( inum, jpdom_data, 'e1t' , e1t , lrowattr=ln_use_jattr ) 488 CALL iom_get( inum, jpdom_data, 'e1u' , e1u , lrowattr=ln_use_jattr ) 489 CALL iom_get( inum, jpdom_data, 'e1v' , e1v , lrowattr=ln_use_jattr ) 490 CALL iom_get( inum, jpdom_data, 'e1f' , e1f , lrowattr=ln_use_jattr ) 491 ! 492 CALL iom_get( inum, jpdom_data, 'e2t' , e2t , lrowattr=ln_use_jattr ) 493 CALL iom_get( inum, jpdom_data, 'e2u' , e2u , lrowattr=ln_use_jattr ) 494 CALL iom_get( inum, jpdom_data, 'e2v' , e2v , lrowattr=ln_use_jattr ) 495 CALL iom_get( inum, jpdom_data, 'e2f' , e2f , lrowattr=ln_use_jattr ) 189 CALL iom_open( cn_domcfg, inum ) 190 ! 191 CALL iom_get( inum, jpdom_data, 'glamt', plamt, lrowattr=ln_use_jattr ) 192 CALL iom_get( inum, jpdom_data, 'glamu', plamu, lrowattr=ln_use_jattr ) 193 CALL iom_get( inum, jpdom_data, 'glamv', plamv, lrowattr=ln_use_jattr ) 194 CALL iom_get( inum, jpdom_data, 'glamf', plamf, lrowattr=ln_use_jattr ) 195 ! 196 CALL iom_get( inum, jpdom_data, 'gphit', pphit, lrowattr=ln_use_jattr ) 197 CALL iom_get( inum, jpdom_data, 'gphiu', pphiu, lrowattr=ln_use_jattr ) 198 CALL iom_get( inum, jpdom_data, 'gphiv', pphiv, lrowattr=ln_use_jattr ) 199 CALL iom_get( inum, jpdom_data, 'gphif', pphif, lrowattr=ln_use_jattr ) 200 ! 201 CALL iom_get( inum, jpdom_data, 'e1t' , pe1t , lrowattr=ln_use_jattr ) 202 CALL iom_get( inum, jpdom_data, 'e1u' , pe1u , lrowattr=ln_use_jattr ) 203 CALL iom_get( inum, jpdom_data, 'e1v' , pe1v , lrowattr=ln_use_jattr ) 204 CALL iom_get( inum, jpdom_data, 'e1f' , pe1f , lrowattr=ln_use_jattr ) 205 ! 206 CALL iom_get( inum, jpdom_data, 'e2t' , pe2t , lrowattr=ln_use_jattr ) 207 CALL iom_get( inum, jpdom_data, 'e2u' , pe2u , lrowattr=ln_use_jattr ) 208 CALL iom_get( inum, jpdom_data, 'e2v' , pe2v , lrowattr=ln_use_jattr ) 209 CALL iom_get( inum, jpdom_data, 'e2f' , pe2f , lrowattr=ln_use_jattr ) 210 ! 211 IF( iom_varid( inum, 'ff_f', ldstop = .FALSE. ) > 0 .AND. & 212 & iom_varid( inum, 'ff_t', ldstop = .FALSE. ) > 0 ) THEN 213 IF(lwp) WRITE(numout,*) ' Coriolis factor at f- and t-points read in ', TRIM( cn_domcfg ), ' file' 214 CALL iom_get( inum, jpdom_data, 'ff_f' , pff_f , lrowattr=ln_use_jattr ) 215 CALL iom_get( inum, jpdom_data, 'ff_t' , pff_t , lrowattr=ln_use_jattr ) 216 kff = 1 217 ELSE 218 kff = 0 219 ENDIF 496 220 ! 497 221 IF( iom_varid( inum, 'e1e2u', ldstop = .FALSE. ) > 0 ) THEN 498 IF(lwp) WRITE(numout,*) ' hgr_read : e1e2u & e1e2v read in coordinatesfile'499 CALL iom_get( inum, jpdom_data, 'e1e2u' , e1e2u , lrowattr=ln_use_jattr )500 CALL iom_get( inum, jpdom_data, 'e1e2v' , e1e2v , lrowattr=ln_use_jattr )222 IF(lwp) WRITE(numout,*) ' e1e2u & e1e2v read in ', TRIM( cn_domcfg ), ' file' 223 CALL iom_get( inum, jpdom_data, 'e1e2u' , pe1e2u , lrowattr=ln_use_jattr ) 224 CALL iom_get( inum, jpdom_data, 'e1e2v' , pe1e2v , lrowattr=ln_use_jattr ) 501 225 ke1e2u_v = 1 502 226 ELSE … … 505 229 ! 506 230 CALL iom_close( inum ) 507 508 231 ! 232 END SUBROUTINE hgr_read 509 233 510 234 !!====================================================================== -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r6140 r7646 9 9 !! - ! 1996-05 (G. Madec) mask computed from tmask 10 10 !! 8.0 ! 1997-02 (G. Madec) mesh information put in domhgr.F 11 !! 8.1 ! 1997-07 (G. Madec) modification of mbathyand fmask11 !! 8.1 ! 1997-07 (G. Madec) modification of kbat and fmask 12 12 !! - ! 1998-05 (G. Roullet) free surface 13 13 !! 8.2 ! 2000-03 (G. Madec) no slip accurate … … 17 17 !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option 18 18 !! 3.6 ! 2015-05 (P. Mathiot) ISF: add wmask,wumask and wvmask 19 !!---------------------------------------------------------------------- 20 21 !!---------------------------------------------------------------------- 22 !! dom_msk : compute land/ocean mask 23 !!---------------------------------------------------------------------- 24 USE oce ! ocean dynamics and tracers 25 USE dom_oce ! ocean space and time domain 26 ! 27 USE in_out_manager ! I/O manager 28 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 29 USE lib_mpp ! 30 USE wrk_nemo ! Memory allocation 31 USE timing ! Timing 19 !! 4.0 ! 2016-06 (G. Madec, S. Flavoni) domain configuration / user defined interface 20 !!---------------------------------------------------------------------- 21 22 !!---------------------------------------------------------------------- 23 !! dom_msk : compute land/ocean mask 24 !!---------------------------------------------------------------------- 25 USE oce ! ocean dynamics and tracers 26 USE dom_oce ! ocean space and time domain 27 USE usrdef_fmask ! user defined fmask 28 USE bdy_oce 29 USE in_out_manager ! I/O manager 30 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 31 USE lib_mpp ! Massively Parallel Processing library 32 USE wrk_nemo ! Memory allocation 33 USE timing ! Timing 32 34 33 35 IMPLICIT NONE … … 50 52 CONTAINS 51 53 52 SUBROUTINE dom_msk 54 SUBROUTINE dom_msk( k_top, k_bot ) 53 55 !!--------------------------------------------------------------------- 54 56 !! *** ROUTINE dom_msk *** … … 57 59 !! zontal velocity points (u & v), vorticity points (f) points. 58 60 !! 59 !! ** Method : The ocean/land mask is computed from the basin bathy- 60 !! metry in level (mbathy) which is defined or read in dommba. 61 !! mbathy equals 0 over continental T-point 62 !! and the number of ocean level over the ocean. 63 !! 64 !! At a given position (ji,jj,jk) the ocean/land mask is given by: 65 !! t-point : 0. IF mbathy( ji ,jj) =< 0 66 !! 1. IF mbathy( ji ,jj) >= jk 67 !! u-point : 0. IF mbathy( ji ,jj) or mbathy(ji+1, jj ) =< 0 68 !! 1. IF mbathy( ji ,jj) and mbathy(ji+1, jj ) >= jk. 69 !! v-point : 0. IF mbathy( ji ,jj) or mbathy( ji ,jj+1) =< 0 70 !! 1. IF mbathy( ji ,jj) and mbathy( ji ,jj+1) >= jk. 71 !! f-point : 0. IF mbathy( ji ,jj) or mbathy( ji ,jj+1) 72 !! or mbathy(ji+1,jj) or mbathy(ji+1,jj+1) =< 0 73 !! 1. IF mbathy( ji ,jj) and mbathy( ji ,jj+1) 74 !! and mbathy(ji+1,jj) and mbathy(ji+1,jj+1) >= jk. 75 !! tmask_i : interior ocean mask at t-point, i.e. excluding duplicated 76 !! rows/lines due to cyclic or North Fold boundaries as well 77 !! as MPP halos. 78 !! 79 !! The lateral friction is set through the value of fmask along 80 !! the coast and topography. This value is defined by rn_shlat, a 81 !! namelist parameter: 61 !! ** Method : The ocean/land mask at t-point is deduced from ko_top 62 !! and ko_bot, the indices of the fist and last ocean t-levels which 63 !! are either defined in usrdef_zgr or read in zgr_read. 64 !! The velocity masks (umask, vmask, wmask, wumask, wvmask) 65 !! are deduced from a product of the two neighboring tmask. 66 !! The vorticity mask (fmask) is deduced from tmask taking 67 !! into account the choice of lateral boundary condition (rn_shlat) : 82 68 !! rn_shlat = 0, free slip (no shear along the coast) 83 69 !! rn_shlat = 2, no slip (specified zero velocity at the coast) … … 85 71 !! 2 < rn_shlat, strong slip | in the lateral boundary layer 86 72 !! 87 !! N.B. If nperio not equal to 0, the land/ocean mask arrays88 !! are defined with the proper value at lateral domain boundaries.89 !! 90 !! In case of open boundaries (lk_bdy=T):91 !! - tmask is set to 1 on the points to be computed bay the open92 !! boundaries routines.93 !! 94 !! ** Action : tmask : land/ocean mask at t-point(=0. or 1.)95 !! umask : land/ocean mask at u-point (=0. or 1.)96 !! vmask : land/ocean mask at v-point (=0. or 1.)97 !! fmask : land/ocean mask at f-point (=0. or 1.)98 !! =rn_shlat along lateral boundaries99 !! tmask_i : interiorocean mask73 !! tmask_i : interior ocean mask at t-point, i.e. excluding duplicated 74 !! rows/lines due to cyclic or North Fold boundaries as well 75 !! as MPP halos. 76 !! tmask_h : halo mask at t-point, i.e. excluding duplicated rows/lines 77 !! due to cyclic or North Fold boundaries as well as MPP halos. 78 !! 79 !! ** Action : tmask, umask, vmask, wmask, wumask, wvmask : land/ocean mask 80 !! at t-, u-, v- w, wu-, and wv-points (=0. or 1.) 81 !! fmask : land/ocean mask at f-point (=0., or =1., or 82 !! =rn_shlat along lateral boundaries) 83 !! tmask_i : interior ocean mask 84 !! tmask_h : halo mask 85 !! ssmask , ssumask, ssvmask, ssfmask : 2D ocean mask 100 86 !!---------------------------------------------------------------------- 101 INTEGER :: ji, jj, jk ! dummy loop indices 102 INTEGER :: iif, iil, ii0, ii1, ii ! local integers 103 INTEGER :: ijf, ijl, ij0, ij1 ! - - 104 INTEGER :: ios 105 INTEGER :: isrow ! index for ORCA1 starting row 106 INTEGER , POINTER, DIMENSION(:,:) :: imsk 107 REAL(wp), POINTER, DIMENSION(:,:) :: zwf 87 INTEGER, DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! first and last ocean level 88 ! 89 INTEGER :: ji, jj, jk ! dummy loop indices 90 INTEGER :: iif, iil ! local integers 91 INTEGER :: ijf, ijl ! - - 92 INTEGER :: iktop, ikbot ! - - 93 INTEGER :: ios, inum 94 REAL(wp), POINTER, DIMENSION(:,:) :: zwf ! 2D workspace 108 95 !! 109 96 NAMELIST/namlbc/ rn_shlat, ln_vorlat 97 NAMELIST/nambdy/ ln_bdy ,nb_bdy, ln_coords_file, cn_coords_file, & 98 & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & 99 & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & 100 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 101 & cn_ice_lim, nn_ice_lim_dta, & 102 & rn_ice_tem, rn_ice_sal, rn_ice_age, & 103 & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy 110 104 !!--------------------------------------------------------------------- 111 105 ! 112 106 IF( nn_timing == 1 ) CALL timing_start('dom_msk') 113 !114 CALL wrk_alloc( jpi, jpj, imsk )115 CALL wrk_alloc( jpi, jpj, zwf )116 107 ! 117 108 REWIND( numnam_ref ) ! Namelist namlbc in reference namelist : Lateral momentum boundary condition … … 142 133 ENDIF 143 134 144 ! 1. Ocean/land mask at t-point (computed from mbathy) 145 ! -----------------------------146 ! N.B. tmask has already the right boundary conditions since mbathy is ok135 136 ! Ocean/land mask at t-point (computed from ko_top and ko_bot) 137 ! ---------------------------- 147 138 ! 148 139 tmask(:,:,:) = 0._wp 149 DO jk = 1, jpk 150 DO jj = 1, jpj 151 DO ji = 1, jpi 152 IF( REAL( mbathy(ji,jj) - jk, wp ) + 0.1_wp >= 0._wp ) tmask(ji,jj,jk) = 1._wp 153 END DO 140 DO jj = 1, jpj 141 DO ji = 1, jpi 142 iktop = k_top(ji,jj) 143 ikbot = k_bot(ji,jj) 144 IF( iktop /= 0 ) THEN ! water in the column 145 tmask(ji,jj,iktop:ikbot ) = 1._wp 146 ENDIF 154 147 END DO 155 148 END DO 156 157 ! (ISF) define barotropic mask and mask the ice shelf point 158 ssmask(:,:)=tmask(:,:,1) ! at this stage ice shelf is not masked 159 160 DO jk = 1, jpk 161 DO jj = 1, jpj 162 DO ji = 1, jpi 163 IF( REAL( misfdep(ji,jj) - jk, wp ) - 0.1_wp >= 0._wp ) THEN 164 tmask(ji,jj,jk) = 0._wp 165 END IF 166 END DO 167 END DO 168 END DO 169 170 ! Interior domain mask (used for global sum) 171 ! -------------------- 172 tmask_i(:,:) = ssmask(:,:) ! (ISH) tmask_i = 1 even on the ice shelf 173 174 tmask_h(:,:) = 1._wp ! 0 on the halo and 1 elsewhere 175 iif = jpreci ! ??? 176 iil = nlci - jpreci + 1 177 ijf = jprecj ! ??? 178 ijl = nlcj - jprecj + 1 179 180 tmask_h( 1 :iif, : ) = 0._wp ! first columns 181 tmask_h(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns) 182 tmask_h( : , 1 :ijf) = 0._wp ! first rows 183 tmask_h( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows) 184 185 ! north fold mask 186 ! --------------- 187 tpol(1:jpiglo) = 1._wp 188 fpol(1:jpiglo) = 1._wp 189 IF( jperio == 3 .OR. jperio == 4 ) THEN ! T-point pivot 190 tpol(jpiglo/2+1:jpiglo) = 0._wp 191 fpol( 1 :jpiglo) = 0._wp 192 IF( mjg(nlej) == jpjglo ) THEN ! only half of the nlcj-1 row 193 DO ji = iif+1, iil-1 194 tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji)) 195 END DO 196 ENDIF 197 ENDIF 198 199 tmask_i(:,:) = tmask_i(:,:) * tmask_h(:,:) 200 201 IF( jperio == 5 .OR. jperio == 6 ) THEN ! F-point pivot 202 tpol( 1 :jpiglo) = 0._wp 203 fpol(jpiglo/2+1:jpiglo) = 0._wp 204 ENDIF 205 206 ! 2. Ocean/land mask at u-, v-, and z-points (computed from tmask) 207 ! ------------------------------------------- 149 !SF add here lbc_lnk: bug not still understood : cause now domain configuration is read ! 150 !!gm I don't understand why... 151 CALL lbc_lnk( tmask , 'T', 1._wp ) ! Lateral boundary conditions 152 153 ! Mask corrections for bdy (read in mppini2) 154 REWIND( numnam_ref ) ! Namelist nambdy in reference namelist :Unstructured open boundaries 155 READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) 156 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist', lwp ) 157 158 REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist :Unstructured open boundaries 159 READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) 160 904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist', lwp ) 161 ! ------------------------ 162 IF ( ln_bdy .AND. ln_mask_file ) THEN 163 DO jk = 1, jpkm1 164 DO jj = 1, jpj 165 DO ji = 1, jpi 166 tmask(ji,jj,jk) = tmask(ji,jj,jk) * bdytmask(ji,jj) 167 END DO 168 END DO 169 END DO 170 ENDIF 171 172 ! Ocean/land mask at u-, v-, and f-points (computed from tmask) 173 ! ---------------------------------------- 174 ! NB: at this point, fmask is designed for free slip lateral boundary condition 208 175 DO jk = 1, jpk 209 176 DO jj = 1, jpjm1 … … 218 185 END DO 219 186 END DO 220 ! (ISF) MIN(1,SUM(umask)) is here to check if you have effectively at least 1 wet cell at u point221 DO jj = 1, jpjm1222 DO ji = 1, fs_jpim1 ! vector loop223 ssumask(ji,jj) = ssmask(ji,jj) * ssmask(ji+1,jj ) * MIN(1._wp,SUM(umask(ji,jj,:)))224 ssvmask(ji,jj) = ssmask(ji,jj) * ssmask(ji ,jj+1) * MIN(1._wp,SUM(vmask(ji,jj,:)))225 END DO226 DO ji = 1, jpim1 ! NO vector opt.227 ssfmask(ji,jj) = ssmask(ji,jj ) * ssmask(ji+1,jj ) &228 & * ssmask(ji,jj+1) * ssmask(ji+1,jj+1) * MIN(1._wp,SUM(fmask(ji,jj,:)))229 END DO230 END DO231 187 CALL lbc_lnk( umask , 'U', 1._wp ) ! Lateral boundary conditions 232 188 CALL lbc_lnk( vmask , 'V', 1._wp ) 233 189 CALL lbc_lnk( fmask , 'F', 1._wp ) 234 CALL lbc_lnk( ssumask, 'U', 1._wp ) ! Lateral boundary conditions 235 CALL lbc_lnk( ssvmask, 'V', 1._wp ) 236 CALL lbc_lnk( ssfmask, 'F', 1._wp ) 237 238 ! 3. Ocean/land mask at wu-, wv- and w points 239 !---------------------------------------------- 190 191 192 ! Ocean/land mask at wu-, wv- and w points (computed from tmask) 193 !----------------------------------------- 240 194 wmask (:,:,1) = tmask(:,:,1) ! surface 241 195 wumask(:,:,1) = umask(:,:,1) … … 247 201 END DO 248 202 203 204 ! Ocean/land column mask at t-, u-, and v-points (i.e. at least 1 wet cell in the vertical) 205 ! ---------------------------------------------- 206 ssmask (:,:) = MAXVAL( tmask(:,:,:), DIM=3 ) 207 ssumask(:,:) = MAXVAL( umask(:,:,:), DIM=3 ) 208 ssvmask(:,:) = MAXVAL( vmask(:,:,:), DIM=3 ) 209 210 211 ! Interior domain mask (used for global sum) 212 ! -------------------- 213 ! 214 iif = jpreci ; iil = nlci - jpreci + 1 215 ijf = jprecj ; ijl = nlcj - jprecj + 1 216 ! 217 ! ! halo mask : 0 on the halo and 1 elsewhere 218 tmask_h(:,:) = 1._wp 219 tmask_h( 1 :iif, : ) = 0._wp ! first columns 220 tmask_h(iil:jpi, : ) = 0._wp ! last columns (including mpp extra columns) 221 tmask_h( : , 1 :ijf) = 0._wp ! first rows 222 tmask_h( : ,ijl:jpj) = 0._wp ! last rows (including mpp extra rows) 223 ! 224 ! ! north fold mask 225 tpol(1:jpiglo) = 1._wp 226 fpol(1:jpiglo) = 1._wp 227 IF( jperio == 3 .OR. jperio == 4 ) THEN ! T-point pivot 228 tpol(jpiglo/2+1:jpiglo) = 0._wp 229 fpol( 1 :jpiglo) = 0._wp 230 IF( mjg(nlej) == jpjglo ) THEN ! only half of the nlcj-1 row for tmask_h 231 DO ji = iif+1, iil-1 232 tmask_h(ji,nlej-1) = tmask_h(ji,nlej-1) * tpol(mig(ji)) 233 END DO 234 ENDIF 235 ENDIF 236 ! 237 IF( jperio == 5 .OR. jperio == 6 ) THEN ! F-point pivot 238 tpol( 1 :jpiglo) = 0._wp 239 fpol(jpiglo/2+1:jpiglo) = 0._wp 240 ENDIF 241 ! 242 ! ! interior mask : 2D ocean mask x halo mask 243 tmask_i(:,:) = ssmask(:,:) * tmask_h(:,:) 244 245 249 246 ! Lateral boundary conditions on velocity (modify fmask) 250 ! --------------------------------------- 251 DO jk = 1, jpk 252 zwf(:,:) = fmask(:,:,jk) 253 DO jj = 2, jpjm1 254 DO ji = fs_2, fs_jpim1 ! vector opt. 255 IF( fmask(ji,jj,jk) == 0._wp ) THEN 256 fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), & 257 & zwf(ji-1,jj), zwf(ji,jj-1) ) ) 247 ! --------------------------------------- 248 IF( rn_shlat /= 0 ) THEN ! Not free-slip lateral boundary condition 249 ! 250 CALL wrk_alloc( jpi,jpj, zwf ) 251 ! 252 DO jk = 1, jpk 253 zwf(:,:) = fmask(:,:,jk) 254 DO jj = 2, jpjm1 255 DO ji = fs_2, fs_jpim1 ! vector opt. 256 IF( fmask(ji,jj,jk) == 0._wp ) THEN 257 fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), & 258 & zwf(ji-1,jj), zwf(ji,jj-1) ) ) 259 ENDIF 260 END DO 261 END DO 262 DO jj = 2, jpjm1 263 IF( fmask(1,jj,jk) == 0._wp ) THEN 264 fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) ) 265 ENDIF 266 IF( fmask(jpi,jj,jk) == 0._wp ) THEN 267 fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) ) 268 ENDIF 269 END DO 270 DO ji = 2, jpim1 271 IF( fmask(ji,1,jk) == 0._wp ) THEN 272 fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) ) 273 ENDIF 274 IF( fmask(ji,jpj,jk) == 0._wp ) THEN 275 fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) ) 258 276 ENDIF 259 277 END DO 260 278 END DO 261 DO jj = 2, jpjm1 262 IF( fmask(1,jj,jk) == 0._wp ) THEN 263 fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) ) 264 ENDIF 265 IF( fmask(jpi,jj,jk) == 0._wp ) THEN 266 fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) ) 267 ENDIF 268 END DO 269 DO ji = 2, jpim1 270 IF( fmask(ji,1,jk) == 0._wp ) THEN 271 fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) ) 272 ENDIF 273 IF( fmask(ji,jpj,jk) == 0._wp ) THEN 274 fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) ) 275 ENDIF 276 END DO 277 END DO 278 ! 279 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA_R2 configuration 280 ! ! Increased lateral friction near of some straits 281 ! ! Gibraltar strait : partial slip (fmask=0.5) 282 ij0 = 101 ; ij1 = 101 283 ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 284 ij0 = 102 ; ij1 = 102 285 ii0 = 139 ; ii1 = 140 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp 286 ! 287 ! ! Bab el Mandeb : partial slip (fmask=1) 288 ij0 = 87 ; ij1 = 88 289 ii0 = 160 ; ii1 = 160 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 290 ij0 = 88 ; ij1 = 88 291 ii0 = 159 ; ii1 = 159 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp 292 ! 293 ! ! Danish straits : strong slip (fmask > 2) 294 ! We keep this as an example but it is instable in this case 295 ! ij0 = 115 ; ij1 = 115 296 ! ii0 = 145 ; ii1 = 146 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp 297 ! ij0 = 116 ; ij1 = 116 298 ! ii0 = 145 ; ii1 = 146 ; fmask( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 4._wp 299 ! 300 ENDIF 301 ! 302 IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN ! ORCA R1 configuration 303 ! ! Increased lateral friction near of some straits 304 ! This dirty section will be suppressed by simplification process: 305 ! all this will come back in input files 306 ! Currently these hard-wired indices relate to configuration with 307 ! extend grid (jpjglo=332) 308 ! 309 isrow = 332 - jpjglo 310 ! 311 IF(lwp) WRITE(numout,*) 312 IF(lwp) WRITE(numout,*) ' orca_r1: increase friction near the following straits : ' 313 IF(lwp) WRITE(numout,*) ' Gibraltar ' 314 ii0 = 282 ; ii1 = 283 ! Gibraltar Strait 315 ij0 = 241 - isrow ; ij1 = 241 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 316 317 IF(lwp) WRITE(numout,*) ' Bhosporus ' 318 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait 319 ij0 = 248 - isrow ; ij1 = 248 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 320 321 IF(lwp) WRITE(numout,*) ' Makassar (Top) ' 322 ii0 = 48 ; ii1 = 48 ! Makassar Strait (Top) 323 ij0 = 189 - isrow ; ij1 = 190 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 324 325 IF(lwp) WRITE(numout,*) ' Lombok ' 326 ii0 = 44 ; ii1 = 44 ! Lombok Strait 327 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 328 329 IF(lwp) WRITE(numout,*) ' Ombai ' 330 ii0 = 53 ; ii1 = 53 ! Ombai Strait 331 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 332 333 IF(lwp) WRITE(numout,*) ' Timor Passage ' 334 ii0 = 56 ; ii1 = 56 ! Timor Passage 335 ij0 = 164 - isrow ; ij1 = 165 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp 336 337 IF(lwp) WRITE(numout,*) ' West Halmahera ' 338 ii0 = 58 ; ii1 = 58 ! West Halmahera Strait 339 ij0 = 181 - isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 340 341 IF(lwp) WRITE(numout,*) ' East Halmahera ' 342 ii0 = 55 ; ii1 = 55 ! East Halmahera Strait 343 ij0 = 181 - isrow ; ij1 = 182 - isrow ; fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp 344 ! 345 ENDIF 346 ! 347 CALL lbc_lnk( fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask 348 ! 349 ! CAUTION : The fmask may be further modified in dyn_vor_init ( dynvor.F90 ) 350 ! 351 CALL wrk_dealloc( jpi, jpj, imsk ) 352 CALL wrk_dealloc( jpi, jpj, zwf ) 279 ! 280 CALL wrk_dealloc( jpi,jpj, zwf ) 281 ! 282 CALL lbc_lnk( fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask 283 ! 284 ! CAUTION : The fmask may be further modified in dyn_vor_init ( dynvor.F90 ) depending on ln_vorlat 285 ! 286 ENDIF 287 288 ! User defined alteration of fmask (use to reduce ocean transport in specified straits) 289 ! -------------------------------- 290 ! 291 CALL usr_def_fmask( cn_cfg, nn_cfg, fmask ) 292 ! 353 293 ! 354 294 IF( nn_timing == 1 ) CALL timing_stop('dom_msk') -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/domngb.F90
r6140 r7646 62 62 END SELECT 63 63 64 IF (jphgr_msh /= 2 .AND. jphgr_msh /= 3) THEN 65 zlon = MOD( plon + 720., 360. ) ! plon between 0 and 360 66 zglam(:,:) = MOD( zglam(:,:) + 720., 360. ) ! glam between 0 and 360 67 IF( zlon > 270. ) zlon = zlon - 360. ! zlon between -90 and 270 68 IF( zlon < 90. ) WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360. ! glam between -180 and 180 69 zglam(:,:) = zglam(:,:) - zlon 70 ELSE 71 zglam(:,:) = zglam(:,:) - plon 72 END IF 64 zlon = MOD( plon + 720., 360. ) ! plon between 0 and 360 65 zglam(:,:) = MOD( zglam(:,:) + 720., 360. ) ! glam between 0 and 360 66 IF( zlon > 270. ) zlon = zlon - 360. ! zlon between -90 and 270 67 IF( zlon < 90. ) WHERE( zglam(:,:) > 180. ) zglam(:,:) = zglam(:,:) - 360. ! glam between -180 and 180 68 zglam(:,:) = zglam(:,:) - zlon 73 69 74 70 zgphi(:,:) = zgphi(:,:) - plat -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r6351 r7646 24 24 USE sbc_oce ! ocean surface boundary condition 25 25 USE wet_dry ! wetting and drying 26 USE usrdef_istate ! user defined initial state (wad only) 26 27 USE restart ! ocean restart 27 28 ! … … 232 233 END DO 233 234 END DO 234 IF( c p_cfg == "orca" .AND. jp_cfg == 3 ) THEN ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2235 IF( cn_cfg == "orca" .AND. nn_cfg == 3 ) THEN ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 235 236 ii0 = 103 ; ii1 = 111 236 237 ij0 = 128 ; ij1 = 135 ; … … 874 875 ! 875 876 ELSE !* Initialize at "rest" 876 e3t_b(:,:,:) = e3t_0(:,:,:) 877 e3t_n(:,:,:) = e3t_0(:,:,:) 878 sshn(:,:) = 0.0_wp 879 880 IF( ln_wd ) THEN 877 ! 878 IF( ln_wd .AND. ( cn_cfg == 'wad' ) ) THEN 879 ! Wetting and drying test case 880 CALL usr_def_istate( gdept_b, tmask, tsb, ub, vb, sshb ) 881 tsn (:,:,:,:) = tsb (:,:,:,:) ! set now values from to before ones 882 sshn (:,:) = sshb(:,:) 883 un (:,:,:) = ub (:,:,:) 884 vn (:,:,:) = vb (:,:,:) 885 ! uniform T-S fields and initial ssh slope 886 ! needs to be called here and in istate which is called later. 887 ! Adjust vertical metrics 888 DO jk = 1, jpk 889 e3t_n(:,:,jk) = e3t_0(:,:,jk) * ( ht_0(:,:) + sshn(:,:) ) & 890 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 891 & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk)) 892 END DO 893 e3t_b(:,:,:) = e3t_n(:,:,:) 894 ! 895 ELSEIF( ln_wd ) THEN 896 ! 881 897 DO jj = 1, jpj 882 898 DO ji = 1, jpi 883 899 IF( e3t_0(ji,jj,1) <= 0.5_wp * rn_wdmin1 ) THEN 884 e3t_b(ji,jj,:) = 0.5_wp * rn_wdmin1 885 e3t_n(ji,jj,:) = 0.5_wp * rn_wdmin1 886 e3t_a(ji,jj,:) = 0.5_wp * rn_wdmin1 887 sshb(ji,jj) = rn_wdmin1 - bathy(ji,jj) 888 sshn(ji,jj) = rn_wdmin1 - bathy(ji,jj) 889 ssha(ji,jj) = rn_wdmin1 - bathy(ji,jj) 900 ! potential bug 901 ! Warning this assumes 2 layers only over wetting locations. needs investigating 902 e3t_b(ji,jj,:) = 0.5_wp * rn_wdmin1 903 e3t_n(ji,jj,:) = 0.5_wp * rn_wdmin1 904 e3t_a(ji,jj,:) = 0.5_wp * rn_wdmin1 905 sshb(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) !!gm I don't understand that ! 906 sshn(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) 907 ssha(ji,jj) = rn_wdmin1 - ht_wd(ji,jj) 890 908 ENDIF 891 909 ENDDO 892 910 ENDDO 911 ! 912 ELSE 913 ! 914 e3t_b(:,:,:) = e3t_0(:,:,:) 915 e3t_n(:,:,:) = e3t_0(:,:,:) 916 sshn(:,:) = 0.0_wp 917 ! 893 918 END IF 894 919 895 920 IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN 896 tilde_e3t_b(:,:,:) = 0. 0_wp897 tilde_e3t_n(:,:,:) = 0. 0_wp898 IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0. 0_wp921 tilde_e3t_b(:,:,:) = 0._wp 922 tilde_e3t_n(:,:,:) = 0._wp 923 IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0._wp 899 924 END IF 900 925 ENDIF -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90
r6689 r7646 8 8 !! NEMO 1.0 ! 2002-08 (G. Madec) F90 and several file 9 9 !! 3.0 ! 2008-01 (S. Masson) add dom_uniq 10 !! 4.0 ! 2016-01 (G. Madec) simplified mesh_mask.nc file 10 11 !!---------------------------------------------------------------------- 11 12 … … 13 14 !! dom_wri : create and write mesh and mask file(s) 14 15 !! dom_uniq : identify unique point of a grid (TUVF) 16 !! dom_stiff : diagnose maximum grid stiffness/hydrostatic consistency (s-coordinate) 15 17 !!---------------------------------------------------------------------- 16 18 USE dom_oce ! ocean space and time domain 19 USE phycst , ONLY : rsmall 20 USE wet_dry, ONLY : ln_wd, ht_wd 21 ! 17 22 USE in_out_manager ! I/O manager 18 23 USE iom ! I/O library … … 26 31 27 32 PUBLIC dom_wri ! routine called by inidom.F90 28 PUBLIC dom_wri_coordinate ! routine called by domhgr.F90 33 PUBLIC dom_stiff ! routine called by inidom.F90 34 29 35 !! * Substitutions 30 36 # include "vectopt_loop_substitute.h90" 31 37 !!---------------------------------------------------------------------- 32 !! NEMO/OPA 3.3 , NEMO Consortium (2010)38 !! NEMO/OPA 4.0 , NEMO Consortium (2016) 33 39 !! $Id$ 34 40 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 35 41 !!---------------------------------------------------------------------- 36 42 CONTAINS 37 38 SUBROUTINE dom_wri_coordinate39 !!----------------------------------------------------------------------40 !! *** ROUTINE dom_wri_coordinate ***41 !!42 !! ** Purpose : Create the NetCDF file which contains all the43 !! standard coordinate information plus the surface,44 !! e1e2u and e1e2v. By doing so, those surface will45 !! not be changed by the reduction of e1u or e2v scale46 !! factors in some straits.47 !! NB: call just after the read of standard coordinate48 !! and the reduction of scale factors in some straits49 !!50 !! ** output file : coordinate_e1e2u_v.nc51 !!----------------------------------------------------------------------52 INTEGER :: inum0 ! temprary units for 'coordinate_e1e2u_v.nc' file53 CHARACTER(len=21) :: clnam0 ! filename (mesh and mask informations)54 ! ! workspaces55 REAL(wp), POINTER, DIMENSION(:,: ) :: zprt, zprw56 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv57 !!----------------------------------------------------------------------58 !59 IF( nn_timing == 1 ) CALL timing_start('dom_wri_coordinate')60 !61 IF(lwp) WRITE(numout,*)62 IF(lwp) WRITE(numout,*) 'dom_wri_coordinate : create NetCDF coordinate file'63 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~~'64 65 clnam0 = 'coordinate_e1e2u_v' ! filename (mesh and mask informations)66 67 ! create 'coordinate_e1e2u_v.nc' file68 ! ============================69 !70 CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib )71 !72 ! ! horizontal mesh (inum3)73 CALL iom_rstput( 0, 0, inum0, 'glamt', glamt, ktype = jp_r8 ) ! ! latitude74 CALL iom_rstput( 0, 0, inum0, 'glamu', glamu, ktype = jp_r8 )75 CALL iom_rstput( 0, 0, inum0, 'glamv', glamv, ktype = jp_r8 )76 CALL iom_rstput( 0, 0, inum0, 'glamf', glamf, ktype = jp_r8 )77 78 CALL iom_rstput( 0, 0, inum0, 'gphit', gphit, ktype = jp_r8 ) ! ! longitude79 CALL iom_rstput( 0, 0, inum0, 'gphiu', gphiu, ktype = jp_r8 )80 CALL iom_rstput( 0, 0, inum0, 'gphiv', gphiv, ktype = jp_r8 )81 CALL iom_rstput( 0, 0, inum0, 'gphif', gphif, ktype = jp_r8 )82 83 CALL iom_rstput( 0, 0, inum0, 'e1t', e1t, ktype = jp_r8 ) ! ! e1 scale factors84 CALL iom_rstput( 0, 0, inum0, 'e1u', e1u, ktype = jp_r8 )85 CALL iom_rstput( 0, 0, inum0, 'e1v', e1v, ktype = jp_r8 )86 CALL iom_rstput( 0, 0, inum0, 'e1f', e1f, ktype = jp_r8 )87 88 CALL iom_rstput( 0, 0, inum0, 'e2t', e2t, ktype = jp_r8 ) ! ! e2 scale factors89 CALL iom_rstput( 0, 0, inum0, 'e2u', e2u, ktype = jp_r8 )90 CALL iom_rstput( 0, 0, inum0, 'e2v', e2v, ktype = jp_r8 )91 CALL iom_rstput( 0, 0, inum0, 'e2f', e2f, ktype = jp_r8 )92 93 CALL iom_rstput( 0, 0, inum0, 'e1e2u', e1e2u, ktype = jp_r8 )94 CALL iom_rstput( 0, 0, inum0, 'e1e2v', e1e2v, ktype = jp_r8 )95 96 CALL iom_close( inum0 )97 !98 IF( nn_timing == 1 ) CALL timing_stop('dom_wri_coordinate')99 !100 END SUBROUTINE dom_wri_coordinate101 102 43 103 44 SUBROUTINE dom_wri … … 113 54 !! domhgr, domzgr, and dommsk. Note: the file contain depends on 114 55 !! the vertical coord. used (z-coord, partial steps, s-coord) 115 !! MOD(n msh, 3) = 1 : 'mesh_mask.nc' file56 !! MOD(nn_msh, 3) = 1 : 'mesh_mask.nc' file 116 57 !! = 2 : 'mesh.nc' and mask.nc' files 117 58 !! = 0 : 'mesh_hgr.nc', 'mesh_zgr.nc' and … … 120 61 !! vertical coordinate. 121 62 !! 122 !! if n msh <= 3: write full 3D arrays for e3[tuvw] and gdep[tuvw]123 !! if 3 < n msh <= 6: write full 3D arrays for e3[tuvw] and 2D arrays63 !! if nn_msh <= 3: write full 3D arrays for e3[tuvw] and gdep[tuvw] 64 !! if 3 < nn_msh <= 6: write full 3D arrays for e3[tuvw] and 2D arrays 124 65 !! corresponding to the depth of the bottom t- and w-points 125 !! if 6 < n msh <= 9: write 2D arrays corresponding to the depth and the66 !! if 6 < nn_msh <= 9: write 2D arrays corresponding to the depth and the 126 67 !! thickness (e3[tw]_ps) of the bottom points 127 68 !! … … 129 70 !! masks, depth and vertical scale factors 130 71 !!---------------------------------------------------------------------- 131 !! 132 INTEGER :: inum0 ! temprary units for 'mesh_mask.nc' file 133 INTEGER :: inum1 ! temprary units for 'mesh.nc' file 134 INTEGER :: inum2 ! temprary units for 'mask.nc' file 135 INTEGER :: inum3 ! temprary units for 'mesh_hgr.nc' file 136 INTEGER :: inum4 ! temprary units for 'mesh_zgr.nc' file 137 CHARACTER(len=21) :: clnam0 ! filename (mesh and mask informations) 138 CHARACTER(len=21) :: clnam1 ! filename (mesh informations) 139 CHARACTER(len=21) :: clnam2 ! filename (mask informations) 140 CHARACTER(len=21) :: clnam3 ! filename (horizontal mesh informations) 141 CHARACTER(len=21) :: clnam4 ! filename (vertical mesh informations) 72 INTEGER :: inum ! temprary units for 'mesh_mask.nc' file 73 CHARACTER(len=21) :: clnam ! filename (mesh and mask informations) 142 74 INTEGER :: ji, jj, jk ! dummy loop indices 143 ! ! workspaces 144 REAL(wp), POINTER, DIMENSION(:,: ) :: zprt, zprw 145 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv 75 INTEGER :: izco, izps, isco, icav 76 ! 77 REAL(wp), POINTER, DIMENSION(:,:) :: zprt, zprw ! 2D workspace 78 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdepu, zdepv ! 3D workspace 146 79 !!---------------------------------------------------------------------- 147 80 ! 148 81 IF( nn_timing == 1 ) CALL timing_start('dom_wri') 149 82 ! 150 CALL wrk_alloc( jpi, jpj, zprt, zprw)151 CALL wrk_alloc( jpi, jpj, jpk,zdepu, zdepv )83 CALL wrk_alloc( jpi,jpj, zprt , zprw ) 84 CALL wrk_alloc( jpi,jpj,jpk, zdepu, zdepv ) 152 85 ! 153 86 IF(lwp) WRITE(numout,*) … … 155 88 IF(lwp) WRITE(numout,*) '~~~~~~~' 156 89 157 clnam0 = 'mesh_mask' ! filename (mesh and mask informations) 158 clnam1 = 'mesh' ! filename (mesh informations) 159 clnam2 = 'mask' ! filename (mask informations) 160 clnam3 = 'mesh_hgr' ! filename (horizontal mesh informations) 161 clnam4 = 'mesh_zgr' ! filename (vertical mesh informations) 162 163 SELECT CASE ( MOD(nmsh, 3) ) 164 ! ! ============================ 165 CASE ( 1 ) ! create 'mesh_mask.nc' file 166 ! ! ============================ 167 CALL iom_open( TRIM(clnam0), inum0, ldwrt = .TRUE., kiolib = jprstlib ) 168 inum2 = inum0 ! put all the informations 169 inum3 = inum0 ! in unit inum0 170 inum4 = inum0 171 172 ! ! ============================ 173 CASE ( 2 ) ! create 'mesh.nc' and 174 ! ! 'mask.nc' files 175 ! ! ============================ 176 CALL iom_open( TRIM(clnam1), inum1, ldwrt = .TRUE., kiolib = jprstlib ) 177 CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib ) 178 inum3 = inum1 ! put mesh informations 179 inum4 = inum1 ! in unit inum1 180 ! ! ============================ 181 CASE ( 0 ) ! create 'mesh_hgr.nc' 182 ! ! 'mesh_zgr.nc' and 183 ! ! 'mask.nc' files 184 ! ! ============================ 185 CALL iom_open( TRIM(clnam2), inum2, ldwrt = .TRUE., kiolib = jprstlib ) 186 CALL iom_open( TRIM(clnam3), inum3, ldwrt = .TRUE., kiolib = jprstlib ) 187 CALL iom_open( TRIM(clnam4), inum4, ldwrt = .TRUE., kiolib = jprstlib ) 188 ! 189 END SELECT 190 191 ! ! masks (inum2) 192 CALL iom_rstput( 0, 0, inum2, 'tmask', tmask, ktype = jp_i1 ) ! ! land-sea mask 193 CALL iom_rstput( 0, 0, inum2, 'umask', umask, ktype = jp_i1 ) 194 CALL iom_rstput( 0, 0, inum2, 'vmask', vmask, ktype = jp_i1 ) 195 CALL iom_rstput( 0, 0, inum2, 'fmask', fmask, ktype = jp_i1 ) 90 clnam = 'mesh_mask' ! filename (mesh and mask informations) 91 92 ! ! ============================ 93 ! ! create 'mesh_mask.nc' file 94 ! ! ============================ 95 CALL iom_open( TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib ) 96 ! 97 ! ! global domain size 98 CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 ) 99 CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 ) 100 CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpkglo, wp), ktype = jp_i4 ) 101 102 ! ! domain characteristics 103 CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 ) 104 ! ! type of vertical coordinate 105 IF( ln_zco ) THEN ; izco = 1 ; ELSE ; izco = 0 ; ENDIF 106 IF( ln_zps ) THEN ; izps = 1 ; ELSE ; izps = 0 ; ENDIF 107 IF( ln_sco ) THEN ; isco = 1 ; ELSE ; isco = 0 ; ENDIF 108 CALL iom_rstput( 0, 0, inum, 'ln_zco' , REAL( izco, wp), ktype = jp_i4 ) 109 CALL iom_rstput( 0, 0, inum, 'ln_zps' , REAL( izps, wp), ktype = jp_i4 ) 110 CALL iom_rstput( 0, 0, inum, 'ln_sco' , REAL( isco, wp), ktype = jp_i4 ) 111 ! ! ocean cavities under iceshelves 112 IF( ln_isfcav ) THEN ; icav = 1 ; ELSE ; icav = 0 ; ENDIF 113 CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 ) 114 115 ! ! masks 116 CALL iom_rstput( 0, 0, inum, 'tmask', tmask, ktype = jp_i1 ) ! ! land-sea mask 117 CALL iom_rstput( 0, 0, inum, 'umask', umask, ktype = jp_i1 ) 118 CALL iom_rstput( 0, 0, inum, 'vmask', vmask, ktype = jp_i1 ) 119 CALL iom_rstput( 0, 0, inum, 'fmask', fmask, ktype = jp_i1 ) 196 120 197 121 CALL dom_uniq( zprw, 'T' ) 198 122 DO jj = 1, jpj 199 123 DO ji = 1, jpi 200 jk=mikt(ji,jj) 201 zprt(ji,jj) = tmask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask 124 zprt(ji,jj) = ssmask(ji,jj) * zprw(ji,jj) ! ! unique point mask 202 125 END DO 203 126 END DO ! ! unique point mask 204 CALL iom_rstput( 0, 0, inum 2, 'tmaskutil', zprt, ktype = jp_i1 )127 CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 ) 205 128 CALL dom_uniq( zprw, 'U' ) 206 129 DO jj = 1, jpj 207 130 DO ji = 1, jpi 208 jk=miku(ji,jj) 209 zprt(ji,jj) = umask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask 131 zprt(ji,jj) = ssumask(ji,jj) * zprw(ji,jj) ! ! unique point mask 210 132 END DO 211 133 END DO 212 CALL iom_rstput( 0, 0, inum 2, 'umaskutil', zprt, ktype = jp_i1 )134 CALL iom_rstput( 0, 0, inum, 'umaskutil', zprt, ktype = jp_i1 ) 213 135 CALL dom_uniq( zprw, 'V' ) 214 136 DO jj = 1, jpj 215 137 DO ji = 1, jpi 216 jk=mikv(ji,jj) 217 zprt(ji,jj) = vmask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask 138 zprt(ji,jj) = ssvmask(ji,jj) * zprw(ji,jj) ! ! unique point mask 218 139 END DO 219 140 END DO 220 CALL iom_rstput( 0, 0, inum2, 'vmaskutil', zprt, ktype = jp_i1 ) 221 CALL dom_uniq( zprw, 'F' ) 222 DO jj = 1, jpj 223 DO ji = 1, jpi 224 jk=mikf(ji,jj) 225 zprt(ji,jj) = fmask(ji,jj,jk) * zprw(ji,jj) ! ! unique point mask 226 END DO 227 END DO 228 CALL iom_rstput( 0, 0, inum2, 'fmaskutil', zprt, ktype = jp_i1 ) 141 CALL iom_rstput( 0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1 ) 142 !!gm ssfmask has been removed ==>> find another solution to defined fmaskutil 143 !! Here we just remove the output of fmaskutil. 144 ! CALL dom_uniq( zprw, 'F' ) 145 ! DO jj = 1, jpj 146 ! DO ji = 1, jpi 147 ! zprt(ji,jj) = ssfmask(ji,jj) * zprw(ji,jj) ! ! unique point mask 148 ! END DO 149 ! END DO 150 ! CALL iom_rstput( 0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1 ) 151 !!gm 229 152 230 153 ! ! horizontal mesh (inum3) 231 CALL iom_rstput( 0, 0, inum3, 'glamt', glamt, ktype = jp_r8 ) ! ! latitude 232 CALL iom_rstput( 0, 0, inum3, 'glamu', glamu, ktype = jp_r8 ) 233 CALL iom_rstput( 0, 0, inum3, 'glamv', glamv, ktype = jp_r8 ) 234 CALL iom_rstput( 0, 0, inum3, 'glamf', glamf, ktype = jp_r8 ) 235 236 CALL iom_rstput( 0, 0, inum3, 'gphit', gphit, ktype = jp_r8 ) ! ! longitude 237 CALL iom_rstput( 0, 0, inum3, 'gphiu', gphiu, ktype = jp_r8 ) 238 CALL iom_rstput( 0, 0, inum3, 'gphiv', gphiv, ktype = jp_r8 ) 239 CALL iom_rstput( 0, 0, inum3, 'gphif', gphif, ktype = jp_r8 ) 240 241 CALL iom_rstput( 0, 0, inum3, 'e1t', e1t, ktype = jp_r8 ) ! ! e1 scale factors 242 CALL iom_rstput( 0, 0, inum3, 'e1u', e1u, ktype = jp_r8 ) 243 CALL iom_rstput( 0, 0, inum3, 'e1v', e1v, ktype = jp_r8 ) 244 CALL iom_rstput( 0, 0, inum3, 'e1f', e1f, ktype = jp_r8 ) 245 246 CALL iom_rstput( 0, 0, inum3, 'e2t', e2t, ktype = jp_r8 ) ! ! e2 scale factors 247 CALL iom_rstput( 0, 0, inum3, 'e2u', e2u, ktype = jp_r8 ) 248 CALL iom_rstput( 0, 0, inum3, 'e2v', e2v, ktype = jp_r8 ) 249 CALL iom_rstput( 0, 0, inum3, 'e2f', e2f, ktype = jp_r8 ) 250 251 CALL iom_rstput( 0, 0, inum3, 'ff', ff, ktype = jp_r8 ) ! ! coriolis factor 154 CALL iom_rstput( 0, 0, inum, 'glamt', glamt, ktype = jp_r8 ) ! ! latitude 155 CALL iom_rstput( 0, 0, inum, 'glamu', glamu, ktype = jp_r8 ) 156 CALL iom_rstput( 0, 0, inum, 'glamv', glamv, ktype = jp_r8 ) 157 CALL iom_rstput( 0, 0, inum, 'glamf', glamf, ktype = jp_r8 ) 158 159 CALL iom_rstput( 0, 0, inum, 'gphit', gphit, ktype = jp_r8 ) ! ! longitude 160 CALL iom_rstput( 0, 0, inum, 'gphiu', gphiu, ktype = jp_r8 ) 161 CALL iom_rstput( 0, 0, inum, 'gphiv', gphiv, ktype = jp_r8 ) 162 CALL iom_rstput( 0, 0, inum, 'gphif', gphif, ktype = jp_r8 ) 163 164 CALL iom_rstput( 0, 0, inum, 'e1t', e1t, ktype = jp_r8 ) ! ! e1 scale factors 165 CALL iom_rstput( 0, 0, inum, 'e1u', e1u, ktype = jp_r8 ) 166 CALL iom_rstput( 0, 0, inum, 'e1v', e1v, ktype = jp_r8 ) 167 CALL iom_rstput( 0, 0, inum, 'e1f', e1f, ktype = jp_r8 ) 168 169 CALL iom_rstput( 0, 0, inum, 'e2t', e2t, ktype = jp_r8 ) ! ! e2 scale factors 170 CALL iom_rstput( 0, 0, inum, 'e2u', e2u, ktype = jp_r8 ) 171 CALL iom_rstput( 0, 0, inum, 'e2v', e2v, ktype = jp_r8 ) 172 CALL iom_rstput( 0, 0, inum, 'e2f', e2f, ktype = jp_r8 ) 173 174 CALL iom_rstput( 0, 0, inum, 'ff_f', ff_f, ktype = jp_r8 ) ! ! coriolis factor 175 CALL iom_rstput( 0, 0, inum, 'ff_t', ff_t, ktype = jp_r8 ) 252 176 253 177 ! note that mbkt is set to 1 over land ==> use surface tmask 254 178 zprt(:,:) = ssmask(:,:) * REAL( mbkt(:,:) , wp ) 255 CALL iom_rstput( 0, 0, inum 4, 'mbathy', zprt, ktype = jp_i2) ! ! nb of ocean T-points179 CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points 256 180 zprt(:,:) = ssmask(:,:) * REAL( mikt(:,:) , wp ) 257 CALL iom_rstput( 0, 0, inum 4, 'misf', zprt, ktype = jp_i2) ! ! nb of ocean T-points181 CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points 258 182 zprt(:,:) = ssmask(:,:) * REAL( risfdep(:,:) , wp ) 259 CALL iom_rstput( 0, 0, inum4, 'isfdraft', zprt, ktype = jp_r8 ) ! ! nb of ocean T-points 260 261 IF( ln_sco ) THEN ! s-coordinate 262 CALL iom_rstput( 0, 0, inum4, 'hbatt', hbatt ) 263 CALL iom_rstput( 0, 0, inum4, 'hbatu', hbatu ) 264 CALL iom_rstput( 0, 0, inum4, 'hbatv', hbatv ) 265 CALL iom_rstput( 0, 0, inum4, 'hbatf', hbatf ) 266 ! 267 CALL iom_rstput( 0, 0, inum4, 'gsigt', gsigt ) ! ! scaling coef. 268 CALL iom_rstput( 0, 0, inum4, 'gsigw', gsigw ) 269 CALL iom_rstput( 0, 0, inum4, 'gsi3w', gsi3w ) 270 CALL iom_rstput( 0, 0, inum4, 'esigt', esigt ) 271 CALL iom_rstput( 0, 0, inum4, 'esigw', esigw ) 272 ! 273 CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 ) ! ! scale factors 274 CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 ) 275 CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 ) 276 CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 ) 277 CALL iom_rstput( 0, 0, inum4, 'rx1', rx1 ) ! ! Max. grid stiffness ratio 278 ! 279 CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d ) ! ! stretched system 280 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 281 CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r8 ) 282 CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r8 ) 183 CALL iom_rstput( 0, 0, inum, 'isfdraft', zprt, ktype = jp_r8 ) ! ! nb of ocean T-points 184 ! ! vertical mesh 185 CALL iom_rstput( 0, 0, inum, 'e3t_0', e3t_0, ktype = jp_r8 ) ! ! scale factors 186 CALL iom_rstput( 0, 0, inum, 'e3u_0', e3u_0, ktype = jp_r8 ) 187 CALL iom_rstput( 0, 0, inum, 'e3v_0', e3v_0, ktype = jp_r8 ) 188 CALL iom_rstput( 0, 0, inum, 'e3w_0', e3w_0, ktype = jp_r8 ) 189 ! 190 CALL iom_rstput( 0, 0, inum, 'gdept_1d' , gdept_1d , ktype = jp_r8 ) ! stretched system 191 CALL iom_rstput( 0, 0, inum, 'gdepw_1d' , gdepw_1d , ktype = jp_r8 ) 192 CALL iom_rstput( 0, 0, inum, 'gdept_0' , gdept_0 , ktype = jp_r8 ) 193 CALL iom_rstput( 0, 0, inum, 'gdepw_0' , gdepw_0 , ktype = jp_r8 ) 194 ! 195 IF( ln_sco ) THEN ! s-coordinate stiffness 196 CALL dom_stiff( zprt ) 197 CALL iom_rstput( 0, 0, inum, 'stiffness', zprt ) ! Max. grid stiffness ratio 283 198 ENDIF 284 285 IF( ln_zps ) THEN ! z-coordinate - partial steps 286 ! 287 IF( nmsh <= 6 ) THEN ! ! 3D vertical scale factors 288 CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 ) 289 CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 ) 290 CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 ) 291 CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 ) 292 ELSE ! ! 2D masked bottom ocean scale factors 293 DO jj = 1,jpj 294 DO ji = 1,jpi 295 e3tp(ji,jj) = e3t_0(ji,jj,mbkt(ji,jj)) * ssmask(ji,jj) 296 e3wp(ji,jj) = e3w_0(ji,jj,mbkt(ji,jj)) * ssmask(ji,jj) 297 END DO 298 END DO 299 CALL iom_rstput( 0, 0, inum4, 'e3t_ps', e3tp ) 300 CALL iom_rstput( 0, 0, inum4, 'e3w_ps', e3wp ) 301 END IF 302 ! 303 IF( nmsh <= 3 ) THEN ! ! 3D depth 304 CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r8 ) 305 DO jk = 1,jpk 306 DO jj = 1, jpjm1 307 DO ji = 1, fs_jpim1 ! vector opt. 308 zdepu(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji+1,jj ,jk) ) 309 zdepv(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji ,jj+1,jk) ) 310 END DO 311 END DO 312 END DO 313 CALL lbc_lnk( zdepu, 'U', 1. ) ; CALL lbc_lnk( zdepv, 'V', 1. ) 314 CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r8 ) 315 CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r8 ) 316 CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r8 ) 317 ELSE ! ! 2D bottom depth 318 DO jj = 1,jpj 319 DO ji = 1,jpi 320 zprt(ji,jj) = gdept_0(ji,jj,mbkt(ji,jj) ) * ssmask(ji,jj) 321 zprw(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) * ssmask(ji,jj) 322 END DO 323 END DO 324 CALL iom_rstput( 0, 0, inum4, 'hdept', zprt, ktype = jp_r8 ) 325 CALL iom_rstput( 0, 0, inum4, 'hdepw', zprw, ktype = jp_r8 ) 326 ENDIF 327 ! 328 CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d ) ! ! reference z-coord. 329 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d ) 330 CALL iom_rstput( 0, 0, inum4, 'e3t_1d' , e3t_1d ) 331 CALL iom_rstput( 0, 0, inum4, 'e3w_1d' , e3w_1d ) 332 ENDIF 333 334 IF( ln_zco ) THEN 335 ! ! z-coordinate - full steps 336 CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d ) ! ! depth 337 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d ) 338 CALL iom_rstput( 0, 0, inum4, 'e3t_1d' , e3t_1d ) ! ! scale factors 339 CALL iom_rstput( 0, 0, inum4, 'e3w_1d' , e3w_1d ) 199 ! 200 IF( ln_wd ) THEN ! wetting and drying domain 201 CALL iom_rstput( 0, 0, inum, 'ht_0' , ht_0 , ktype = jp_r8 ) 202 CALL iom_rstput( 0, 0, inum, 'ht_wd' , ht_wd , ktype = jp_r8 ) 340 203 ENDIF 341 204 ! ! ============================ 342 !! close the files205 CALL iom_close( inum ) ! close the files 343 206 ! ! ============================ 344 SELECT CASE ( MOD(nmsh, 3) )345 CASE ( 1 )346 CALL iom_close( inum0 )347 CASE ( 2 )348 CALL iom_close( inum1 )349 CALL iom_close( inum2 )350 CASE ( 0 )351 CALL iom_close( inum2 )352 CALL iom_close( inum3 )353 CALL iom_close( inum4 )354 END SELECT355 207 ! 356 208 CALL wrk_dealloc( jpi, jpj, zprt, zprw ) … … 371 223 !! 2) check which elements have been changed 372 224 !!---------------------------------------------------------------------- 373 !374 225 CHARACTER(len=1) , INTENT(in ) :: cdgrd ! 375 226 REAL(wp), DIMENSION(:,:), INTENT(inout) :: puniq ! … … 405 256 END SUBROUTINE dom_uniq 406 257 258 259 SUBROUTINE dom_stiff( px1 ) 260 !!---------------------------------------------------------------------- 261 !! *** ROUTINE dom_stiff *** 262 !! 263 !! ** Purpose : Diagnose maximum grid stiffness/hydrostatic consistency 264 !! 265 !! ** Method : Compute Haney (1991) hydrostatic condition ratio 266 !! Save the maximum in the vertical direction 267 !! (this number is only relevant in s-coordinates) 268 !! 269 !! Haney, 1991, J. Phys. Oceanogr., 21, 610-619. 270 !!---------------------------------------------------------------------- 271 REAL(wp), DIMENSION(:,:), INTENT(out), OPTIONAL :: px1 ! stiffness 272 ! 273 INTEGER :: ji, jj, jk 274 REAL(wp) :: zrxmax 275 REAL(wp), DIMENSION(4) :: zr1 276 REAL(wp), DIMENSION(jpi,jpj) :: zx1 277 !!---------------------------------------------------------------------- 278 zx1(:,:) = 0._wp 279 zrxmax = 0._wp 280 zr1(:) = 0._wp 281 ! 282 DO ji = 2, jpim1 283 DO jj = 2, jpjm1 284 DO jk = 1, jpkm1 285 !!gm remark: dk(gdepw) = e3t ===>>> possible simplification of the following calculation.... 286 !! especially since it is gde3w which is used to compute the pressure gradient 287 !! furthermore, I think gdept_0 should be used below instead of w point in the numerator 288 !! so that the ratio is computed at the same point (i.e. uw and vw) .... 289 zr1(1) = ABS( ( gdepw_0(ji ,jj,jk )-gdepw_0(ji-1,jj,jk ) & 290 & +gdepw_0(ji ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) ) & 291 & / ( gdepw_0(ji ,jj,jk )+gdepw_0(ji-1,jj,jk ) & 292 & -gdepw_0(ji ,jj,jk+1)-gdepw_0(ji-1,jj,jk+1) + rsmall ) ) * umask(ji-1,jj,jk) 293 zr1(2) = ABS( ( gdepw_0(ji+1,jj,jk )-gdepw_0(ji ,jj,jk ) & 294 & +gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji ,jj,jk+1) ) & 295 & / ( gdepw_0(ji+1,jj,jk )+gdepw_0(ji ,jj,jk ) & 296 & -gdepw_0(ji+1,jj,jk+1)-gdepw_0(ji ,jj,jk+1) + rsmall ) ) * umask(ji ,jj,jk) 297 zr1(3) = ABS( ( gdepw_0(ji,jj+1,jk )-gdepw_0(ji,jj ,jk ) & 298 & +gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj ,jk+1) ) & 299 & / ( gdepw_0(ji,jj+1,jk )+gdepw_0(ji,jj ,jk ) & 300 & -gdepw_0(ji,jj+1,jk+1)-gdepw_0(ji,jj ,jk+1) + rsmall ) ) * vmask(ji,jj ,jk) 301 zr1(4) = ABS( ( gdepw_0(ji,jj ,jk )-gdepw_0(ji,jj-1,jk ) & 302 & +gdepw_0(ji,jj ,jk+1)-gdepw_0(ji,jj-1,jk+1) ) & 303 & / ( gdepw_0(ji,jj ,jk )+gdepw_0(ji,jj-1,jk ) & 304 & -gdepw_0(ji,jj ,jk+1)-gdepw_0(ji,jj-1,jk+1) + rsmall ) ) * vmask(ji,jj-1,jk) 305 zrxmax = MAXVAL( zr1(1:4) ) 306 zx1(ji,jj) = MAX( zx1(ji,jj) , zrxmax ) 307 END DO 308 END DO 309 END DO 310 CALL lbc_lnk( zx1, 'T', 1. ) 311 ! 312 IF( PRESENT( px1 ) ) px1 = zx1 313 ! 314 zrxmax = MAXVAL( zx1 ) 315 ! 316 IF( lk_mpp ) CALL mpp_max( zrxmax ) ! max over the global domain 317 ! 318 IF(lwp) THEN 319 WRITE(numout,*) 320 WRITE(numout,*) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax 321 WRITE(numout,*) '~~~~~~~~~' 322 ENDIF 323 ! 324 END SUBROUTINE dom_stiff 325 407 326 !!====================================================================== 408 327 END MODULE domwri -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r6492 r7646 22 22 23 23 !!---------------------------------------------------------------------- 24 !! dom_zgr : defined the ocean vertical coordinate system 25 !! zgr_bat : bathymetry fields (levels and meters) 26 !! zgr_bat_zoom : modify the bathymetry field if zoom domain 27 !! zgr_bat_ctl : check the bathymetry files 28 !! zgr_bot_level: deepest ocean level for t-, u, and v-points 29 !! zgr_z : reference z-coordinate 30 !! zgr_zco : z-coordinate 31 !! zgr_zps : z-coordinate with partial steps 32 !! zgr_sco : s-coordinate 33 !! fssig : tanh stretch function 34 !! fssig1 : Song and Haidvogel 1994 stretch function 35 !! fgamma : Siddorn and Furner 2012 stretching function 24 !! dom_zgr : read or set the ocean vertical coordinate system 25 !! zgr_read : read the vertical information in the domain configuration file 26 !! zgr_top_bot : ocean top and bottom level for t-, u, and v-points with 1 as minimum value 36 27 !!--------------------------------------------------------------------- 37 USE oce 38 USE dom_oce 39 USE wet_dry ! wetting and drying40 USE closea ! closed seas41 USE c1d ! 1D vertical configuration28 USE oce ! ocean variables 29 USE dom_oce ! ocean domain 30 USE usrdef_zgr ! user defined vertical coordinate system 31 USE depth_e3 ! depth <=> e3 32 USE wet_dry, ONLY: ln_wd, ht_wd 42 33 ! 43 USE in_out_manager 44 USE iom 45 USE lbclnk 46 USE lib_mpp 47 USE wrk_nemo 48 USE timing 34 USE in_out_manager ! I/O manager 35 USE iom ! I/O library 36 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 37 USE lib_mpp ! distributed memory computing library 38 USE wrk_nemo ! Memory allocation 39 USE timing ! Timing 49 40 50 41 IMPLICIT NONE … … 52 43 53 44 PUBLIC dom_zgr ! called by dom_init.F90 54 55 ! !!* Namelist namzgr_sco *56 LOGICAL :: ln_s_sh94 ! use hybrid s-sig Song and Haidvogel 1994 stretching function fssig1 (ln_sco=T)57 LOGICAL :: ln_s_sf12 ! use hybrid s-z-sig Siddorn and Furner 2012 stretching function fgamma (ln_sco=T)58 !59 REAL(wp) :: rn_sbot_min ! minimum depth of s-bottom surface (>0) (m)60 REAL(wp) :: rn_sbot_max ! maximum depth of s-bottom surface (= ocean depth) (>0) (m)61 REAL(wp) :: rn_rmax ! maximum cut-off r-value allowed (0<rn_rmax<1)62 REAL(wp) :: rn_hc ! Critical depth for transition from sigma to stretched coordinates63 ! Song and Haidvogel 1994 stretching parameters64 REAL(wp) :: rn_theta ! surface control parameter (0<=rn_theta<=20)65 REAL(wp) :: rn_thetb ! bottom control parameter (0<=rn_thetb<= 1)66 REAL(wp) :: rn_bb ! stretching parameter67 ! ! ( rn_bb=0; top only, rn_bb =1; top and bottom)68 ! Siddorn and Furner stretching parameters69 LOGICAL :: ln_sigcrit ! use sigma coordinates below critical depth (T) or Z coordinates (F) for Siddorn & Furner stretch70 REAL(wp) :: rn_alpha ! control parameter ( > 1 stretch towards surface, < 1 towards seabed)71 REAL(wp) :: rn_efold ! efold length scale for transition to stretched coord72 REAL(wp) :: rn_zs ! depth of surface grid box73 ! bottom cell depth (Zb) is a linear function of water depth Zb = H*a + b74 REAL(wp) :: rn_zb_a ! bathymetry scaling factor for calculating Zb75 REAL(wp) :: rn_zb_b ! offset for calculating Zb76 45 77 46 !! * Substitutions … … 84 53 CONTAINS 85 54 86 SUBROUTINE dom_zgr 55 SUBROUTINE dom_zgr( k_top, k_bot ) 87 56 !!---------------------------------------------------------------------- 88 57 !! *** ROUTINE dom_zgr *** … … 101 70 !! ** Action : define gdep., e3., mbathy and bathy 102 71 !!---------------------------------------------------------------------- 103 INTEGER :: ioptio, ibat ! local integer 104 INTEGER :: ios 105 ! 106 NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav, ln_linssh 72 INTEGER, DIMENSION(:,:), INTENT(out) :: k_top, k_bot ! ocean first and last level indices 73 ! 74 INTEGER :: jk ! dummy loop index 75 INTEGER :: ioptio, ibat, ios ! local integer 76 REAL(wp) :: zrefdep ! depth of the reference level (~10m) 107 77 !!---------------------------------------------------------------------- 108 78 ! 109 79 IF( nn_timing == 1 ) CALL timing_start('dom_zgr') 110 80 ! 111 REWIND( numnam_ref ) ! Namelist namzgr in reference namelist : Vertical coordinate112 READ ( numnam_ref, namzgr, IOSTAT = ios, ERR = 901 )113 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in reference namelist', lwp )114 115 REWIND( numnam_cfg ) ! Namelist namzgr in configuration namelist : Vertical coordinate116 READ ( numnam_cfg, namzgr, IOSTAT = ios, ERR = 902 )117 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr in configuration namelist', lwp )118 IF(lwm) WRITE ( numond, namzgr )119 120 81 IF(lwp) THEN ! Control print 121 82 WRITE(numout,*) 122 83 WRITE(numout,*) 'dom_zgr : vertical coordinate' 123 84 WRITE(numout,*) '~~~~~~~' 124 WRITE(numout,*) ' Namelist namzgr : set vertical coordinate' 85 ENDIF 86 87 IF( ln_linssh .AND. lwp) WRITE(numout,*) ' linear free surface: the vertical mesh does not change in time' 88 89 90 IF( ln_read_cfg ) THEN !== read in mesh_mask.nc file ==! 91 IF(lwp) WRITE(numout,*) 92 IF(lwp) WRITE(numout,*) ' Read vertical mesh in ', TRIM( cn_domcfg ), ' file' 93 ! 94 CALL zgr_read ( ln_zco , ln_zps , ln_sco, ln_isfcav, & 95 & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth 96 & gdept_0 , gdepw_0 , & ! gridpoints depth 97 & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors 98 & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors 99 & k_top , k_bot ) ! 1st & last ocean level 100 ! 101 ELSE !== User defined configuration ==! 102 IF(lwp) WRITE(numout,*) 103 IF(lwp) WRITE(numout,*) ' User defined vertical mesh (usr_def_zgr)' 104 ! 105 CALL usr_def_zgr( ln_zco , ln_zps , ln_sco, ln_isfcav, & 106 & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth 107 & gdept_0 , gdepw_0 , & ! gridpoints depth 108 & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors 109 & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors 110 & k_top , k_bot ) ! 1st & last ocean level 111 ! 112 ENDIF 113 ! 114 !!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w disappears 115 ! Compute gde3w_0 (vertical sum of e3w) 116 gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) 117 DO jk = 2, jpk 118 gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk) 119 END DO 120 ! 121 IF(lwp) THEN ! Control print 122 WRITE(numout,*) 123 WRITE(numout,*) ' Type of vertical coordinate (read in ', TRIM( cn_domcfg ), ' file or set in userdef_nam) :' 125 124 WRITE(numout,*) ' z-coordinate - full steps ln_zco = ', ln_zco 126 125 WRITE(numout,*) ' z-coordinate - partial steps ln_zps = ', ln_zps 127 126 WRITE(numout,*) ' s- or hybrid z-s-coordinate ln_sco = ', ln_sco 128 127 WRITE(numout,*) ' ice shelf cavities ln_isfcav = ', ln_isfcav 129 WRITE(numout,*) ' linear free surface ln_linssh = ', ln_linssh 130 ENDIF 131 132 IF( ln_linssh .AND. lwp) WRITE(numout,*) ' linear free surface: the vertical mesh does not change in time' 128 ENDIF 133 129 134 130 ioptio = 0 ! Check Vertical coordinate options … … 137 133 IF( ln_sco ) ioptio = ioptio + 1 138 134 IF( ioptio /= 1 ) CALL ctl_stop( ' none or several vertical coordinate options used' ) 139 ! 140 ioptio = 0 141 IF ( ln_zco .AND. ln_isfcav ) ioptio = ioptio + 1 142 IF ( ln_sco .AND. ln_isfcav ) ioptio = ioptio + 1 143 IF( ioptio > 0 ) CALL ctl_stop( ' Cavity not tested/compatible with full step (zco) and sigma (ln_sco) ' ) 144 ! 145 ! Build the vertical coordinate system 146 ! ------------------------------------ 147 CALL zgr_z ! Reference z-coordinate system (always called) 148 CALL zgr_bat ! Bathymetry fields (levels and meters) 149 IF( lk_c1d ) CALL lbc_lnk( bathy , 'T', 1._wp ) ! 1D config.: same bathy value over the 3x3 domain 150 IF( ln_zco ) CALL zgr_zco ! z-coordinate 151 IF( ln_zps ) CALL zgr_zps ! Partial step z-coordinate 152 IF( ln_sco ) CALL zgr_sco ! s-coordinate or hybrid z-s coordinate 153 ! 154 ! final adjustment of mbathy & check 155 ! ----------------------------------- 156 IF( lzoom ) CALL zgr_bat_zoom ! correct mbathy in case of zoom subdomain 157 IF( .NOT.lk_c1d ) CALL zgr_bat_ctl ! check bathymetry (mbathy) and suppress isolated ocean points 158 CALL zgr_bot_level ! deepest ocean level for t-, u- and v-points 159 CALL zgr_top_level ! shallowest ocean level for T-, U-, V- points 160 ! 161 IF( lk_c1d ) THEN ! 1D config.: same mbathy value over the 3x3 domain 162 ibat = mbathy(2,2) 163 mbathy(:,:) = ibat 164 END IF 135 136 137 ! ! top/bottom ocean level indices for t-, u- and v-points (f-point also for top) 138 CALL zgr_top_bot( k_top, k_bot ) ! with a minimum value set to 1 139 140 141 ! ! deepest/shallowest W level Above/Below ~10m 142 !!gm BUG in s-coordinate this does not work! 143 zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d ) ! ref. depth with tolerance (10% of minimum layer thickness) 144 nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 145 nla10 = nlb10 - 1 ! deepest W level Above ~10m 146 !!gm end bug 165 147 ! 166 148 IF( nprint == 1 .AND. lwp ) THEN 167 WRITE(numout,*) ' MIN val mbathy ', MINVAL( mbathy(:,:) ), ' MAX ', MAXVAL( mbathy(:,:) ) 149 WRITE(numout,*) ' MIN val k_top ', MINVAL( k_top(:,:) ), ' MAX ', MAXVAL( k_top(:,:) ) 150 WRITE(numout,*) ' MIN val k_bot ', MINVAL( k_bot(:,:) ), ' MAX ', MAXVAL( k_bot(:,:) ) 168 151 WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & 169 152 & ' w ', MINVAL( gdepw_0(:,:,:) ), '3w ', MINVAL( gde3w_0(:,:,:) ) … … 186 169 187 170 188 SUBROUTINE zgr_z 189 !!---------------------------------------------------------------------- 190 !! *** ROUTINE zgr_z *** 191 !! 192 !! ** Purpose : set the depth of model levels and the resulting 193 !! vertical scale factors. 194 !! 195 !! ** Method : z-coordinate system (use in all type of coordinate) 196 !! The depth of model levels is defined from an analytical 197 !! function the derivative of which gives the scale factors. 198 !! both depth and scale factors only depend on k (1d arrays). 199 !! w-level: gdepw_1d = gdep(k) 200 !! e3w_1d(k) = dk(gdep)(k) = e3(k) 201 !! t-level: gdept_1d = gdep(k+0.5) 202 !! e3t_1d(k) = dk(gdep)(k+0.5) = e3(k+0.5) 203 !! 204 !! ** Action : - gdept_1d, gdepw_1d : depth of T- and W-point (m) 205 !! - e3t_1d , e3w_1d : scale factors at T- and W-levels (m) 206 !! 207 !! Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. 208 !!---------------------------------------------------------------------- 209 INTEGER :: jk ! dummy loop indices 210 REAL(wp) :: zt, zw ! temporary scalars 211 REAL(wp) :: zsur, za0, za1, zkth ! Values set from parameters in 212 REAL(wp) :: zacr, zdzmin, zhmax ! par_CONFIG_Rxx.h90 213 REAL(wp) :: zrefdep ! depth of the reference level (~10m) 214 REAL(wp) :: za2, zkth2, zacr2 ! Values for optional double tanh function set from parameters 215 !!---------------------------------------------------------------------- 216 ! 217 IF( nn_timing == 1 ) CALL timing_start('zgr_z') 218 ! 219 ! Set variables from parameters 220 ! ------------------------------ 221 zkth = ppkth ; zacr = ppacr 222 zdzmin = ppdzmin ; zhmax = pphmax 223 zkth2 = ppkth2 ; zacr2 = ppacr2 ! optional (ldbletanh=T) double tanh parameters 224 225 ! If ppa1 and ppa0 and ppsur are et to pp_to_be_computed 226 ! za0, za1, zsur are computed from ppdzmin , pphmax, ppkth, ppacr 227 IF( ppa1 == pp_to_be_computed .AND. & 228 & ppa0 == pp_to_be_computed .AND. & 229 & ppsur == pp_to_be_computed ) THEN 230 ! 231 #if defined key_agrif 232 za1 = ( ppdzmin - pphmax / FLOAT(jpkdta-1) ) & 233 & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpkdta-1) * ( LOG( COSH( (jpkdta - ppkth) / ppacr) )& 234 & - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) 235 #else 236 za1 = ( ppdzmin - pphmax / FLOAT(jpkm1) ) & 237 & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpk-1) * ( LOG( COSH( (jpk - ppkth) / ppacr) ) & 238 & - LOG( COSH( ( 1 - ppkth) / ppacr) ) ) ) 239 #endif 240 za0 = ppdzmin - za1 * TANH( (1-ppkth) / ppacr ) 241 zsur = - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr ) ) 242 ELSE 243 za1 = ppa1 ; za0 = ppa0 ; zsur = ppsur 244 za2 = ppa2 ! optional (ldbletanh=T) double tanh parameter 245 ENDIF 246 247 IF(lwp) THEN ! Parameter print 171 SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate 172 & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate 173 & pdept , pdepw , & ! 3D t & w-points depth 174 & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors 175 & pe3w , pe3uw , pe3vw , & ! - - - 176 & k_top , k_bot ) ! top & bottom ocean level 177 !!--------------------------------------------------------------------- 178 !! *** ROUTINE zgr_read *** 179 !! 180 !! ** Purpose : Read the vertical information in the domain configuration file 181 !! 182 !!---------------------------------------------------------------------- 183 LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags 184 LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag 185 REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] 186 REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] 187 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] 188 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] 189 REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! - - - 190 INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top , k_bot ! first & last ocean level 191 ! 192 INTEGER :: jk ! dummy loop index 193 INTEGER :: inum ! local logical unit 194 REAL(WP) :: z_zco, z_zps, z_sco, z_cav 195 REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace 196 !!---------------------------------------------------------------------- 197 ! 198 IF(lwp) THEN 248 199 WRITE(numout,*) 249 WRITE(numout,*) ' zgr_z : Reference vertical z-coordinates' 250 WRITE(numout,*) ' ~~~~~~~' 251 IF( ppkth == 0._wp ) THEN 252 WRITE(numout,*) ' Uniform grid with ',jpk-1,' layers' 253 WRITE(numout,*) ' Total depth :', zhmax 254 #if defined key_agrif 255 WRITE(numout,*) ' Layer thickness:', zhmax/(jpkdta-1) 256 #else 257 WRITE(numout,*) ' Layer thickness:', zhmax/(jpk-1) 258 #endif 259 ELSE 260 IF( ppa1 == 0._wp .AND. ppa0 == 0._wp .AND. ppsur == 0._wp ) THEN 261 WRITE(numout,*) ' zsur, za0, za1 computed from ' 262 WRITE(numout,*) ' zdzmin = ', zdzmin 263 WRITE(numout,*) ' zhmax = ', zhmax 264 ENDIF 265 WRITE(numout,*) ' Value of coefficients for vertical mesh:' 266 WRITE(numout,*) ' zsur = ', zsur 267 WRITE(numout,*) ' za0 = ', za0 268 WRITE(numout,*) ' za1 = ', za1 269 WRITE(numout,*) ' zkth = ', zkth 270 WRITE(numout,*) ' zacr = ', zacr 271 IF( ldbletanh ) THEN 272 WRITE(numout,*) ' (Double tanh za2 = ', za2 273 WRITE(numout,*) ' parameters) zkth2= ', zkth2 274 WRITE(numout,*) ' zacr2= ', zacr2 275 ENDIF 200 WRITE(numout,*) ' zgr_read : read the vertical coordinates in ', TRIM( cn_domcfg ), ' file' 201 WRITE(numout,*) ' ~~~~~~~~' 202 ENDIF 203 ! 204 CALL iom_open( cn_domcfg, inum ) 205 ! 206 ! !* type of vertical coordinate 207 CALL iom_get( inum, 'ln_zco' , z_zco ) 208 CALL iom_get( inum, 'ln_zps' , z_zps ) 209 CALL iom_get( inum, 'ln_sco' , z_sco ) 210 IF( z_zco == 0._wp ) THEN ; ld_zco = .false. ; ELSE ; ld_zco = .true. ; ENDIF 211 IF( z_zps == 0._wp ) THEN ; ld_zps = .false. ; ELSE ; ld_zps = .true. ; ENDIF 212 IF( z_sco == 0._wp ) THEN ; ld_sco = .false. ; ELSE ; ld_sco = .true. ; ENDIF 213 ! 214 ! !* ocean cavities under iceshelves 215 CALL iom_get( inum, 'ln_isfcav', z_cav ) 216 IF( z_cav == 0._wp ) THEN ; ld_isfcav = .false. ; ELSE ; ld_isfcav = .true. ; ENDIF 217 ! 218 ! !* vertical scale factors 219 CALL iom_get( inum, jpdom_unknown, 'e3t_1d' , pe3t_1d ) ! 1D reference coordinate 220 CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , pe3w_1d ) 221 ! 222 CALL iom_get( inum, jpdom_data, 'e3t_0' , pe3t , lrowattr=ln_use_jattr ) ! 3D coordinate 223 CALL iom_get( inum, jpdom_data, 'e3u_0' , pe3u , lrowattr=ln_use_jattr ) 224 CALL iom_get( inum, jpdom_data, 'e3v_0' , pe3v , lrowattr=ln_use_jattr ) 225 CALL iom_get( inum, jpdom_data, 'e3f_0' , pe3f , lrowattr=ln_use_jattr ) 226 CALL iom_get( inum, jpdom_data, 'e3w_0' , pe3w , lrowattr=ln_use_jattr ) 227 CALL iom_get( inum, jpdom_data, 'e3uw_0' , pe3uw , lrowattr=ln_use_jattr ) 228 CALL iom_get( inum, jpdom_data, 'e3vw_0' , pe3vw , lrowattr=ln_use_jattr ) 229 ! 230 ! !* depths 231 ! !- old depth definition (obsolescent feature) 232 IF( iom_varid( inum, 'gdept_1d', ldstop = .FALSE. ) > 0 .AND. & 233 & iom_varid( inum, 'gdepw_1d', ldstop = .FALSE. ) > 0 .AND. & 234 & iom_varid( inum, 'gdept_0' , ldstop = .FALSE. ) > 0 .AND. & 235 & iom_varid( inum, 'gdepw_0' , ldstop = .FALSE. ) > 0 ) THEN 236 CALL ctl_warn( 'zgr_read : old definition of depths and scale factors used ', & 237 & ' depths at t- and w-points read in the domain configuration file') 238 CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d ) 239 CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d ) 240 CALL iom_get( inum, jpdom_data , 'gdept_0' , pdept , lrowattr=ln_use_jattr ) 241 CALL iom_get( inum, jpdom_data , 'gdepw_0' , pdepw , lrowattr=ln_use_jattr ) 242 ! 243 ELSE !- depths computed from e3. scale factors 244 CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) ! 1D reference depth 245 CALL e3_to_depth( pe3t , pe3w , pdept , pdepw ) ! 3D depths 246 IF(lwp) THEN 247 WRITE(numout,*) 248 WRITE(numout,*) ' Reference 1D z-coordinate depth and scale factors:' 249 WRITE(numout, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" ) 250 WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, pdept_1d(jk), pdepw_1d(jk), pe3t_1d(jk), pe3w_1d(jk), jk = 1, jpk ) 276 251 ENDIF 277 252 ENDIF 278 279 280 ! Reference z-coordinate (depth - scale factor at T- and W-points) 281 ! ====================== 282 IF( ppkth == 0._wp ) THEN ! uniform vertical grid 283 #if defined key_agrif 284 za1 = zhmax / FLOAT(jpkdta-1) 285 #else 286 za1 = zhmax / FLOAT(jpk-1) 287 #endif 288 DO jk = 1, jpk 289 zw = FLOAT( jk ) 290 zt = FLOAT( jk ) + 0.5_wp 291 gdepw_1d(jk) = ( zw - 1 ) * za1 292 gdept_1d(jk) = ( zt - 1 ) * za1 293 e3w_1d (jk) = za1 294 e3t_1d (jk) = za1 295 END DO 296 ELSE ! Madec & Imbard 1996 function 297 IF( .NOT. ldbletanh ) THEN 298 DO jk = 1, jpk 299 zw = REAL( jk , wp ) 300 zt = REAL( jk , wp ) + 0.5_wp 301 gdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth) / zacr ) ) ) 302 gdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth) / zacr ) ) ) 303 e3w_1d (jk) = za0 + za1 * TANH( (zw-zkth) / zacr ) 304 e3t_1d (jk) = za0 + za1 * TANH( (zt-zkth) / zacr ) 305 END DO 306 ELSE 307 DO jk = 1, jpk 308 zw = FLOAT( jk ) 309 zt = FLOAT( jk ) + 0.5_wp 310 ! Double tanh function 311 gdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth ) / zacr ) ) & 312 & + za2 * zacr2* LOG ( COSH( (zw-zkth2) / zacr2 ) ) ) 313 gdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth ) / zacr ) ) & 314 & + za2 * zacr2* LOG ( COSH( (zt-zkth2) / zacr2 ) ) ) 315 e3w_1d (jk) = za0 + za1 * TANH( (zw-zkth ) / zacr ) & 316 & + za2 * TANH( (zw-zkth2) / zacr2 ) 317 e3t_1d (jk) = za0 + za1 * TANH( (zt-zkth ) / zacr ) & 318 & + za2 * TANH( (zt-zkth2) / zacr2 ) 319 END DO 320 ENDIF 321 gdepw_1d(1) = 0._wp ! force first w-level to be exactly at zero 322 ENDIF 323 324 IF ( ln_isfcav ) THEN 325 ! need to be like this to compute the pressure gradient with ISF. If not, level beneath the ISF are not aligned (sum(e3t) /= depth) 326 ! define e3t_0 and e3w_0 as the differences between gdept and gdepw respectively 327 DO jk = 1, jpkm1 328 e3t_1d(jk) = gdepw_1d(jk+1)-gdepw_1d(jk) 329 END DO 330 e3t_1d(jpk) = e3t_1d(jpk-1) ! we don't care because this level is masked in NEMO 331 332 DO jk = 2, jpk 333 e3w_1d(jk) = gdept_1d(jk) - gdept_1d(jk-1) 334 END DO 335 e3w_1d(1 ) = 2._wp * (gdept_1d(1) - gdepw_1d(1)) 336 END IF 337 338 !!gm BUG in s-coordinate this does not work! 339 ! deepest/shallowest W level Above/Below ~10m 340 zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d ) ! ref. depth with tolerance (10% of minimum layer thickness) 341 nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 342 nla10 = nlb10 - 1 ! deepest W level Above ~10m 343 !!gm end bug 344 345 IF(lwp) THEN ! control print 346 WRITE(numout,*) 347 WRITE(numout,*) ' Reference z-coordinate depth and scale factors:' 348 WRITE(numout, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" ) 349 WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_1d(jk), gdepw_1d(jk), e3t_1d(jk), e3w_1d(jk), jk = 1, jpk ) 350 ENDIF 351 DO jk = 1, jpk ! control positivity 352 IF( e3w_1d (jk) <= 0._wp .OR. e3t_1d (jk) <= 0._wp ) CALL ctl_stop( 'dom:zgr_z: e3w_1d or e3t_1d =< 0 ' ) 353 IF( gdepw_1d(jk) < 0._wp .OR. gdept_1d(jk) < 0._wp ) CALL ctl_stop( 'dom:zgr_z: gdepw_1d or gdept_1d < 0 ' ) 354 END DO 355 ! 356 IF( nn_timing == 1 ) CALL timing_stop('zgr_z') 357 ! 358 END SUBROUTINE zgr_z 359 360 361 SUBROUTINE zgr_bat 362 !!---------------------------------------------------------------------- 363 !! *** ROUTINE zgr_bat *** 364 !! 365 !! ** Purpose : set bathymetry both in levels and meters 366 !! 367 !! ** Method : read or define mbathy and bathy arrays 368 !! * level bathymetry: 369 !! The ocean basin geometry is given by a two-dimensional array, 370 !! mbathy, which is defined as follow : 371 !! mbathy(ji,jj) = 1, ..., jpk-1, the number of ocean level 372 !! at t-point (ji,jj). 373 !! = 0 over the continental t-point. 374 !! The array mbathy is checked to verified its consistency with 375 !! model option. in particular: 376 !! mbathy must have at least 1 land grid-points (mbathy<=0) 377 !! along closed boundary. 378 !! mbathy must be cyclic IF jperio=1. 379 !! mbathy must be lower or equal to jpk-1. 380 !! isolated ocean grid points are suppressed from mbathy 381 !! since they are only connected to remaining 382 !! ocean through vertical diffusion. 383 !! ntopo=-1 : rectangular channel or bassin with a bump 384 !! ntopo= 0 : flat rectangular channel or basin 385 !! ntopo= 1 : mbathy is read in 'bathy_level.nc' NetCDF file 386 !! bathy is read in 'bathy_meter.nc' NetCDF file 387 !! 388 !! ** Action : - mbathy: level bathymetry (in level index) 389 !! - bathy : meter bathymetry (in meters) 390 !!---------------------------------------------------------------------- 391 INTEGER :: ji, jj, jk ! dummy loop indices 392 INTEGER :: inum ! temporary logical unit 393 INTEGER :: ierror ! error flag 394 INTEGER :: ii_bump, ij_bump, ih ! bump center position 395 INTEGER :: ii0, ii1, ij0, ij1, ik ! local indices 396 REAL(wp) :: r_bump , h_bump , h_oce ! bump characteristics 397 REAL(wp) :: zi, zj, zh, zhmin ! local scalars 398 INTEGER , ALLOCATABLE, DIMENSION(:,:) :: idta ! global domain integer data 399 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zdta ! global domain scalar data 400 !!---------------------------------------------------------------------- 401 ! 402 IF( nn_timing == 1 ) CALL timing_start('zgr_bat') 403 ! 404 IF(lwp) WRITE(numout,*) 405 IF(lwp) WRITE(numout,*) ' zgr_bat : defines level and meter bathymetry' 406 IF(lwp) WRITE(numout,*) ' ~~~~~~~' 407 ! ! ================== ! 408 IF( ntopo == 0 .OR. ntopo == -1 ) THEN ! defined by hand ! 409 ! ! ================== ! 410 ! ! global domain level and meter bathymetry (idta,zdta) 411 ! 412 ALLOCATE( idta(jpidta,jpjdta), STAT=ierror ) 413 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'zgr_bat: unable to allocate idta array' ) 414 ALLOCATE( zdta(jpidta,jpjdta), STAT=ierror ) 415 IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'zgr_bat: unable to allocate zdta array' ) 416 ! 417 IF( ntopo == 0 ) THEN ! flat basin 418 IF(lwp) WRITE(numout,*) 419 IF(lwp) WRITE(numout,*) ' bathymetry field: flat basin' 420 IF( rn_bathy > 0.01 ) THEN 421 IF(lwp) WRITE(numout,*) ' Depth = rn_bathy read in namelist' 422 zdta(:,:) = rn_bathy 423 IF( ln_sco ) THEN ! s-coordinate (zsc ): idta()=jpk 424 idta(:,:) = jpkm1 425 ELSE ! z-coordinate (zco or zps): step-like topography 426 idta(:,:) = jpkm1 427 DO jk = 1, jpkm1 428 WHERE( gdept_1d(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_1d(jk+1) ) idta(:,:) = jk 429 END DO 430 ENDIF 431 ELSE 432 IF(lwp) WRITE(numout,*) ' Depth = depthw(jpkm1)' 433 idta(:,:) = jpkm1 ! before last level 434 zdta(:,:) = gdepw_1d(jpk) ! last w-point depth 435 h_oce = gdepw_1d(jpk) 436 ENDIF 437 ELSE ! bump centered in the basin 438 IF(lwp) WRITE(numout,*) 439 IF(lwp) WRITE(numout,*) ' bathymetry field: flat basin with a bump' 440 ii_bump = jpidta / 2 ! i-index of the bump center 441 ij_bump = jpjdta / 2 ! j-index of the bump center 442 r_bump = 50000._wp ! bump radius (meters) 443 h_bump = 2700._wp ! bump height (meters) 444 h_oce = gdepw_1d(jpk) ! background ocean depth (meters) 445 IF(lwp) WRITE(numout,*) ' bump characteristics: ' 446 IF(lwp) WRITE(numout,*) ' bump center (i,j) = ', ii_bump, ii_bump 447 IF(lwp) WRITE(numout,*) ' bump height = ', h_bump , ' meters' 448 IF(lwp) WRITE(numout,*) ' bump radius = ', r_bump , ' index' 449 IF(lwp) WRITE(numout,*) ' background ocean depth = ', h_oce , ' meters' 450 ! 451 DO jj = 1, jpjdta ! zdta : 452 DO ji = 1, jpidta 453 zi = FLOAT( ji - ii_bump ) * ppe1_m / r_bump 454 zj = FLOAT( jj - ij_bump ) * ppe2_m / r_bump 455 zdta(ji,jj) = h_oce - h_bump * EXP( -( zi*zi + zj*zj ) ) 456 END DO 457 END DO 458 ! ! idta : 459 IF( ln_sco ) THEN ! s-coordinate (zsc ): idta()=jpk 460 idta(:,:) = jpkm1 461 ELSE ! z-coordinate (zco or zps): step-like topography 462 idta(:,:) = jpkm1 463 DO jk = 1, jpkm1 464 WHERE( gdept_1d(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_1d(jk+1) ) idta(:,:) = jk 465 END DO 466 ENDIF 467 ENDIF 468 ! ! set GLOBAL boundary conditions 469 ! ! Caution : idta on the global domain: use of jperio, not nperio 470 IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 ) THEN 471 idta( : , 1 ) = -1 ; zdta( : , 1 ) = -1._wp 472 idta( : ,jpjdta) = 0 ; zdta( : ,jpjdta) = 0._wp 473 ELSEIF( jperio == 2 ) THEN 474 idta( : , 1 ) = idta( : , 3 ) ; zdta( : , 1 ) = zdta( : , 3 ) 475 idta( : ,jpjdta) = 0 ; zdta( : ,jpjdta) = 0._wp 476 idta( 1 , : ) = 0 ; zdta( 1 , : ) = 0._wp 477 idta(jpidta, : ) = 0 ; zdta(jpidta, : ) = 0._wp 478 ELSE 479 ih = 0 ; zh = 0._wp 480 IF( ln_sco ) ih = jpkm1 ; IF( ln_sco ) zh = h_oce 481 idta( : , 1 ) = ih ; zdta( : , 1 ) = zh 482 idta( : ,jpjdta) = ih ; zdta( : ,jpjdta) = zh 483 idta( 1 , : ) = ih ; zdta( 1 , : ) = zh 484 idta(jpidta, : ) = ih ; zdta(jpidta, : ) = zh 485 ENDIF 486 487 ! ! local domain level and meter bathymetries (mbathy,bathy) 488 mbathy(:,:) = 0 ! set to zero extra halo points 489 bathy (:,:) = 0._wp ! (require for mpp case) 490 DO jj = 1, nlcj ! interior values 491 DO ji = 1, nlci 492 mbathy(ji,jj) = idta( mig(ji), mjg(jj) ) 493 bathy (ji,jj) = zdta( mig(ji), mjg(jj) ) 494 END DO 495 END DO 496 risfdep(:,:)=0.e0 497 misfdep(:,:)=1 498 ! 499 DEALLOCATE( idta, zdta ) 500 ! 501 ! ! ================ ! 502 ELSEIF( ntopo == 1 ) THEN ! read in file ! (over the local domain) 503 ! ! ================ ! 504 ! 505 IF( ln_zco ) THEN ! zco : read level bathymetry 506 CALL iom_open ( 'bathy_level.nc', inum ) 507 CALL iom_get ( inum, jpdom_data, 'Bathy_level', bathy ) 508 CALL iom_close( inum ) 509 mbathy(:,:) = INT( bathy(:,:) ) 510 ! initialisation isf variables 511 risfdep(:,:)=0._wp ; misfdep(:,:)=1 512 ! ! ===================== 513 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA R2 configuration 514 ! ! ===================== 515 ! 516 ii0 = 140 ; ii1 = 140 ! Gibraltar Strait open 517 ij0 = 102 ; ij1 = 102 ! (Thomson, Ocean Modelling, 1995) 518 DO ji = mi0(ii0), mi1(ii1) 519 DO jj = mj0(ij0), mj1(ij1) 520 mbathy(ji,jj) = 15 521 END DO 522 END DO 523 IF(lwp) WRITE(numout,*) 524 IF(lwp) WRITE(numout,*) ' orca_r2: Gibraltar strait open at i=',ii0,' j=',ij0 525 ! 526 ii0 = 160 ; ii1 = 160 ! Bab el mandeb Strait open 527 ij0 = 88 ; ij1 = 88 ! (Thomson, Ocean Modelling, 1995) 528 DO ji = mi0(ii0), mi1(ii1) 529 DO jj = mj0(ij0), mj1(ij1) 530 mbathy(ji,jj) = 12 531 END DO 532 END DO 533 IF(lwp) WRITE(numout,*) 534 IF(lwp) WRITE(numout,*) ' orca_r2: Bab el Mandeb strait open at i=',ii0,' j=',ij0 535 ! 536 ENDIF 537 ! 538 ENDIF 539 IF( ln_zps .OR. ln_sco ) THEN ! zps or sco : read meter bathymetry 540 CALL iom_open ( 'bathy_meter.nc', inum ) 541 IF ( ln_isfcav ) THEN 542 CALL iom_get ( inum, jpdom_data, 'Bathymetry_isf', bathy, lrowattr=.false. ) 543 ELSE 544 CALL iom_get ( inum, jpdom_data, 'Bathymetry' , bathy, lrowattr=ln_use_jattr ) 545 END IF 546 CALL iom_close( inum ) 547 ! 548 ! initialisation isf variables 549 risfdep(:,:)=0._wp ; misfdep(:,:)=1 550 ! 551 IF ( ln_isfcav ) THEN 552 CALL iom_open ( 'isf_draft_meter.nc', inum ) 553 CALL iom_get ( inum, jpdom_data, 'isf_draft', risfdep ) 554 CALL iom_close( inum ) 555 WHERE( bathy(:,:) <= 0._wp ) risfdep(:,:) = 0._wp 556 557 ! set grounded point to 0 558 ! (a treshold could be set here if needed, or set it offline based on the grounded fraction) 559 WHERE ( bathy(:,:) <= risfdep(:,:) + rn_isfhmin ) 560 misfdep(:,:) = 0 ; risfdep(:,:) = 0._wp 561 mbathy (:,:) = 0 ; bathy (:,:) = 0._wp 562 END WHERE 563 END IF 564 ! 565 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA R2 configuration 566 ! 567 ii0 = 140 ; ii1 = 140 ! Gibraltar Strait open 568 ij0 = 102 ; ij1 = 102 ! (Thomson, Ocean Modelling, 1995) 569 DO ji = mi0(ii0), mi1(ii1) 570 DO jj = mj0(ij0), mj1(ij1) 571 bathy(ji,jj) = 284._wp 572 END DO 573 END DO 574 IF(lwp) WRITE(numout,*) 575 IF(lwp) WRITE(numout,*) ' orca_r2: Gibraltar strait open at i=',ii0,' j=',ij0 576 ! 577 ii0 = 160 ; ii1 = 160 ! Bab el mandeb Strait open 578 ij0 = 88 ; ij1 = 88 ! (Thomson, Ocean Modelling, 1995) 579 DO ji = mi0(ii0), mi1(ii1) 580 DO jj = mj0(ij0), mj1(ij1) 581 bathy(ji,jj) = 137._wp 582 END DO 583 END DO 584 IF(lwp) WRITE(numout,*) 585 IF(lwp) WRITE(numout,*) ' orca_r2: Bab el Mandeb strait open at i=',ii0,' j=',ij0 586 ! 587 ENDIF 588 ! 589 ENDIF 590 ! ! =============== ! 591 ELSE ! error ! 592 ! ! =============== ! 593 WRITE(ctmp1,*) 'parameter , ntopo = ', ntopo 594 CALL ctl_stop( ' zgr_bat : '//trim(ctmp1) ) 595 ENDIF 596 ! 597 IF( nn_closea == 0 ) CALL clo_bat( bathy, mbathy ) !== NO closed seas or lakes ==! 598 ! 599 IF ( .not. ln_sco ) THEN !== set a minimum depth ==! 600 IF( rn_hmin < 0._wp ) THEN ; ik = - INT( rn_hmin ) ! from a nb of level 601 ELSE ; ik = MINLOC( gdepw_1d, mask = gdepw_1d > rn_hmin, dim = 1 ) ! from a depth 602 ENDIF 603 zhmin = gdepw_1d(ik+1) ! minimum depth = ik+1 w-levels 604 WHERE( bathy(:,:) <= 0._wp ) ; bathy(:,:) = 0._wp ! min=0 over the lands 605 ELSE WHERE ; bathy(:,:) = MAX( zhmin , bathy(:,:) ) ! min=zhmin over the oceans 606 END WHERE 607 IF(lwp) write(numout,*) 'Minimum ocean depth: ', zhmin, ' minimum number of ocean levels : ', ik 608 ENDIF 609 ! 610 IF( nn_timing == 1 ) CALL timing_stop('zgr_bat') 611 ! 612 END SUBROUTINE zgr_bat 613 614 615 SUBROUTINE zgr_bat_zoom 616 !!---------------------------------------------------------------------- 617 !! *** ROUTINE zgr_bat_zoom *** 618 !! 619 !! ** Purpose : - Close zoom domain boundary if necessary 620 !! - Suppress Med Sea from ORCA R2 and R05 arctic zoom 621 !! 622 !! ** Method : 623 !! 624 !! ** Action : - update mbathy: level bathymetry (in level index) 625 !!---------------------------------------------------------------------- 626 INTEGER :: ii0, ii1, ij0, ij1 ! temporary integers 627 !!---------------------------------------------------------------------- 628 ! 629 IF(lwp) WRITE(numout,*) 630 IF(lwp) WRITE(numout,*) ' zgr_bat_zoom : modify the level bathymetry for zoom domain' 631 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~' 632 ! 633 ! Zoom domain 634 ! =========== 635 ! 636 ! Forced closed boundary if required 637 IF( lzoom_s ) mbathy( : , mj0(jpjzoom):mj1(jpjzoom) ) = 0 638 IF( lzoom_w ) mbathy( mi0(jpizoom):mi1(jpizoom) , : ) = 0 639 IF( lzoom_e ) mbathy( mi0(jpiglo+jpizoom-1):mi1(jpiglo+jpizoom-1) , : ) = 0 640 IF( lzoom_n ) mbathy( : , mj0(jpjglo+jpjzoom-1):mj1(jpjglo+jpjzoom-1) ) = 0 641 ! 642 ! Configuration specific domain modifications 643 ! (here, ORCA arctic configuration: suppress Med Sea) 644 IF( cp_cfg == "orca" .AND. cp_cfz == "arctic" ) THEN 645 SELECT CASE ( jp_cfg ) 646 ! ! ======================= 647 CASE ( 2 ) ! ORCA_R2 configuration 648 ! ! ======================= 649 IF(lwp) WRITE(numout,*) ' ORCA R2 arctic zoom: suppress the Med Sea' 650 ii0 = 141 ; ii1 = 162 ! Sea box i,j indices 651 ij0 = 98 ; ij1 = 110 652 ! ! ======================= 653 CASE ( 05 ) ! ORCA_R05 configuration 654 ! ! ======================= 655 IF(lwp) WRITE(numout,*) ' ORCA R05 arctic zoom: suppress the Med Sea' 656 ii0 = 563 ; ii1 = 642 ! zero over the Med Sea boxe 657 ij0 = 314 ; ij1 = 370 658 END SELECT 659 ! 660 mbathy( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0 ! zero over the Med Sea boxe 661 ! 662 ENDIF 663 ! 664 END SUBROUTINE zgr_bat_zoom 665 666 667 SUBROUTINE zgr_bat_ctl 668 !!---------------------------------------------------------------------- 669 !! *** ROUTINE zgr_bat_ctl *** 670 !! 671 !! ** Purpose : check the bathymetry in levels 672 !! 673 !! ** Method : The array mbathy is checked to verified its consistency 674 !! with the model options. in particular: 675 !! mbathy must have at least 1 land grid-points (mbathy<=0) 676 !! along closed boundary. 677 !! mbathy must be cyclic IF jperio=1. 678 !! mbathy must be lower or equal to jpk-1. 679 !! isolated ocean grid points are suppressed from mbathy 680 !! since they are only connected to remaining 681 !! ocean through vertical diffusion. 682 !! C A U T I O N : mbathy will be modified during the initializa- 683 !! tion phase to become the number of non-zero w-levels of a water 684 !! column, with a minimum value of 1. 685 !! 686 !! ** Action : - update mbathy: level bathymetry (in level index) 687 !! - update bathy : meter bathymetry (in meters) 688 !!---------------------------------------------------------------------- 689 INTEGER :: ji, jj, jl ! dummy loop indices 690 INTEGER :: icompt, ibtest, ikmax ! temporary integers 691 REAL(wp), POINTER, DIMENSION(:,:) :: zbathy 692 !!---------------------------------------------------------------------- 693 ! 694 IF( nn_timing == 1 ) CALL timing_start('zgr_bat_ctl') 695 ! 696 CALL wrk_alloc( jpi, jpj, zbathy ) 697 ! 698 IF(lwp) WRITE(numout,*) 699 IF(lwp) WRITE(numout,*) ' zgr_bat_ctl : check the bathymetry' 700 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' 701 ! ! Suppress isolated ocean grid points 702 IF(lwp) WRITE(numout,*) 703 IF(lwp) WRITE(numout,*)' suppress isolated ocean grid points' 704 IF(lwp) WRITE(numout,*)' -----------------------------------' 705 icompt = 0 706 DO jl = 1, 2 707 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 708 mbathy( 1 ,:) = mbathy(jpim1,:) ! local domain is cyclic east-west 709 mbathy(jpi,:) = mbathy( 2 ,:) 710 ENDIF 711 DO jj = 2, jpjm1 712 DO ji = 2, jpim1 713 ibtest = MAX( mbathy(ji-1,jj), mbathy(ji+1,jj), & 714 & mbathy(ji,jj-1), mbathy(ji,jj+1) ) 715 IF( ibtest < mbathy(ji,jj) ) THEN 716 IF(lwp) WRITE(numout,*) ' the number of ocean level at ', & 717 & 'grid-point (i,j) = ',ji,jj,' is changed from ', mbathy(ji,jj),' to ', ibtest 718 mbathy(ji,jj) = ibtest 719 icompt = icompt + 1 720 ENDIF 721 END DO 722 END DO 723 END DO 724 IF( lk_mpp ) CALL mpp_sum( icompt ) 725 IF( icompt == 0 ) THEN 726 IF(lwp) WRITE(numout,*)' no isolated ocean grid points' 727 ELSE 728 IF(lwp) WRITE(numout,*)' ',icompt,' ocean grid points suppressed' 729 ENDIF 730 IF( lk_mpp ) THEN 731 zbathy(:,:) = FLOAT( mbathy(:,:) ) 732 CALL lbc_lnk( zbathy, 'T', 1._wp ) 733 mbathy(:,:) = INT( zbathy(:,:) ) 734 ENDIF 735 ! ! East-west cyclic boundary conditions 736 IF( nperio == 0 ) THEN 737 IF(lwp) WRITE(numout,*) ' mbathy set to 0 along east and west boundary: nperio = ', nperio 738 IF( lk_mpp ) THEN 739 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 740 IF( jperio /= 1 ) mbathy(1,:) = 0 741 ENDIF 742 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 743 IF( jperio /= 1 ) mbathy(nlci,:) = 0 744 ENDIF 745 ELSE 746 IF( ln_zco .OR. ln_zps ) THEN 747 mbathy( 1 ,:) = 0 748 mbathy(jpi,:) = 0 749 ELSE 750 mbathy( 1 ,:) = jpkm1 751 mbathy(jpi,:) = jpkm1 752 ENDIF 753 ENDIF 754 ELSEIF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 755 IF(lwp) WRITE(numout,*)' east-west cyclic boundary conditions on mbathy: nperio = ', nperio 756 mbathy( 1 ,:) = mbathy(jpim1,:) 757 mbathy(jpi,:) = mbathy( 2 ,:) 758 ELSEIF( nperio == 2 ) THEN 759 IF(lwp) WRITE(numout,*) ' equatorial boundary conditions on mbathy: nperio = ', nperio 760 ELSE 761 IF(lwp) WRITE(numout,*) ' e r r o r' 762 IF(lwp) WRITE(numout,*) ' parameter , nperio = ', nperio 763 ! STOP 'dom_mba' 764 ENDIF 765 ! Boundary condition on mbathy 766 IF( .NOT.lk_mpp ) THEN 767 !!gm !!bug ??? think about it ! 768 ! ... mono- or macro-tasking: T-point, >0, 2D array, no slab 769 zbathy(:,:) = FLOAT( mbathy(:,:) ) 770 CALL lbc_lnk( zbathy, 'T', 1._wp ) 771 mbathy(:,:) = INT( zbathy(:,:) ) 772 ENDIF 773 ! Number of ocean level inferior or equal to jpkm1 774 ikmax = 0 775 DO jj = 1, jpj 776 DO ji = 1, jpi 777 ikmax = MAX( ikmax, mbathy(ji,jj) ) 778 END DO 779 END DO 780 !!gm !!! test to do: ikmax = MAX( mbathy(:,:) ) ??? 781 IF( ikmax > jpkm1 ) THEN 782 IF(lwp) WRITE(numout,*) ' maximum number of ocean level = ', ikmax,' > jpk-1' 783 IF(lwp) WRITE(numout,*) ' change jpk to ',ikmax+1,' to use the exact ead bathymetry' 784 ELSE IF( ikmax < jpkm1 ) THEN 785 IF(lwp) WRITE(numout,*) ' maximum number of ocean level = ', ikmax,' < jpk-1' 786 IF(lwp) WRITE(numout,*) ' you can decrease jpk to ', ikmax+1 787 ENDIF 788 ! 789 CALL wrk_dealloc( jpi, jpj, zbathy ) 790 ! 791 IF( nn_timing == 1 ) CALL timing_stop('zgr_bat_ctl') 792 ! 793 END SUBROUTINE zgr_bat_ctl 794 795 796 SUBROUTINE zgr_bot_level 797 !!---------------------------------------------------------------------- 798 !! *** ROUTINE zgr_bot_level *** 253 ! 254 ! !* ocean top and bottom level 255 CALL iom_get( inum, jpdom_data, 'top_level' , z2d , lrowattr=ln_use_jattr ) ! 1st wet T-points (ISF) 256 k_top(:,:) = INT( z2d(:,:) ) 257 CALL iom_get( inum, jpdom_data, 'bottom_level' , z2d , lrowattr=ln_use_jattr ) ! last wet T-points 258 k_bot(:,:) = INT( z2d(:,:) ) 259 ! 260 ! bathymetry with orography (wetting and drying only) 261 IF( ln_wd ) CALL iom_get( inum, jpdom_data, 'ht_wd' , ht_wd , lrowattr=ln_use_jattr ) 262 ! 263 CALL iom_close( inum ) 264 ! 265 END SUBROUTINE zgr_read 266 267 268 SUBROUTINE zgr_top_bot( k_top, k_bot ) 269 !!---------------------------------------------------------------------- 270 !! *** ROUTINE zgr_top_bot *** 799 271 !! 800 272 !! ** Purpose : defines the vertical index of ocean bottom (mbk. arrays) 801 273 !! 802 !! ** Method : computes from mbathy with a minimum value of 1 over land 803 !! 274 !! ** Method : computes from k_top and k_bot with a minimum value of 1 over land 275 !! 276 !! ** Action : mikt, miku, mikv : vertical indices of the shallowest 277 !! ocean level at t-, u- & v-points 278 !! (min value = 1) 804 279 !! ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest 805 280 !! ocean level at t-, u- & v-points 806 281 !! (min value = 1 over land) 807 282 !!---------------------------------------------------------------------- 283 INTEGER , DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! top & bottom ocean level indices 284 ! 808 285 INTEGER :: ji, jj ! dummy loop indices 809 REAL(wp), POINTER, DIMENSION(:,:) :: z mbk810 !!---------------------------------------------------------------------- 811 ! 812 IF( nn_timing == 1 ) CALL timing_start('zgr_ bot_level')813 ! 814 CALL wrk_alloc( jpi, jpj, zmbk )286 REAL(wp), POINTER, DIMENSION(:,:) :: zk 287 !!---------------------------------------------------------------------- 288 ! 289 IF( nn_timing == 1 ) CALL timing_start('zgr_top_bot') 290 ! 291 CALL wrk_alloc( jpi,jpj, zk ) 815 292 ! 816 293 IF(lwp) WRITE(numout,*) 817 IF(lwp) WRITE(numout,*) ' zgr_bot_level : ocean bottom k-index of T-, U-, V- and W-levels ' 818 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' 819 ! 820 mbkt(:,:) = MAX( mbathy(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) 294 IF(lwp) WRITE(numout,*) ' zgr_top_bot : ocean top and bottom k-index of T-, U-, V- and W-levels ' 295 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' 296 ! 297 mikt(:,:) = MAX( k_top(:,:) , 1 ) ! top ocean k-index of T-level (=1 over land) 298 ! 299 mbkt(:,:) = MAX( k_bot(:,:) , 1 ) ! bottom ocean k-index of T-level (=1 over land) 821 300 822 ! ! bottom k-index of W-level = mbkt+1 823 DO jj = 1, jpjm1 ! bottom k-index of u- (v-) level 301 ! ! N.B. top k-index of W-level = mikt 302 ! ! bottom k-index of W-level = mbkt+1 303 DO jj = 1, jpjm1 824 304 DO ji = 1, jpim1 305 miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) ) 306 mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) ) 307 mikf(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj), mikt(ji+1,jj ), mikt(ji+1,jj+1) ) 308 ! 825 309 mbku(ji,jj) = MIN( mbkt(ji+1,jj ) , mbkt(ji,jj) ) 826 310 mbkv(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj) ) … … 828 312 END DO 829 313 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 830 zmbk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 831 zmbk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 832 ! 833 CALL wrk_dealloc( jpi, jpj, zmbk ) 834 ! 835 IF( nn_timing == 1 ) CALL timing_stop('zgr_bot_level') 836 ! 837 END SUBROUTINE zgr_bot_level 838 839 840 SUBROUTINE zgr_top_level 841 !!---------------------------------------------------------------------- 842 !! *** ROUTINE zgr_top_level *** 843 !! 844 !! ** Purpose : defines the vertical index of ocean top (mik. arrays) 845 !! 846 !! ** Method : computes from misfdep with a minimum value of 1 847 !! 848 !! ** Action : mikt, miku, mikv : vertical indices of the shallowest 849 !! ocean level at t-, u- & v-points 850 !! (min value = 1) 851 !!---------------------------------------------------------------------- 852 INTEGER :: ji, jj ! dummy loop indices 853 REAL(wp), POINTER, DIMENSION(:,:) :: zmik 854 !!---------------------------------------------------------------------- 855 ! 856 IF( nn_timing == 1 ) CALL timing_start('zgr_top_level') 857 ! 858 CALL wrk_alloc( jpi, jpj, zmik ) 859 ! 860 IF(lwp) WRITE(numout,*) 861 IF(lwp) WRITE(numout,*) ' zgr_top_level : ocean top k-index of T-, U-, V- and W-levels ' 862 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~' 863 ! 864 mikt(:,:) = MAX( misfdep(:,:) , 1 ) ! top k-index of T-level (=1) 865 ! ! top k-index of W-level (=mikt) 866 DO jj = 1, jpjm1 ! top k-index of U- (U-) level 867 DO ji = 1, jpim1 868 miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) ) 869 mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) ) 870 mikf(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj), mikt(ji+1,jj ), mikt(ji+1,jj+1) ) 871 END DO 872 END DO 873 874 ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 875 zmik(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk(zmik,'U',1.) ; miku (:,:) = MAX( INT( zmik(:,:) ), 1 ) 876 zmik(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk(zmik,'V',1.) ; mikv (:,:) = MAX( INT( zmik(:,:) ), 1 ) 877 zmik(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk(zmik,'F',1.) ; mikf (:,:) = MAX( INT( zmik(:,:) ), 1 ) 878 ! 879 CALL wrk_dealloc( jpi, jpj, zmik ) 880 ! 881 IF( nn_timing == 1 ) CALL timing_stop('zgr_top_level') 882 ! 883 END SUBROUTINE zgr_top_level 884 885 886 SUBROUTINE zgr_zco 887 !!---------------------------------------------------------------------- 888 !! *** ROUTINE zgr_zco *** 889 !! 890 !! ** Purpose : define the reference z-coordinate system 891 !! 892 !! ** Method : set 3D coord. arrays to reference 1D array 893 !!---------------------------------------------------------------------- 894 INTEGER :: jk 895 !!---------------------------------------------------------------------- 896 ! 897 IF( nn_timing == 1 ) CALL timing_start('zgr_zco') 898 ! 899 DO jk = 1, jpk 900 gdept_0(:,:,jk) = gdept_1d(jk) 901 gdepw_0(:,:,jk) = gdepw_1d(jk) 902 gde3w_0(:,:,jk) = gdepw_1d(jk) 903 e3t_0 (:,:,jk) = e3t_1d (jk) 904 e3u_0 (:,:,jk) = e3t_1d (jk) 905 e3v_0 (:,:,jk) = e3t_1d (jk) 906 e3f_0 (:,:,jk) = e3t_1d (jk) 907 e3w_0 (:,:,jk) = e3w_1d (jk) 908 e3uw_0 (:,:,jk) = e3w_1d (jk) 909 e3vw_0 (:,:,jk) = e3w_1d (jk) 910 END DO 911 ! 912 IF( nn_timing == 1 ) CALL timing_stop('zgr_zco') 913 ! 914 END SUBROUTINE zgr_zco 915 916 917 SUBROUTINE zgr_zps 918 !!---------------------------------------------------------------------- 919 !! *** ROUTINE zgr_zps *** 920 !! 921 !! ** Purpose : the depth and vertical scale factor in partial step 922 !! reference z-coordinate case 923 !! 924 !! ** Method : Partial steps : computes the 3D vertical scale factors 925 !! of T-, U-, V-, W-, UW-, VW and F-points that are associated with 926 !! a partial step representation of bottom topography. 927 !! 928 !! The reference depth of model levels is defined from an analytical 929 !! function the derivative of which gives the reference vertical 930 !! scale factors. 931 !! From depth and scale factors reference, we compute there new value 932 !! with partial steps on 3d arrays ( i, j, k ). 933 !! 934 !! w-level: gdepw_0(i,j,k) = gdep(k) 935 !! e3w_0(i,j,k) = dk(gdep)(k) = e3(i,j,k) 936 !! t-level: gdept_0(i,j,k) = gdep(k+0.5) 937 !! e3t_0(i,j,k) = dk(gdep)(k+0.5) = e3(i,j,k+0.5) 938 !! 939 !! With the help of the bathymetric file ( bathymetry_depth_ORCA_R2.nc), 940 !! we find the mbathy index of the depth at each grid point. 941 !! This leads us to three cases: 942 !! 943 !! - bathy = 0 => mbathy = 0 944 !! - 1 < mbathy < jpkm1 945 !! - bathy > gdepw_0(jpk) => mbathy = jpkm1 946 !! 947 !! Then, for each case, we find the new depth at t- and w- levels 948 !! and the new vertical scale factors at t-, u-, v-, w-, uw-, vw- 949 !! and f-points. 950 !! 951 !! This routine is given as an example, it must be modified 952 !! following the user s desiderata. nevertheless, the output as 953 !! well as the way to compute the model levels and scale factors 954 !! must be respected in order to insure second order accuracy 955 !! schemes. 956 !! 957 !! c a u t i o n : gdept_1d, gdepw_1d and e3._1d are positives 958 !! - - - - - - - gdept_0, gdepw_0 and e3. are positives 959 !! 960 !! Reference : Pacanowsky & Gnanadesikan 1997, Mon. Wea. Rev., 126, 3248-3270. 961 !!---------------------------------------------------------------------- 962 INTEGER :: ji, jj, jk ! dummy loop indices 963 INTEGER :: ik, it, ikb, ikt ! temporary integers 964 REAL(wp) :: ze3tp , ze3wp ! Last ocean level thickness at T- and W-points 965 REAL(wp) :: zdepwp, zdepth ! Ajusted ocean depth to avoid too small e3t 966 REAL(wp) :: zdiff ! temporary scalar 967 REAL(wp) :: zmax ! temporary scalar 968 REAL(wp), POINTER, DIMENSION(:,:,:) :: zprt 969 !!--------------------------------------------------------------------- 970 ! 971 IF( nn_timing == 1 ) CALL timing_start('zgr_zps') 972 ! 973 CALL wrk_alloc( jpi,jpj,jpk, zprt ) 974 ! 975 IF(lwp) WRITE(numout,*) 976 IF(lwp) WRITE(numout,*) ' zgr_zps : z-coordinate with partial steps' 977 IF(lwp) WRITE(numout,*) ' ~~~~~~~ ' 978 IF(lwp) WRITE(numout,*) ' mbathy is recomputed : bathy_level file is NOT used' 979 980 ! bathymetry in level (from bathy_meter) 981 ! =================== 982 zmax = gdepw_1d(jpk) + e3t_1d(jpk) ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) 983 bathy(:,:) = MIN( zmax , bathy(:,:) ) ! bounded value of bathy (min already set at the end of zgr_bat) 984 WHERE( bathy(:,:) == 0._wp ) ; mbathy(:,:) = 0 ! land : set mbathy to 0 985 ELSE WHERE ; mbathy(:,:) = jpkm1 ! ocean : initialize mbathy to the max ocean level 986 END WHERE 987 988 ! Compute mbathy for ocean points (i.e. the number of ocean levels) 989 ! find the number of ocean levels such that the last level thickness 990 ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where 991 ! e3t_1d is the reference level thickness 992 DO jk = jpkm1, 1, -1 993 zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 994 WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth ) mbathy(:,:) = jk-1 995 END DO 996 997 ! Scale factors and depth at T- and W-points 998 DO jk = 1, jpk ! intitialization to the reference z-coordinate 999 gdept_0(:,:,jk) = gdept_1d(jk) 1000 gdepw_0(:,:,jk) = gdepw_1d(jk) 1001 e3t_0 (:,:,jk) = e3t_1d (jk) 1002 e3w_0 (:,:,jk) = e3w_1d (jk) 1003 END DO 1004 1005 ! Bathy, iceshelf draft, scale factor and depth at T- and W- points in case of isf 1006 IF ( ln_isfcav ) CALL zgr_isf 1007 1008 ! Scale factors and depth at T- and W-points 1009 IF ( .NOT. ln_isfcav ) THEN 1010 DO jj = 1, jpj 1011 DO ji = 1, jpi 1012 ik = mbathy(ji,jj) 1013 IF( ik > 0 ) THEN ! ocean point only 1014 ! max ocean level case 1015 IF( ik == jpkm1 ) THEN 1016 zdepwp = bathy(ji,jj) 1017 ze3tp = bathy(ji,jj) - gdepw_1d(ik) 1018 ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) 1019 e3t_0(ji,jj,ik ) = ze3tp 1020 e3t_0(ji,jj,ik+1) = ze3tp 1021 e3w_0(ji,jj,ik ) = ze3wp 1022 e3w_0(ji,jj,ik+1) = ze3tp 1023 gdepw_0(ji,jj,ik+1) = zdepwp 1024 gdept_0(ji,jj,ik ) = gdept_1d(ik-1) + ze3wp 1025 gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp 1026 ! 1027 ELSE ! standard case 1028 IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN ; gdepw_0(ji,jj,ik+1) = bathy(ji,jj) 1029 ELSE ; gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 1030 ENDIF 1031 !gm Bug? check the gdepw_1d 1032 ! ... on ik 1033 gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) ) & 1034 & * ((gdept_1d( ik ) - gdepw_1d(ik) ) & 1035 & / ( gdepw_1d( ik+1) - gdepw_1d(ik) )) 1036 e3t_0 (ji,jj,ik) = e3t_1d (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) ) & 1037 & / ( gdepw_1d( ik+1) - gdepw_1d(ik) ) 1038 e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) ) & 1039 & * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) 1040 ! ... on ik+1 1041 e3w_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) 1042 e3t_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) 1043 gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) 1044 ENDIF 1045 ENDIF 1046 END DO 1047 END DO 1048 ! 1049 it = 0 1050 DO jj = 1, jpj 1051 DO ji = 1, jpi 1052 ik = mbathy(ji,jj) 1053 IF( ik > 0 ) THEN ! ocean point only 1054 e3tp (ji,jj) = e3t_0(ji,jj,ik) 1055 e3wp (ji,jj) = e3w_0(ji,jj,ik) 1056 ! test 1057 zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik ) 1058 IF( zdiff <= 0._wp .AND. lwp ) THEN 1059 it = it + 1 1060 WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj 1061 WRITE(numout,*) ' bathy = ', bathy(ji,jj) 1062 WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 1063 WRITE(numout,*) ' e3tp = ', e3t_0 (ji,jj,ik), ' e3wp = ', e3w_0 (ji,jj,ik ) 1064 ENDIF 1065 ENDIF 1066 END DO 1067 END DO 1068 END IF 1069 ! 1070 ! Scale factors and depth at U-, V-, UW and VW-points 1071 DO jk = 1, jpk ! initialisation to z-scale factors 1072 e3u_0 (:,:,jk) = e3t_1d(jk) 1073 e3v_0 (:,:,jk) = e3t_1d(jk) 1074 e3uw_0(:,:,jk) = e3w_1d(jk) 1075 e3vw_0(:,:,jk) = e3w_1d(jk) 1076 END DO 1077 1078 DO jk = 1,jpk ! Computed as the minimum of neighbooring scale factors 1079 DO jj = 1, jpjm1 1080 DO ji = 1, fs_jpim1 ! vector opt. 1081 e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) 1082 e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) 1083 e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) 1084 e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) 1085 END DO 1086 END DO 1087 END DO 1088 IF ( ln_isfcav ) THEN 1089 ! (ISF) define e3uw (adapted for 2 cells in the water column) 1090 DO jj = 2, jpjm1 1091 DO ji = 2, fs_jpim1 ! vector opt. 1092 ikb = MAX(mbathy (ji,jj),mbathy (ji+1,jj)) 1093 ikt = MAX(misfdep(ji,jj),misfdep(ji+1,jj)) 1094 IF (ikb == ikt+1) e3uw_0(ji,jj,ikb) = MIN( gdept_0(ji,jj,ikb ), gdept_0(ji+1,jj ,ikb ) ) & 1095 & - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji+1,jj ,ikb-1) ) 1096 ikb = MAX(mbathy (ji,jj),mbathy (ji,jj+1)) 1097 ikt = MAX(misfdep(ji,jj),misfdep(ji,jj+1)) 1098 IF (ikb == ikt+1) e3vw_0(ji,jj,ikb) = MIN( gdept_0(ji,jj,ikb ), gdept_0(ji ,jj+1,ikb ) ) & 1099 & - MAX( gdept_0(ji,jj,ikb-1), gdept_0(ji ,jj+1,ikb-1) ) 1100 END DO 1101 END DO 1102 END IF 1103 1104 CALL lbc_lnk( e3u_0 , 'U', 1._wp ) ; CALL lbc_lnk( e3uw_0, 'U', 1._wp ) ! lateral boundary conditions 1105 CALL lbc_lnk( e3v_0 , 'V', 1._wp ) ; CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 1106 ! 1107 1108 DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries) 1109 WHERE( e3u_0 (:,:,jk) == 0._wp ) e3u_0 (:,:,jk) = e3t_1d(jk) 1110 WHERE( e3v_0 (:,:,jk) == 0._wp ) e3v_0 (:,:,jk) = e3t_1d(jk) 1111 WHERE( e3uw_0(:,:,jk) == 0._wp ) e3uw_0(:,:,jk) = e3w_1d(jk) 1112 WHERE( e3vw_0(:,:,jk) == 0._wp ) e3vw_0(:,:,jk) = e3w_1d(jk) 1113 END DO 1114 1115 ! Scale factor at F-point 1116 DO jk = 1, jpk ! initialisation to z-scale factors 1117 e3f_0(:,:,jk) = e3t_1d(jk) 1118 END DO 1119 DO jk = 1, jpk ! Computed as the minimum of neighbooring V-scale factors 1120 DO jj = 1, jpjm1 1121 DO ji = 1, fs_jpim1 ! vector opt. 1122 e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) 1123 END DO 1124 END DO 1125 END DO 1126 CALL lbc_lnk( e3f_0, 'F', 1._wp ) ! Lateral boundary conditions 1127 ! 1128 DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries) 1129 WHERE( e3f_0(:,:,jk) == 0._wp ) e3f_0(:,:,jk) = e3t_1d(jk) 1130 END DO 1131 !!gm bug ? : must be a do loop with mj0,mj1 1132 ! 1133 e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:) ! we duplicate factor scales for jj = 1 and jj = 2 1134 e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:) 1135 e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:) 1136 e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:) 1137 e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:) 1138 1139 ! Control of the sign 1140 IF( MINVAL( e3t_0 (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3t_0 <= 0' ) 1141 IF( MINVAL( e3w_0 (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3w_0 <= 0' ) 1142 IF( MINVAL( gdept_0(:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdept_0 < 0' ) 1143 IF( MINVAL( gdepw_0(:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdepw_0 < 0' ) 1144 1145 ! Compute gde3w_0 (vertical sum of e3w) 1146 IF ( ln_isfcav ) THEN ! if cavity 1147 WHERE( misfdep == 0 ) misfdep = 1 1148 DO jj = 1,jpj 1149 DO ji = 1,jpi 1150 gde3w_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1) 1151 DO jk = 2, misfdep(ji,jj) 1152 gde3w_0(ji,jj,jk) = gde3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk) 1153 END DO 1154 IF( misfdep(ji,jj) >= 2 ) gde3w_0(ji,jj,misfdep(ji,jj)) = risfdep(ji,jj) + 0.5_wp * e3w_0(ji,jj,misfdep(ji,jj)) 1155 DO jk = misfdep(ji,jj) + 1, jpk 1156 gde3w_0(ji,jj,jk) = gde3w_0(ji,jj,jk-1) + e3w_0(ji,jj,jk) 1157 END DO 1158 END DO 1159 END DO 1160 ELSE ! no cavity 1161 gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) 1162 DO jk = 2, jpk 1163 gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk) 1164 END DO 1165 END IF 1166 ! 1167 CALL wrk_dealloc( jpi,jpj,jpk, zprt ) 1168 ! 1169 IF( nn_timing == 1 ) CALL timing_stop('zgr_zps') 1170 ! 1171 END SUBROUTINE zgr_zps 1172 1173 1174 SUBROUTINE zgr_isf 1175 !!---------------------------------------------------------------------- 1176 !! *** ROUTINE zgr_isf *** 1177 !! 1178 !! ** Purpose : check the bathymetry in levels 1179 !! 1180 !! ** Method : THe water column have to contained at least 2 cells 1181 !! Bathymetry and isfdraft are modified (dig/close) to respect 1182 !! this criterion. 1183 !! 1184 !! ** Action : - test compatibility between isfdraft and bathy 1185 !! - bathy and isfdraft are modified 1186 !!---------------------------------------------------------------------- 1187 INTEGER :: ji, jj, jl, jk ! dummy loop indices 1188 INTEGER :: ik, it ! temporary integers 1189 INTEGER :: icompt, ibtest ! (ISF) 1190 INTEGER :: ibtestim1, ibtestip1 ! (ISF) 1191 INTEGER :: ibtestjm1, ibtestjp1 ! (ISF) 1192 REAL(wp) :: zdepth ! Ajusted ocean depth to avoid too small e3t 1193 REAL(wp) :: zmax ! Maximum and minimum depth 1194 REAL(wp) :: zbathydiff ! isf temporary scalar 1195 REAL(wp) :: zrisfdepdiff ! isf temporary scalar 1196 REAL(wp) :: ze3tp , ze3wp ! Last ocean level thickness at T- and W-points 1197 REAL(wp) :: zdepwp ! Ajusted ocean depth to avoid too small e3t 1198 REAL(wp) :: zdiff ! temporary scalar 1199 REAL(wp), POINTER, DIMENSION(:,:) :: zrisfdep, zbathy, zmask ! 2D workspace (ISH) 1200 INTEGER , POINTER, DIMENSION(:,:) :: zmbathy, zmisfdep ! 2D workspace (ISH) 1201 !!--------------------------------------------------------------------- 1202 ! 1203 IF( nn_timing == 1 ) CALL timing_start('zgr_isf') 1204 ! 1205 CALL wrk_alloc( jpi,jpj, zbathy, zmask, zrisfdep) 1206 CALL wrk_alloc( jpi,jpj, zmisfdep, zmbathy ) 1207 1208 ! (ISF) compute misfdep 1209 WHERE( risfdep(:,:) == 0._wp .AND. bathy(:,:) /= 0 ) ; misfdep(:,:) = 1 ! open water : set misfdep to 1 1210 ELSEWHERE ; misfdep(:,:) = 2 ! iceshelf : initialize misfdep to second level 1211 END WHERE 1212 1213 ! Compute misfdep for ocean points (i.e. first wet level) 1214 ! find the first ocean level such that the first level thickness 1215 ! is larger than the bot_level of e3zps_min and e3zps_rat * e3t_0 (where 1216 ! e3t_0 is the reference level thickness 1217 DO jk = 2, jpkm1 1218 zdepth = gdepw_1d(jk+1) - MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 1219 WHERE( 0._wp < risfdep(:,:) .AND. risfdep(:,:) >= zdepth ) misfdep(:,:) = jk+1 1220 END DO 1221 WHERE ( 0._wp < risfdep(:,:) .AND. risfdep(:,:) <= e3t_1d(1) ) 1222 risfdep(:,:) = 0. ; misfdep(:,:) = 1 1223 END WHERE 1224 1225 ! remove very shallow ice shelf (less than ~ 10m if 75L) 1226 WHERE (risfdep(:,:) <= 10._wp .AND. misfdep(:,:) > 1) 1227 misfdep = 0; risfdep = 0.0_wp; 1228 mbathy = 0; bathy = 0.0_wp; 1229 END WHERE 1230 WHERE (bathy(:,:) <= 30.0_wp .AND. gphit < -60._wp) 1231 misfdep = 0; risfdep = 0.0_wp; 1232 mbathy = 0; bathy = 0.0_wp; 1233 END WHERE 1234 1235 ! basic check for the compatibility of bathy and risfdep. I think it should be offline because it is not perfect and cannot solved all the situation 1236 icompt = 0 1237 ! run the bathy check 10 times to be sure all the modif in the bathy or iceshelf draft are compatible together 1238 DO jl = 1, 10 1239 ! check at each iteration if isf is grounded or not (1cm treshold have to be update after first coupling experiments) 1240 WHERE (bathy(:,:) <= risfdep(:,:) + rn_isfhmin) 1241 misfdep(:,:) = 0 ; risfdep(:,:) = 0._wp 1242 mbathy (:,:) = 0 ; bathy (:,:) = 0._wp 1243 END WHERE 1244 WHERE (mbathy(:,:) <= 0) 1245 misfdep(:,:) = 0; risfdep(:,:) = 0._wp 1246 mbathy (:,:) = 0; bathy (:,:) = 0._wp 1247 END WHERE 1248 IF( lk_mpp ) THEN 1249 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1250 CALL lbc_lnk( zbathy, 'T', 1. ) 1251 misfdep(:,:) = INT( zbathy(:,:) ) 1252 1253 CALL lbc_lnk( risfdep,'T', 1. ) 1254 CALL lbc_lnk( bathy, 'T', 1. ) 1255 1256 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1257 CALL lbc_lnk( zbathy, 'T', 1. ) 1258 mbathy(:,:) = INT( zbathy(:,:) ) 1259 ENDIF 1260 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 1261 misfdep( 1 ,:) = misfdep(jpim1,:) ! local domain is cyclic east-west 1262 misfdep(jpi,:) = misfdep( 2 ,:) 1263 mbathy( 1 ,:) = mbathy(jpim1,:) ! local domain is cyclic east-west 1264 mbathy(jpi,:) = mbathy( 2 ,:) 1265 ENDIF 1266 1267 ! split last cell if possible (only where water column is 2 cell or less) 1268 ! if coupled to ice sheet, we do not modify the bathymetry (can be discuss). 1269 IF ( .NOT. ln_iscpl) THEN 1270 DO jk = jpkm1, 1, -1 1271 zmax = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 1272 WHERE( gdepw_1d(jk) < bathy(:,:) .AND. bathy(:,:) <= zmax .AND. misfdep + 1 >= mbathy) 1273 mbathy(:,:) = jk 1274 bathy(:,:) = zmax 1275 END WHERE 1276 END DO 1277 END IF 1278 1279 ! split top cell if possible (only where water column is 2 cell or less) 1280 DO jk = 2, jpkm1 1281 zmax = gdepw_1d(jk+1) - MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 1282 WHERE( gdepw_1d(jk+1) > risfdep(:,:) .AND. risfdep(:,:) >= zmax .AND. misfdep + 1 >= mbathy) 1283 misfdep(:,:) = jk 1284 risfdep(:,:) = zmax 1285 END WHERE 1286 END DO 1287 1288 1289 ! Case where bathy and risfdep compatible but not the level variable mbathy/misfdep because of partial cell condition 1290 DO jj = 1, jpj 1291 DO ji = 1, jpi 1292 ! find the minimum change option: 1293 ! test bathy 1294 IF (risfdep(ji,jj) > 1) THEN 1295 IF ( .NOT. ln_iscpl ) THEN 1296 zbathydiff =ABS(bathy(ji,jj) - (gdepw_1d(mbathy (ji,jj)+1) & 1297 & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 1298 zrisfdepdiff=ABS(risfdep(ji,jj) - (gdepw_1d(misfdep(ji,jj) ) & 1299 & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 1300 IF (bathy(ji,jj) > risfdep(ji,jj) .AND. mbathy(ji,jj) < misfdep(ji,jj)) THEN 1301 IF (zbathydiff <= zrisfdepdiff) THEN 1302 bathy(ji,jj) = gdepw_1d(mbathy(ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj)+1)*e3zps_rat ) 1303 mbathy(ji,jj)= mbathy(ji,jj) + 1 1304 ELSE 1305 risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ) 1306 misfdep(ji,jj) = misfdep(ji,jj) - 1 1307 END IF 1308 ENDIF 1309 ELSE 1310 IF (bathy(ji,jj) > risfdep(ji,jj) .AND. mbathy(ji,jj) < misfdep(ji,jj)) THEN 1311 risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ) 1312 misfdep(ji,jj) = misfdep(ji,jj) - 1 1313 END IF 1314 END IF 1315 END IF 1316 END DO 1317 END DO 1318 1319 ! At least 2 levels for water thickness at T, U, and V point. 1320 DO jj = 1, jpj 1321 DO ji = 1, jpi 1322 ! find the minimum change option: 1323 ! test bathy 1324 IF( misfdep(ji,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) > 1) THEN 1325 IF ( .NOT. ln_iscpl ) THEN 1326 zbathydiff =ABS(bathy(ji,jj) - ( gdepw_1d(mbathy (ji,jj)+1) & 1327 & + MIN( e3zps_min,e3t_1d(mbathy (ji,jj)+1)*e3zps_rat ))) 1328 zrisfdepdiff=ABS(risfdep(ji,jj) - ( gdepw_1d(misfdep(ji,jj) ) & 1329 & - MIN( e3zps_min,e3t_1d(misfdep(ji,jj)-1)*e3zps_rat ))) 1330 IF (zbathydiff <= zrisfdepdiff) THEN 1331 mbathy(ji,jj) = mbathy(ji,jj) + 1 1332 bathy(ji,jj) = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) 1333 ELSE 1334 misfdep(ji,jj)= misfdep(ji,jj) - 1 1335 risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj))*e3zps_rat ) 1336 END IF 1337 ELSE 1338 misfdep(ji,jj)= misfdep(ji,jj) - 1 1339 risfdep(ji,jj)= gdepw_1d(misfdep(ji,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj))*e3zps_rat ) 1340 END IF 1341 ENDIF 1342 END DO 1343 END DO 1344 1345 ! point V mbathy(ji,jj) == misfdep(ji,jj+1) 1346 DO jj = 1, jpjm1 1347 DO ji = 1, jpim1 1348 IF( misfdep(ji,jj+1) == mbathy(ji,jj) .AND. mbathy(ji,jj) > 1) THEN 1349 IF ( .NOT. ln_iscpl ) THEN 1350 zbathydiff =ABS(bathy(ji,jj ) - ( gdepw_1d(mbathy (ji,jj)+1) & 1351 & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj )+1)*e3zps_rat ))) 1352 zrisfdepdiff=ABS(risfdep(ji,jj+1) - ( gdepw_1d(misfdep(ji,jj+1)) & 1353 & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1)-1)*e3zps_rat ))) 1354 IF (zbathydiff <= zrisfdepdiff) THEN 1355 mbathy(ji,jj) = mbathy(ji,jj) + 1 1356 bathy(ji,jj) = gdepw_1d(mbathy (ji,jj )) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj )+1)*e3zps_rat ) 1357 ELSE 1358 misfdep(ji,jj+1) = misfdep(ji,jj+1) - 1 1359 risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) 1360 END IF 1361 ELSE 1362 misfdep(ji,jj+1) = misfdep(ji,jj+1) - 1 1363 risfdep (ji,jj+1) = gdepw_1d(misfdep(ji,jj+1)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj+1))*e3zps_rat ) 1364 END IF 1365 ENDIF 1366 END DO 1367 END DO 1368 1369 IF( lk_mpp ) THEN 1370 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1371 CALL lbc_lnk( zbathy, 'T', 1. ) 1372 misfdep(:,:) = INT( zbathy(:,:) ) 1373 1374 CALL lbc_lnk( risfdep,'T', 1. ) 1375 CALL lbc_lnk( bathy, 'T', 1. ) 1376 1377 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1378 CALL lbc_lnk( zbathy, 'T', 1. ) 1379 mbathy(:,:) = INT( zbathy(:,:) ) 1380 ENDIF 1381 ! point V misdep(ji,jj) == mbathy(ji,jj+1) 1382 DO jj = 1, jpjm1 1383 DO ji = 1, jpim1 1384 IF( misfdep(ji,jj) == mbathy(ji,jj+1) .AND. mbathy(ji,jj) > 1) THEN 1385 IF ( .NOT. ln_iscpl ) THEN 1386 zbathydiff =ABS( bathy(ji,jj+1) - ( gdepw_1d(mbathy (ji,jj+1)+1) & 1387 & + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ))) 1388 zrisfdepdiff=ABS(risfdep(ji,jj ) - ( gdepw_1d(misfdep(ji,jj ) ) & 1389 & - MIN( e3zps_min, e3t_1d(misfdep(ji,jj )-1)*e3zps_rat ))) 1390 IF (zbathydiff <= zrisfdepdiff) THEN 1391 mbathy (ji,jj+1) = mbathy(ji,jj+1) + 1 1392 bathy (ji,jj+1) = gdepw_1d(mbathy (ji,jj+1) ) + MIN( e3zps_min, e3t_1d(mbathy (ji,jj+1)+1)*e3zps_rat ) 1393 ELSE 1394 misfdep(ji,jj) = misfdep(ji,jj) - 1 1395 risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj )+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj ) )*e3zps_rat ) 1396 END IF 1397 ELSE 1398 misfdep(ji,jj) = misfdep(ji,jj) - 1 1399 risfdep(ji,jj) = gdepw_1d(misfdep(ji,jj )+1) - MIN( e3zps_min, e3t_1d(misfdep(ji,jj ) )*e3zps_rat ) 1400 END IF 1401 ENDIF 1402 END DO 1403 END DO 1404 1405 1406 IF( lk_mpp ) THEN 1407 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1408 CALL lbc_lnk( zbathy, 'T', 1. ) 1409 misfdep(:,:) = INT( zbathy(:,:) ) 1410 1411 CALL lbc_lnk( risfdep,'T', 1. ) 1412 CALL lbc_lnk( bathy, 'T', 1. ) 1413 1414 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1415 CALL lbc_lnk( zbathy, 'T', 1. ) 1416 mbathy(:,:) = INT( zbathy(:,:) ) 1417 ENDIF 1418 1419 ! point U mbathy(ji,jj) == misfdep(ji,jj+1) 1420 DO jj = 1, jpjm1 1421 DO ji = 1, jpim1 1422 IF( misfdep(ji+1,jj) == mbathy(ji,jj) .AND. mbathy(ji,jj) > 1) THEN 1423 IF ( .NOT. ln_iscpl ) THEN 1424 zbathydiff =ABS( bathy(ji ,jj) - ( gdepw_1d(mbathy (ji,jj)+1) & 1425 & + MIN( e3zps_min, e3t_1d(mbathy (ji ,jj)+1)*e3zps_rat ))) 1426 zrisfdepdiff=ABS(risfdep(ji+1,jj) - ( gdepw_1d(misfdep(ji+1,jj)) & 1427 & - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj)-1)*e3zps_rat ))) 1428 IF (zbathydiff <= zrisfdepdiff) THEN 1429 mbathy(ji,jj) = mbathy(ji,jj) + 1 1430 bathy(ji,jj) = gdepw_1d(mbathy (ji,jj)) + MIN( e3zps_min, e3t_1d(mbathy(ji,jj) +1)*e3zps_rat ) 1431 ELSE 1432 misfdep(ji+1,jj)= misfdep(ji+1,jj) - 1 1433 risfdep(ji+1,jj) = gdepw_1d(misfdep(ji+1,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj))*e3zps_rat ) 1434 END IF 1435 ELSE 1436 misfdep(ji+1,jj)= misfdep(ji+1,jj) - 1 1437 risfdep(ji+1,jj) = gdepw_1d(misfdep(ji+1,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji+1,jj))*e3zps_rat ) 1438 ENDIF 1439 ENDIF 1440 ENDDO 1441 ENDDO 1442 1443 IF( lk_mpp ) THEN 1444 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1445 CALL lbc_lnk( zbathy, 'T', 1. ) 1446 misfdep(:,:) = INT( zbathy(:,:) ) 1447 1448 CALL lbc_lnk( risfdep,'T', 1. ) 1449 CALL lbc_lnk( bathy, 'T', 1. ) 1450 1451 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1452 CALL lbc_lnk( zbathy, 'T', 1. ) 1453 mbathy(:,:) = INT( zbathy(:,:) ) 1454 ENDIF 1455 1456 ! point U misfdep(ji,jj) == bathy(ji,jj+1) 1457 DO jj = 1, jpjm1 1458 DO ji = 1, jpim1 1459 IF( misfdep(ji,jj) == mbathy(ji+1,jj) .AND. mbathy(ji,jj) > 1) THEN 1460 IF ( .NOT. ln_iscpl ) THEN 1461 zbathydiff =ABS( bathy(ji+1,jj) - ( gdepw_1d(mbathy (ji+1,jj)+1) & 1462 & + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj)+1)*e3zps_rat ))) 1463 zrisfdepdiff=ABS(risfdep(ji ,jj) - ( gdepw_1d(misfdep(ji ,jj) ) & 1464 & - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj)-1)*e3zps_rat ))) 1465 IF (zbathydiff <= zrisfdepdiff) THEN 1466 mbathy(ji+1,jj) = mbathy (ji+1,jj) + 1 1467 bathy (ji+1,jj) = gdepw_1d(mbathy (ji+1,jj) ) + MIN( e3zps_min, e3t_1d(mbathy (ji+1,jj) +1)*e3zps_rat ) 1468 ELSE 1469 misfdep(ji,jj) = misfdep(ji ,jj) - 1 1470 risfdep(ji,jj) = gdepw_1d(misfdep(ji ,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj) )*e3zps_rat ) 1471 END IF 1472 ELSE 1473 misfdep(ji,jj) = misfdep(ji ,jj) - 1 1474 risfdep(ji,jj) = gdepw_1d(misfdep(ji ,jj)+1) - MIN( e3zps_min, e3t_1d(misfdep(ji ,jj) )*e3zps_rat ) 1475 ENDIF 1476 ENDIF 1477 ENDDO 1478 ENDDO 1479 1480 IF( lk_mpp ) THEN 1481 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1482 CALL lbc_lnk( zbathy, 'T', 1. ) 1483 misfdep(:,:) = INT( zbathy(:,:) ) 1484 1485 CALL lbc_lnk( risfdep,'T', 1. ) 1486 CALL lbc_lnk( bathy, 'T', 1. ) 1487 1488 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1489 CALL lbc_lnk( zbathy, 'T', 1. ) 1490 mbathy(:,:) = INT( zbathy(:,:) ) 1491 ENDIF 1492 END DO 1493 ! end dig bathy/ice shelf to be compatible 1494 ! now fill single point in "coastline" of ice shelf, bathy, hole, and test again one cell tickness 1495 DO jl = 1,20 1496 1497 ! remove single point "bay" on isf coast line in the ice shelf draft' 1498 DO jk = 2, jpk 1499 WHERE (misfdep==0) misfdep=jpk 1500 zmask=0._wp 1501 WHERE (misfdep <= jk) zmask=1 1502 DO jj = 2, jpjm1 1503 DO ji = 2, jpim1 1504 IF (misfdep(ji,jj) == jk) THEN 1505 ibtest = zmask(ji-1,jj) + zmask(ji+1,jj) + zmask(ji,jj-1) + zmask(ji,jj+1) 1506 IF (ibtest <= 1) THEN 1507 risfdep(ji,jj)=gdepw_1d(jk+1) ; misfdep(ji,jj)=jk+1 1508 IF (misfdep(ji,jj) > mbathy(ji,jj)) misfdep(ji,jj) = jpk 1509 END IF 1510 END IF 1511 END DO 1512 END DO 1513 END DO 1514 WHERE (misfdep==jpk) 1515 misfdep=0 ; risfdep=0._wp ; mbathy=0 ; bathy=0._wp 1516 END WHERE 1517 IF( lk_mpp ) THEN 1518 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1519 CALL lbc_lnk( zbathy, 'T', 1. ) 1520 misfdep(:,:) = INT( zbathy(:,:) ) 1521 1522 CALL lbc_lnk( risfdep,'T', 1. ) 1523 CALL lbc_lnk( bathy, 'T', 1. ) 1524 1525 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1526 CALL lbc_lnk( zbathy, 'T', 1. ) 1527 mbathy(:,:) = INT( zbathy(:,:) ) 1528 ENDIF 1529 1530 ! remove single point "bay" on bathy coast line beneath an ice shelf' 1531 DO jk = jpk,1,-1 1532 zmask=0._wp 1533 WHERE (mbathy >= jk ) zmask=1 1534 DO jj = 2, jpjm1 1535 DO ji = 2, jpim1 1536 IF (mbathy(ji,jj) == jk .AND. misfdep(ji,jj) >= 2) THEN 1537 ibtest = zmask(ji-1,jj) + zmask(ji+1,jj) + zmask(ji,jj-1) + zmask(ji,jj+1) 1538 IF (ibtest <= 1) THEN 1539 bathy(ji,jj)=gdepw_1d(jk) ; mbathy(ji,jj)=jk-1 1540 IF (misfdep(ji,jj) > mbathy(ji,jj)) mbathy(ji,jj) = 0 1541 END IF 1542 END IF 1543 END DO 1544 END DO 1545 END DO 1546 WHERE (mbathy==0) 1547 misfdep=0 ; risfdep=0._wp ; mbathy=0 ; bathy=0._wp 1548 END WHERE 1549 IF( lk_mpp ) THEN 1550 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1551 CALL lbc_lnk( zbathy, 'T', 1. ) 1552 misfdep(:,:) = INT( zbathy(:,:) ) 1553 1554 CALL lbc_lnk( risfdep,'T', 1. ) 1555 CALL lbc_lnk( bathy, 'T', 1. ) 1556 1557 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1558 CALL lbc_lnk( zbathy, 'T', 1. ) 1559 mbathy(:,:) = INT( zbathy(:,:) ) 1560 ENDIF 1561 1562 ! fill hole in ice shelf 1563 zmisfdep = misfdep 1564 zrisfdep = risfdep 1565 WHERE (zmisfdep <= 1._wp) zmisfdep=jpk 1566 DO jj = 2, jpjm1 1567 DO ji = 2, jpim1 1568 ibtestim1 = zmisfdep(ji-1,jj ) ; ibtestip1 = zmisfdep(ji+1,jj ) 1569 ibtestjm1 = zmisfdep(ji ,jj-1) ; ibtestjp1 = zmisfdep(ji ,jj+1) 1570 IF( zmisfdep(ji,jj) >= mbathy(ji-1,jj ) ) ibtestim1 = jpk 1571 IF( zmisfdep(ji,jj) >= mbathy(ji+1,jj ) ) ibtestip1 = jpk 1572 IF( zmisfdep(ji,jj) >= mbathy(ji ,jj-1) ) ibtestjm1 = jpk 1573 IF( zmisfdep(ji,jj) >= mbathy(ji ,jj+1) ) ibtestjp1 = jpk 1574 ibtest=MIN(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) 1575 IF( ibtest == jpk .AND. misfdep(ji,jj) >= 2) THEN 1576 mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp 1577 END IF 1578 IF( zmisfdep(ji,jj) < ibtest .AND. misfdep(ji,jj) >= 2) THEN 1579 misfdep(ji,jj) = ibtest 1580 risfdep(ji,jj) = gdepw_1d(ibtest) 1581 ENDIF 1582 ENDDO 1583 ENDDO 1584 1585 IF( lk_mpp ) THEN 1586 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1587 CALL lbc_lnk( zbathy, 'T', 1. ) 1588 misfdep(:,:) = INT( zbathy(:,:) ) 1589 1590 CALL lbc_lnk( risfdep, 'T', 1. ) 1591 CALL lbc_lnk( bathy, 'T', 1. ) 1592 1593 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1594 CALL lbc_lnk( zbathy, 'T', 1. ) 1595 mbathy(:,:) = INT( zbathy(:,:) ) 1596 ENDIF 1597 ! 1598 !! fill hole in bathymetry 1599 zmbathy (:,:)=mbathy (:,:) 1600 DO jj = 2, jpjm1 1601 DO ji = 2, jpim1 1602 ibtestim1 = zmbathy(ji-1,jj ) ; ibtestip1 = zmbathy(ji+1,jj ) 1603 ibtestjm1 = zmbathy(ji ,jj-1) ; ibtestjp1 = zmbathy(ji ,jj+1) 1604 IF( zmbathy(ji,jj) < misfdep(ji-1,jj ) ) ibtestim1 = 0 1605 IF( zmbathy(ji,jj) < misfdep(ji+1,jj ) ) ibtestip1 = 0 1606 IF( zmbathy(ji,jj) < misfdep(ji ,jj-1) ) ibtestjm1 = 0 1607 IF( zmbathy(ji,jj) < misfdep(ji ,jj+1) ) ibtestjp1 = 0 1608 ibtest=MAX(ibtestim1, ibtestip1, ibtestjm1, ibtestjp1) 1609 IF( ibtest == 0 .AND. misfdep(ji,jj) >= 2) THEN 1610 mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0.0_wp ; misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0.0_wp ; 1611 END IF 1612 IF( ibtest < zmbathy(ji,jj) .AND. misfdep(ji,jj) >= 2) THEN 1613 mbathy(ji,jj) = ibtest 1614 bathy(ji,jj) = gdepw_1d(ibtest+1) 1615 ENDIF 1616 END DO 1617 END DO 1618 IF( lk_mpp ) THEN 1619 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1620 CALL lbc_lnk( zbathy, 'T', 1. ) 1621 misfdep(:,:) = INT( zbathy(:,:) ) 1622 1623 CALL lbc_lnk( risfdep, 'T', 1. ) 1624 CALL lbc_lnk( bathy, 'T', 1. ) 1625 1626 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1627 CALL lbc_lnk( zbathy, 'T', 1. ) 1628 mbathy(:,:) = INT( zbathy(:,:) ) 1629 ENDIF 1630 ! if not compatible after all check (ie U point water column less than 2 cells), mask U 1631 DO jj = 1, jpjm1 1632 DO ji = 1, jpim1 1633 IF (mbathy(ji,jj) == misfdep(ji+1,jj) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji+1,jj) >= 1) THEN 1634 mbathy(ji,jj) = mbathy(ji,jj) - 1 ; bathy(ji,jj) = gdepw_1d(mbathy(ji,jj)+1) ; 1635 END IF 1636 END DO 1637 END DO 1638 IF( lk_mpp ) THEN 1639 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1640 CALL lbc_lnk( zbathy, 'T', 1. ) 1641 misfdep(:,:) = INT( zbathy(:,:) ) 1642 1643 CALL lbc_lnk( risfdep, 'T', 1. ) 1644 CALL lbc_lnk( bathy, 'T', 1. ) 1645 1646 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1647 CALL lbc_lnk( zbathy, 'T', 1. ) 1648 mbathy(:,:) = INT( zbathy(:,:) ) 1649 ENDIF 1650 ! if not compatible after all check (ie U point water column less than 2 cells), mask U 1651 DO jj = 1, jpjm1 1652 DO ji = 1, jpim1 1653 IF (misfdep(ji,jj) == mbathy(ji+1,jj) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji+1,jj) >= 1) THEN 1654 mbathy(ji+1,jj) = mbathy(ji+1,jj) - 1; bathy(ji+1,jj) = gdepw_1d(mbathy(ji+1,jj)+1) ; 1655 END IF 1656 END DO 1657 END DO 1658 IF( lk_mpp ) THEN 1659 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1660 CALL lbc_lnk( zbathy, 'T', 1. ) 1661 misfdep(:,:) = INT( zbathy(:,:) ) 1662 1663 CALL lbc_lnk( risfdep,'T', 1. ) 1664 CALL lbc_lnk( bathy, 'T', 1. ) 1665 1666 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1667 CALL lbc_lnk( zbathy, 'T', 1. ) 1668 mbathy(:,:) = INT( zbathy(:,:) ) 1669 ENDIF 1670 ! if not compatible after all check (ie V point water column less than 2 cells), mask V 1671 DO jj = 1, jpjm1 1672 DO ji = 1, jpi 1673 IF (mbathy(ji,jj) == misfdep(ji,jj+1) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji,jj+1) >= 1) THEN 1674 mbathy(ji,jj) = mbathy(ji,jj) - 1 ; bathy(ji,jj) = gdepw_1d(mbathy(ji,jj)+1) ; 1675 END IF 1676 END DO 1677 END DO 1678 IF( lk_mpp ) THEN 1679 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1680 CALL lbc_lnk( zbathy, 'T', 1. ) 1681 misfdep(:,:) = INT( zbathy(:,:) ) 1682 1683 CALL lbc_lnk( risfdep,'T', 1. ) 1684 CALL lbc_lnk( bathy, 'T', 1. ) 1685 1686 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1687 CALL lbc_lnk( zbathy, 'T', 1. ) 1688 mbathy(:,:) = INT( zbathy(:,:) ) 1689 ENDIF 1690 ! if not compatible after all check (ie V point water column less than 2 cells), mask V 1691 DO jj = 1, jpjm1 1692 DO ji = 1, jpi 1693 IF (misfdep(ji,jj) == mbathy(ji,jj+1) .AND. mbathy(ji,jj) >= 1 .AND. mbathy(ji,jj+1) >= 1) THEN 1694 mbathy(ji,jj+1) = mbathy(ji,jj+1) - 1 ; bathy(ji,jj+1) = gdepw_1d(mbathy(ji,jj+1)+1) ; 1695 END IF 1696 END DO 1697 END DO 1698 IF( lk_mpp ) THEN 1699 zbathy(:,:) = FLOAT( misfdep(:,:) ) 1700 CALL lbc_lnk( zbathy, 'T', 1. ) 1701 misfdep(:,:) = INT( zbathy(:,:) ) 1702 1703 CALL lbc_lnk( risfdep,'T', 1. ) 1704 CALL lbc_lnk( bathy, 'T', 1. ) 1705 1706 zbathy(:,:) = FLOAT( mbathy(:,:) ) 1707 CALL lbc_lnk( zbathy, 'T', 1. ) 1708 mbathy(:,:) = INT( zbathy(:,:) ) 1709 ENDIF 1710 ! if not compatible after all check, mask T 1711 DO jj = 1, jpj 1712 DO ji = 1, jpi 1713 IF (mbathy(ji,jj) <= misfdep(ji,jj)) THEN 1714 misfdep(ji,jj) = 0 ; risfdep(ji,jj) = 0._wp ; mbathy(ji,jj) = 0 ; bathy(ji,jj) = 0._wp ; 1715 END IF 1716 END DO 1717 END DO 1718 1719 WHERE (mbathy(:,:) == 1) 1720 mbathy = 0; bathy = 0.0_wp ; misfdep = 0 ; risfdep = 0.0_wp 1721 END WHERE 1722 END DO 1723 ! end check compatibility ice shelf/bathy 1724 ! remove very shallow ice shelf (less than ~ 10m if 75L) 1725 WHERE (risfdep(:,:) <= 10._wp) 1726 misfdep = 1; risfdep = 0.0_wp; 1727 END WHERE 1728 1729 IF( icompt == 0 ) THEN 1730 IF(lwp) WRITE(numout,*)' no points with ice shelf too close to bathymetry' 1731 ELSE 1732 IF(lwp) WRITE(numout,*)' ',icompt,' ocean grid points with ice shelf thickness reduced to avoid bathymetry' 1733 ENDIF 1734 1735 ! compute scale factor and depth at T- and W- points 1736 DO jj = 1, jpj 1737 DO ji = 1, jpi 1738 ik = mbathy(ji,jj) 1739 IF( ik > 0 ) THEN ! ocean point only 1740 ! max ocean level case 1741 IF( ik == jpkm1 ) THEN 1742 zdepwp = bathy(ji,jj) 1743 ze3tp = bathy(ji,jj) - gdepw_1d(ik) 1744 ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) 1745 e3t_0(ji,jj,ik ) = ze3tp 1746 e3t_0(ji,jj,ik+1) = ze3tp 1747 e3w_0(ji,jj,ik ) = ze3wp 1748 e3w_0(ji,jj,ik+1) = ze3tp 1749 gdepw_0(ji,jj,ik+1) = zdepwp 1750 gdept_0(ji,jj,ik ) = gdept_1d(ik-1) + ze3wp 1751 gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp 1752 ! 1753 ELSE ! standard case 1754 IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN ; gdepw_0(ji,jj,ik+1) = bathy(ji,jj) 1755 ELSE ; gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 1756 ENDIF 1757 ! gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 1758 !gm Bug? check the gdepw_1d 1759 ! ... on ik 1760 gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) ) & 1761 & * ((gdept_1d( ik ) - gdepw_1d(ik) ) & 1762 & / ( gdepw_1d( ik+1) - gdepw_1d(ik) )) 1763 e3t_0 (ji,jj,ik ) = gdepw_0(ji,jj,ik+1) - gdepw_1d(ik ) 1764 e3w_0 (ji,jj,ik ) = gdept_0(ji,jj,ik ) - gdept_1d(ik-1) 1765 ! ... on ik+1 1766 e3w_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) 1767 e3t_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) 1768 ENDIF 1769 ENDIF 1770 END DO 1771 END DO 1772 ! 1773 it = 0 1774 DO jj = 1, jpj 1775 DO ji = 1, jpi 1776 ik = mbathy(ji,jj) 1777 IF( ik > 0 ) THEN ! ocean point only 1778 e3tp (ji,jj) = e3t_0(ji,jj,ik) 1779 e3wp (ji,jj) = e3w_0(ji,jj,ik) 1780 ! test 1781 zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik ) 1782 IF( zdiff <= 0._wp .AND. lwp ) THEN 1783 it = it + 1 1784 WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj 1785 WRITE(numout,*) ' bathy = ', bathy(ji,jj) 1786 WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 1787 WRITE(numout,*) ' e3tp = ', e3t_0 (ji,jj,ik), ' e3wp = ', e3w_0 (ji,jj,ik ) 1788 ENDIF 1789 ENDIF 1790 END DO 1791 END DO 1792 ! 1793 ! (ISF) Definition of e3t, u, v, w for ISF case 1794 DO jj = 1, jpj 1795 DO ji = 1, jpi 1796 ik = misfdep(ji,jj) 1797 IF( ik > 1 ) THEN ! ice shelf point only 1798 IF( risfdep(ji,jj) < gdepw_1d(ik) ) risfdep(ji,jj)= gdepw_1d(ik) 1799 gdepw_0(ji,jj,ik) = risfdep(ji,jj) 1800 !gm Bug? check the gdepw_0 1801 ! ... on ik 1802 gdept_0(ji,jj,ik) = gdepw_1d(ik+1) - ( gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) ) & 1803 & * ( gdepw_1d(ik+1) - gdept_1d(ik) ) & 1804 & / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) 1805 e3t_0 (ji,jj,ik ) = gdepw_1d(ik+1) - gdepw_0(ji,jj,ik) 1806 e3w_0 (ji,jj,ik+1) = gdept_1d(ik+1) - gdept_0(ji,jj,ik) 1807 1808 IF( ik + 1 == mbathy(ji,jj) ) THEN ! ice shelf point only (2 cell water column) 1809 e3w_0 (ji,jj,ik+1) = gdept_0(ji,jj,ik+1) - gdept_0(ji,jj,ik) 1810 ENDIF 1811 ! ... on ik / ik-1 1812 e3w_0 (ji,jj,ik ) = e3t_0 (ji,jj,ik) !2._wp * (gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik)) 1813 e3t_0 (ji,jj,ik-1) = gdepw_0(ji,jj,ik) - gdepw_1d(ik-1) 1814 ! The next line isn't required and doesn't affect results - included for consistency with bathymetry code 1815 gdept_0(ji,jj,ik-1) = gdept_1d(ik-1) 1816 ENDIF 1817 END DO 1818 END DO 1819 1820 it = 0 1821 DO jj = 1, jpj 1822 DO ji = 1, jpi 1823 ik = misfdep(ji,jj) 1824 IF( ik > 1 ) THEN ! ice shelf point only 1825 e3tp (ji,jj) = e3t_0(ji,jj,ik ) 1826 e3wp (ji,jj) = e3w_0(ji,jj,ik+1 ) 1827 ! test 1828 zdiff= gdept_0(ji,jj,ik) - gdepw_0(ji,jj,ik ) 1829 IF( zdiff <= 0. .AND. lwp ) THEN 1830 it = it + 1 1831 WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj 1832 WRITE(numout,*) ' risfdep = ', risfdep(ji,jj) 1833 WRITE(numout,*) ' gdept = ', gdept_0(ji,jj,ik), ' gdepw = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 1834 WRITE(numout,*) ' e3tp = ', e3tp(ji,jj), ' e3wp = ', e3wp(ji,jj) 1835 ENDIF 1836 ENDIF 1837 END DO 1838 END DO 1839 1840 CALL wrk_dealloc( jpi, jpj, zmask, zbathy, zrisfdep ) 1841 CALL wrk_dealloc( jpi, jpj, zmisfdep, zmbathy ) 1842 ! 1843 IF( nn_timing == 1 ) CALL timing_stop('zgr_isf') 1844 ! 1845 END SUBROUTINE zgr_isf 1846 1847 1848 SUBROUTINE zgr_sco 1849 !!---------------------------------------------------------------------- 1850 !! *** ROUTINE zgr_sco *** 1851 !! 1852 !! ** Purpose : define the s-coordinate system 1853 !! 1854 !! ** Method : s-coordinate 1855 !! The depth of model levels is defined as the product of an 1856 !! analytical function by the local bathymetry, while the vertical 1857 !! scale factors are defined as the product of the first derivative 1858 !! of the analytical function by the bathymetry. 1859 !! (this solution save memory as depth and scale factors are not 1860 !! 3d fields) 1861 !! - Read bathymetry (in meters) at t-point and compute the 1862 !! bathymetry at u-, v-, and f-points. 1863 !! hbatu = mi( hbatt ) 1864 !! hbatv = mj( hbatt ) 1865 !! hbatf = mi( mj( hbatt ) ) 1866 !! - Compute z_gsigt, z_gsigw, z_esigt, z_esigw from an analytical 1867 !! function and its derivative given as function. 1868 !! z_gsigt(k) = fssig (k ) 1869 !! z_gsigw(k) = fssig (k-0.5) 1870 !! z_esigt(k) = fsdsig(k ) 1871 !! z_esigw(k) = fsdsig(k-0.5) 1872 !! Three options for stretching are give, and they can be modified 1873 !! following the users requirements. Nevertheless, the output as 1874 !! well as the way to compute the model levels and scale factors 1875 !! must be respected in order to insure second order accuracy 1876 !! schemes. 1877 !! 1878 !! The three methods for stretching available are: 1879 !! 1880 !! s_sh94 (Song and Haidvogel 1994) 1881 !! a sinh/tanh function that allows sigma and stretched sigma 1882 !! 1883 !! s_sf12 (Siddorn and Furner 2012?) 1884 !! allows the maintenance of fixed surface and or 1885 !! bottom cell resolutions (cf. geopotential coordinates) 1886 !! within an analytically derived stretched S-coordinate framework. 1887 !! 1888 !! s_tanh (Madec et al 1996) 1889 !! a cosh/tanh function that gives stretched coordinates 1890 !! 1891 !!---------------------------------------------------------------------- 1892 INTEGER :: ji, jj, jk, jl ! dummy loop argument 1893 INTEGER :: iip1, ijp1, iim1, ijm1 ! temporary integers 1894 INTEGER :: ios ! Local integer output status for namelist read 1895 REAL(wp) :: zrmax, ztaper ! temporary scalars 1896 REAL(wp) :: zrfact 1897 ! 1898 REAL(wp), POINTER, DIMENSION(:,: ) :: ztmpi1, ztmpi2, ztmpj1, ztmpj2 1899 REAL(wp), POINTER, DIMENSION(:,: ) :: zenv, ztmp, zmsk, zri, zrj, zhbat 1900 !! 1901 NAMELIST/namzgr_sco/ln_s_sh94, ln_s_sf12, ln_sigcrit, rn_sbot_min, rn_sbot_max, rn_hc, rn_rmax,rn_theta, & 1902 & rn_thetb, rn_bb, rn_alpha, rn_efold, rn_zs, rn_zb_a, rn_zb_b 1903 !!---------------------------------------------------------------------- 1904 ! 1905 IF( nn_timing == 1 ) CALL timing_start('zgr_sco') 1906 ! 1907 CALL wrk_alloc( jpi,jpj, zenv, ztmp, zmsk, zri, zrj, zhbat , ztmpi1, ztmpi2, ztmpj1, ztmpj2 ) 1908 ! 1909 REWIND( numnam_ref ) ! Namelist namzgr_sco in reference namelist : Sigma-stretching parameters 1910 READ ( numnam_ref, namzgr_sco, IOSTAT = ios, ERR = 901) 1911 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_sco in reference namelist', lwp ) 1912 1913 REWIND( numnam_cfg ) ! Namelist namzgr_sco in configuration namelist : Sigma-stretching parameters 1914 READ ( numnam_cfg, namzgr_sco, IOSTAT = ios, ERR = 902 ) 1915 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzgr_sco in configuration namelist', lwp ) 1916 IF(lwm) WRITE ( numond, namzgr_sco ) 1917 1918 IF(lwp) THEN ! control print 1919 WRITE(numout,*) 1920 WRITE(numout,*) 'domzgr_sco : s-coordinate or hybrid z-s-coordinate' 1921 WRITE(numout,*) '~~~~~~~~~~~' 1922 WRITE(numout,*) ' Namelist namzgr_sco' 1923 WRITE(numout,*) ' stretching coeffs ' 1924 WRITE(numout,*) ' maximum depth of s-bottom surface (>0) rn_sbot_max = ',rn_sbot_max 1925 WRITE(numout,*) ' minimum depth of s-bottom surface (>0) rn_sbot_min = ',rn_sbot_min 1926 WRITE(numout,*) ' Critical depth rn_hc = ',rn_hc 1927 WRITE(numout,*) ' maximum cut-off r-value allowed rn_rmax = ',rn_rmax 1928 WRITE(numout,*) ' Song and Haidvogel 1994 stretching ln_s_sh94 = ',ln_s_sh94 1929 WRITE(numout,*) ' Song and Haidvogel 1994 stretching coefficients' 1930 WRITE(numout,*) ' surface control parameter (0<=rn_theta<=20) rn_theta = ',rn_theta 1931 WRITE(numout,*) ' bottom control parameter (0<=rn_thetb<= 1) rn_thetb = ',rn_thetb 1932 WRITE(numout,*) ' stretching parameter (song and haidvogel) rn_bb = ',rn_bb 1933 WRITE(numout,*) ' Siddorn and Furner 2012 stretching ln_s_sf12 = ',ln_s_sf12 1934 WRITE(numout,*) ' switching to sigma (T) or Z (F) at H<Hc ln_sigcrit = ',ln_sigcrit 1935 WRITE(numout,*) ' Siddorn and Furner 2012 stretching coefficients' 1936 WRITE(numout,*) ' stretchin parameter ( >1 surface; <1 bottom) rn_alpha = ',rn_alpha 1937 WRITE(numout,*) ' e-fold length scale for transition region rn_efold = ',rn_efold 1938 WRITE(numout,*) ' Surface cell depth (Zs) (m) rn_zs = ',rn_zs 1939 WRITE(numout,*) ' Bathymetry multiplier for Zb rn_zb_a = ',rn_zb_a 1940 WRITE(numout,*) ' Offset for Zb rn_zb_b = ',rn_zb_b 1941 WRITE(numout,*) ' Bottom cell (Zb) (m) = H*rn_zb_a + rn_zb_b' 1942 ENDIF 1943 1944 hift(:,:) = rn_sbot_min ! set the minimum depth for the s-coordinate 1945 hifu(:,:) = rn_sbot_min 1946 hifv(:,:) = rn_sbot_min 1947 hiff(:,:) = rn_sbot_min 1948 1949 ! ! set maximum ocean depth 1950 bathy(:,:) = MIN( rn_sbot_max, bathy(:,:) ) 1951 1952 IF( .NOT.ln_wd ) THEN 1953 DO jj = 1, jpj 1954 DO ji = 1, jpi 1955 IF( bathy(ji,jj) > 0._wp ) bathy(ji,jj) = MAX( rn_sbot_min, bathy(ji,jj) ) 1956 END DO 1957 END DO 1958 END IF 1959 ! ! ============================= 1960 ! ! Define the envelop bathymetry (hbatt) 1961 ! ! ============================= 1962 ! use r-value to create hybrid coordinates 1963 zenv(:,:) = bathy(:,:) 1964 ! 1965 IF( .NOT.ln_wd ) THEN 1966 ! set first land point adjacent to a wet cell to sbot_min as this needs to be included in smoothing 1967 DO jj = 1, jpj 1968 DO ji = 1, jpi 1969 IF( bathy(ji,jj) == 0._wp ) THEN 1970 iip1 = MIN( ji+1, jpi ) 1971 ijp1 = MIN( jj+1, jpj ) 1972 iim1 = MAX( ji-1, 1 ) 1973 ijm1 = MAX( jj-1, 1 ) 1974 !!gm BUG fix see ticket #1617 1975 IF( ( + bathy(iim1,ijm1) + bathy(ji,ijp1) + bathy(iip1,ijp1) & 1976 & + bathy(iim1,jj ) + bathy(iip1,jj ) & 1977 & + bathy(iim1,ijm1) + bathy(ji,ijm1) + bathy(iip1,ijp1) ) > 0._wp ) & 1978 & zenv(ji,jj) = rn_sbot_min 1979 !!gm 1980 !!gm IF( ( bathy(iip1,jj ) + bathy(iim1,jj ) + bathy(ji,ijp1 ) + bathy(ji,ijm1) + & 1981 !!gm & bathy(iip1,ijp1) + bathy(iim1,ijm1) + bathy(iip1,ijp1) + bathy(iim1,ijm1)) > 0._wp ) THEN 1982 !!gm zenv(ji,jj) = rn_sbot_min 1983 !!gm ENDIF 1984 !!gm end 1985 ENDIF 1986 END DO 1987 END DO 1988 END IF 1989 1990 ! apply lateral boundary condition CAUTION: keep the value when the lbc field is zero 1991 CALL lbc_lnk( zenv, 'T', 1._wp, 'no0' ) 1992 ! 1993 ! smooth the bathymetry (if required) 1994 scosrf(:,:) = 0._wp ! ocean surface depth (here zero: no under ice-shelf sea) 1995 scobot(:,:) = bathy(:,:) ! ocean bottom depth 1996 ! 1997 jl = 0 1998 zrmax = 1._wp 1999 ! 2000 ! 2001 ! set scaling factor used in reducing vertical gradients 2002 zrfact = ( 1._wp - rn_rmax ) / ( 1._wp + rn_rmax ) 2003 ! 2004 ! initialise temporary evelope depth arrays 2005 ztmpi1(:,:) = zenv(:,:) 2006 ztmpi2(:,:) = zenv(:,:) 2007 ztmpj1(:,:) = zenv(:,:) 2008 ztmpj2(:,:) = zenv(:,:) 2009 ! 2010 ! initialise temporary r-value arrays 2011 zri(:,:) = 1._wp 2012 zrj(:,:) = 1._wp 2013 ! ! ================ ! 2014 DO WHILE( jl <= 10000 .AND. ( zrmax - rn_rmax ) > 1.e-8_wp ) ! Iterative loop ! 2015 ! ! ================ ! 2016 jl = jl + 1 2017 zrmax = 0._wp 2018 ! we set zrmax from previous r-values (zri and zrj) first 2019 ! if set after current r-value calculation (as previously) 2020 ! we could exit DO WHILE prematurely before checking r-value 2021 ! of current zenv 2022 DO jj = 1, nlcj 2023 DO ji = 1, nlci 2024 zrmax = MAX( zrmax, ABS(zri(ji,jj)), ABS(zrj(ji,jj)) ) 2025 END DO 2026 END DO 2027 zri(:,:) = 0._wp 2028 zrj(:,:) = 0._wp 2029 DO jj = 1, nlcj 2030 DO ji = 1, nlci 2031 iip1 = MIN( ji+1, nlci ) ! force zri = 0 on last line (ji=ncli+1 to jpi) 2032 ijp1 = MIN( jj+1, nlcj ) ! force zrj = 0 on last raw (jj=nclj+1 to jpj) 2033 IF( (zenv(ji,jj) > 0._wp) .AND. (zenv(iip1,jj) > 0._wp)) THEN 2034 zri(ji,jj) = ( zenv(iip1,jj ) - zenv(ji,jj) ) / ( zenv(iip1,jj ) + zenv(ji,jj) ) 2035 END IF 2036 IF( (zenv(ji,jj) > 0._wp) .AND. (zenv(ji,ijp1) > 0._wp)) THEN 2037 zrj(ji,jj) = ( zenv(ji ,ijp1) - zenv(ji,jj) ) / ( zenv(ji ,ijp1) + zenv(ji,jj) ) 2038 END IF 2039 IF( zri(ji,jj) > rn_rmax ) ztmpi1(ji ,jj ) = zenv(iip1,jj ) * zrfact 2040 IF( zri(ji,jj) < -rn_rmax ) ztmpi2(iip1,jj ) = zenv(ji ,jj ) * zrfact 2041 IF( zrj(ji,jj) > rn_rmax ) ztmpj1(ji ,jj ) = zenv(ji ,ijp1) * zrfact 2042 IF( zrj(ji,jj) < -rn_rmax ) ztmpj2(ji ,ijp1) = zenv(ji ,jj ) * zrfact 2043 END DO 2044 END DO 2045 IF( lk_mpp ) CALL mpp_max( zrmax ) ! max over the global domain 2046 ! 2047 IF(lwp)WRITE(numout,*) 'zgr_sco : iter= ',jl, ' rmax= ', zrmax 2048 ! 2049 DO jj = 1, nlcj 2050 DO ji = 1, nlci 2051 zenv(ji,jj) = MAX(zenv(ji,jj), ztmpi1(ji,jj), ztmpi2(ji,jj), ztmpj1(ji,jj), ztmpj2(ji,jj) ) 2052 END DO 2053 END DO 2054 ! apply lateral boundary condition CAUTION: keep the value when the lbc field is zero 2055 CALL lbc_lnk( zenv, 'T', 1._wp, 'no0' ) 2056 ! ! ================ ! 2057 END DO ! End loop ! 2058 ! ! ================ ! 2059 DO jj = 1, jpj 2060 DO ji = 1, jpi 2061 zenv(ji,jj) = MAX( zenv(ji,jj), rn_sbot_min ) ! set all points to avoid undefined scale value warnings 2062 END DO 2063 END DO 2064 ! 2065 ! Envelope bathymetry saved in hbatt 2066 hbatt(:,:) = zenv(:,:) 2067 IF( MINVAL( gphit(:,:) ) * MAXVAL( gphit(:,:) ) <= 0._wp ) THEN 2068 CALL ctl_warn( ' s-coordinates are tapered in vicinity of the Equator' ) 2069 DO jj = 1, jpj 2070 DO ji = 1, jpi 2071 ztaper = EXP( -(gphit(ji,jj)/8._wp)**2._wp ) 2072 hbatt(ji,jj) = rn_sbot_max * ztaper + hbatt(ji,jj) * ( 1._wp - ztaper ) 2073 END DO 2074 END DO 2075 ENDIF 2076 ! 2077 ! ! ============================== 2078 ! ! hbatu, hbatv, hbatf fields 2079 ! ! ============================== 2080 IF(lwp) THEN 2081 WRITE(numout,*) 2082 IF( .NOT.ln_wd ) THEN 2083 WRITE(numout,*) ' zgr_sco: minimum depth of the envelop topography set to : ', rn_sbot_min 2084 ELSE 2085 WRITE(numout,*) ' zgr_sco: minimum positive depth of the envelop topography set to : ', rn_sbot_min 2086 WRITE(numout,*) ' zgr_sco: minimum negative depth of the envelop topography set to : ', -rn_wdld 2087 ENDIF 2088 ENDIF 2089 hbatu(:,:) = rn_sbot_min 2090 hbatv(:,:) = rn_sbot_min 2091 hbatf(:,:) = rn_sbot_min 2092 DO jj = 1, jpjm1 2093 DO ji = 1, jpim1 ! NO vector opt. 2094 hbatu(ji,jj) = 0.50_wp * ( hbatt(ji ,jj) + hbatt(ji+1,jj ) ) 2095 hbatv(ji,jj) = 0.50_wp * ( hbatt(ji ,jj) + hbatt(ji ,jj+1) ) 2096 hbatf(ji,jj) = 0.25_wp * ( hbatt(ji ,jj) + hbatt(ji ,jj+1) & 2097 & + hbatt(ji+1,jj) + hbatt(ji+1,jj+1) ) 2098 END DO 2099 END DO 2100 2101 IF( ln_wd ) THEN !avoid the zero depth on T- (U-,V-,F-) points 2102 DO jj = 1, jpj 2103 DO ji = 1, jpi 2104 IF(ABS(hbatt(ji,jj)) < rn_wdmin1) & 2105 & hbatt(ji,jj) = SIGN(1._wp, hbatt(ji,jj)) * rn_wdmin1 2106 IF(ABS(hbatu(ji,jj)) < rn_wdmin1) & 2107 & hbatu(ji,jj) = SIGN(1._wp, hbatu(ji,jj)) * rn_wdmin1 2108 IF(ABS(hbatv(ji,jj)) < rn_wdmin1) & 2109 & hbatv(ji,jj) = SIGN(1._wp, hbatv(ji,jj)) * rn_wdmin1 2110 IF(ABS(hbatf(ji,jj)) < rn_wdmin1) & 2111 & hbatf(ji,jj) = SIGN(1._wp, hbatf(ji,jj)) * rn_wdmin1 2112 END DO 2113 END DO 2114 END IF 2115 ! 2116 ! Apply lateral boundary condition 2117 !!gm ! CAUTION: retain non zero value in the initial file this should be OK for orca cfg, not for EEL 2118 zhbat(:,:) = hbatu(:,:) ; CALL lbc_lnk( hbatu, 'U', 1._wp ) 2119 DO jj = 1, jpj 2120 DO ji = 1, jpi 2121 IF( hbatu(ji,jj) == 0._wp ) THEN 2122 !No worries about the following line when ln_wd == .true. 2123 IF( zhbat(ji,jj) == 0._wp ) hbatu(ji,jj) = rn_sbot_min 2124 IF( zhbat(ji,jj) /= 0._wp ) hbatu(ji,jj) = zhbat(ji,jj) 2125 ENDIF 2126 END DO 2127 END DO 2128 zhbat(:,:) = hbatv(:,:) ; CALL lbc_lnk( hbatv, 'V', 1._wp ) 2129 DO jj = 1, jpj 2130 DO ji = 1, jpi 2131 IF( hbatv(ji,jj) == 0._wp ) THEN 2132 IF( zhbat(ji,jj) == 0._wp ) hbatv(ji,jj) = rn_sbot_min 2133 IF( zhbat(ji,jj) /= 0._wp ) hbatv(ji,jj) = zhbat(ji,jj) 2134 ENDIF 2135 END DO 2136 END DO 2137 zhbat(:,:) = hbatf(:,:) ; CALL lbc_lnk( hbatf, 'F', 1._wp ) 2138 DO jj = 1, jpj 2139 DO ji = 1, jpi 2140 IF( hbatf(ji,jj) == 0._wp ) THEN 2141 IF( zhbat(ji,jj) == 0._wp ) hbatf(ji,jj) = rn_sbot_min 2142 IF( zhbat(ji,jj) /= 0._wp ) hbatf(ji,jj) = zhbat(ji,jj) 2143 ENDIF 2144 END DO 2145 END DO 2146 2147 !!bug: key_helsinki a verifer 2148 IF( .NOT.ln_wd ) THEN 2149 hift(:,:) = MIN( hift(:,:), hbatt(:,:) ) 2150 hifu(:,:) = MIN( hifu(:,:), hbatu(:,:) ) 2151 hifv(:,:) = MIN( hifv(:,:), hbatv(:,:) ) 2152 hiff(:,:) = MIN( hiff(:,:), hbatf(:,:) ) 2153 END IF 2154 2155 IF( nprint == 1 .AND. lwp ) THEN 2156 WRITE(numout,*) ' MAX val hif t ', MAXVAL( hift (:,:) ), ' f ', MAXVAL( hiff (:,:) ), & 2157 & ' u ', MAXVAL( hifu (:,:) ), ' v ', MAXVAL( hifv (:,:) ) 2158 WRITE(numout,*) ' MIN val hif t ', MINVAL( hift (:,:) ), ' f ', MINVAL( hiff (:,:) ), & 2159 & ' u ', MINVAL( hifu (:,:) ), ' v ', MINVAL( hifv (:,:) ) 2160 WRITE(numout,*) ' MAX val hbat t ', MAXVAL( hbatt(:,:) ), ' f ', MAXVAL( hbatf(:,:) ), & 2161 & ' u ', MAXVAL( hbatu(:,:) ), ' v ', MAXVAL( hbatv(:,:) ) 2162 WRITE(numout,*) ' MIN val hbat t ', MINVAL( hbatt(:,:) ), ' f ', MINVAL( hbatf(:,:) ), & 2163 & ' u ', MINVAL( hbatu(:,:) ), ' v ', MINVAL( hbatv(:,:) ) 2164 ENDIF 2165 !! helsinki 2166 2167 ! ! ======================= 2168 ! ! s-ccordinate fields (gdep., e3.) 2169 ! ! ======================= 2170 ! 2171 ! non-dimensional "sigma" for model level depth at w- and t-levels 2172 2173 2174 !======================================================================== 2175 ! Song and Haidvogel 1994 (ln_s_sh94=T) 2176 ! Siddorn and Furner 2012 (ln_sf12=T) 2177 ! or tanh function (both false) 2178 !======================================================================== 2179 IF ( ln_s_sh94 ) THEN 2180 CALL s_sh94() 2181 ELSE IF ( ln_s_sf12 ) THEN 2182 CALL s_sf12() 2183 ELSE 2184 CALL s_tanh() 2185 ENDIF 2186 2187 CALL lbc_lnk( e3t_0 , 'T', 1._wp ) 2188 CALL lbc_lnk( e3u_0 , 'U', 1._wp ) 2189 CALL lbc_lnk( e3v_0 , 'V', 1._wp ) 2190 CALL lbc_lnk( e3f_0 , 'F', 1._wp ) 2191 CALL lbc_lnk( e3w_0 , 'W', 1._wp ) 2192 CALL lbc_lnk( e3uw_0, 'U', 1._wp ) 2193 CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 2194 ! 2195 IF( .NOT.ln_wd ) THEN 2196 WHERE( e3t_0 (:,:,:) == 0._wp ) e3t_0 (:,:,:) = 1._wp 2197 WHERE( e3u_0 (:,:,:) == 0._wp ) e3u_0 (:,:,:) = 1._wp 2198 WHERE( e3v_0 (:,:,:) == 0._wp ) e3v_0 (:,:,:) = 1._wp 2199 WHERE( e3f_0 (:,:,:) == 0._wp ) e3f_0 (:,:,:) = 1._wp 2200 WHERE( e3w_0 (:,:,:) == 0._wp ) e3w_0 (:,:,:) = 1._wp 2201 WHERE( e3uw_0(:,:,:) == 0._wp ) e3uw_0(:,:,:) = 1._wp 2202 WHERE( e3vw_0(:,:,:) == 0._wp ) e3vw_0(:,:,:) = 1._wp 2203 END IF 2204 2205 #if defined key_agrif 2206 IF( .NOT. Agrif_Root() ) THEN ! Ensure meaningful vertical scale factors in ghost lines/columns 2207 IF( nbondi == -1 .OR. nbondi == 2 ) e3u_0( 1 , : ,:) = e3u_0( 2 , : ,:) 2208 IF( nbondi == 1 .OR. nbondi == 2 ) e3u_0(nlci-1, : ,:) = e3u_0(nlci-2, : ,:) 2209 IF( nbondj == -1 .OR. nbondj == 2 ) e3v_0( : , 1 ,:) = e3v_0( : , 2 ,:) 2210 IF( nbondj == 1 .OR. nbondj == 2 ) e3v_0( : ,nlcj-1,:) = e3v_0( : ,nlcj-2,:) 2211 ENDIF 2212 #endif 2213 2214 !!gm I don't like that HERE we are supposed to set the reference coordinate (i.e. _0 arrays) 2215 !!gm and only that !!!!! 2216 !!gm THIS should be removed from here ! 2217 gdept_n(:,:,:) = gdept_0(:,:,:) 2218 gdepw_n(:,:,:) = gdepw_0(:,:,:) 2219 gde3w_n(:,:,:) = gde3w_0(:,:,:) 2220 e3t_n (:,:,:) = e3t_0 (:,:,:) 2221 e3u_n (:,:,:) = e3u_0 (:,:,:) 2222 e3v_n (:,:,:) = e3v_0 (:,:,:) 2223 e3f_n (:,:,:) = e3f_0 (:,:,:) 2224 e3w_n (:,:,:) = e3w_0 (:,:,:) 2225 e3uw_n (:,:,:) = e3uw_0 (:,:,:) 2226 e3vw_n (:,:,:) = e3vw_0 (:,:,:) 2227 !!gm and obviously in the following, use the _0 arrays until the end of this subroutine 2228 !! gm end 2229 !! 2230 ! HYBRID : 2231 DO jj = 1, jpj 2232 DO ji = 1, jpi 2233 DO jk = 1, jpkm1 2234 IF( scobot(ji,jj) >= gdept_n(ji,jj,jk) ) mbathy(ji,jj) = MAX( 2, jk ) 2235 END DO 2236 IF( ln_wd ) THEN 2237 IF( scobot(ji,jj) <= -(rn_wdld - rn_wdmin2)) THEN 2238 mbathy(ji,jj) = 0 2239 ELSEIF(scobot(ji,jj) <= rn_wdmin1) THEN 2240 mbathy(ji,jj) = 2 2241 ENDIF 2242 ELSE 2243 IF( scobot(ji,jj) == 0._wp ) mbathy(ji,jj) = 0 2244 ENDIF 2245 END DO 2246 END DO 2247 IF( nprint == 1 .AND. lwp ) WRITE(numout,*) ' MIN val mbathy h90 ', MINVAL( mbathy(:,:) ), & 2248 & ' MAX ', MAXVAL( mbathy(:,:) ) 2249 2250 IF( nprint == 1 .AND. lwp ) THEN ! min max values over the local domain 2251 WRITE(numout,*) ' MIN val mbathy ', MINVAL( mbathy(:,:) ), ' MAX ', MAXVAL( mbathy(:,:) ) 2252 WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & 2253 & ' w ', MINVAL( gdepw_0(:,:,:) ), '3w ' , MINVAL( gde3w_0(:,:,:) ) 2254 WRITE(numout,*) ' MIN val e3 t ', MINVAL( e3t_0 (:,:,:) ), ' f ' , MINVAL( e3f_0 (:,:,:) ), & 2255 & ' u ', MINVAL( e3u_0 (:,:,:) ), ' u ' , MINVAL( e3v_0 (:,:,:) ), & 2256 & ' uw', MINVAL( e3uw_0 (:,:,:) ), ' vw' , MINVAL( e3vw_0 (:,:,:) ), & 2257 & ' w ', MINVAL( e3w_0 (:,:,:) ) 2258 2259 WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ), & 2260 & ' w ', MAXVAL( gdepw_0(:,:,:) ), '3w ' , MAXVAL( gde3w_0(:,:,:) ) 2261 WRITE(numout,*) ' MAX val e3 t ', MAXVAL( e3t_0 (:,:,:) ), ' f ' , MAXVAL( e3f_0 (:,:,:) ), & 2262 & ' u ', MAXVAL( e3u_0 (:,:,:) ), ' u ' , MAXVAL( e3v_0 (:,:,:) ), & 2263 & ' uw', MAXVAL( e3uw_0 (:,:,:) ), ' vw' , MAXVAL( e3vw_0 (:,:,:) ), & 2264 & ' w ', MAXVAL( e3w_0 (:,:,:) ) 2265 ENDIF 2266 ! END DO 2267 IF(lwp) THEN ! selected vertical profiles 2268 WRITE(numout,*) 2269 WRITE(numout,*) ' domzgr: vertical coordinates : point (1,1,k) bathy = ', bathy(1,1), hbatt(1,1) 2270 WRITE(numout,*) ' ~~~~~~ --------------------' 2271 WRITE(numout,"(9x,' level gdept_0 gdepw_0 e3t_0 e3w_0')") 2272 WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(1,1,jk), gdepw_0(1,1,jk), & 2273 & e3t_0 (1,1,jk) , e3w_0 (1,1,jk) , jk=1,jpk ) 2274 DO jj = mj0(20), mj1(20) 2275 DO ji = mi0(20), mi1(20) 2276 WRITE(numout,*) 2277 WRITE(numout,*) ' domzgr: vertical coordinates : point (20,20,k) bathy = ', bathy(ji,jj), hbatt(ji,jj) 2278 WRITE(numout,*) ' ~~~~~~ --------------------' 2279 WRITE(numout,"(9x,' level gdept_0 gdepw_0 e3t_0 e3w_0')") 2280 WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(ji,jj,jk), gdepw_0(ji,jj,jk), & 2281 & e3t_0 (ji,jj,jk) , e3w_0 (ji,jj,jk) , jk=1,jpk ) 2282 END DO 2283 END DO 2284 DO jj = mj0(74), mj1(74) 2285 DO ji = mi0(100), mi1(100) 2286 WRITE(numout,*) 2287 WRITE(numout,*) ' domzgr: vertical coordinates : point (100,74,k) bathy = ', bathy(ji,jj), hbatt(ji,jj) 2288 WRITE(numout,*) ' ~~~~~~ --------------------' 2289 WRITE(numout,"(9x,' level gdept_0 gdepw_0 e3t_0 e3w_0')") 2290 WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(ji,jj,jk), gdepw_0(ji,jj,jk), & 2291 & e3t_0 (ji,jj,jk) , e3w_0 (ji,jj,jk) , jk=1,jpk ) 2292 END DO 2293 END DO 2294 ENDIF 2295 ! 2296 !================================================================================ 2297 ! check the coordinate makes sense 2298 !================================================================================ 2299 DO ji = 1, jpi 2300 DO jj = 1, jpj 2301 ! 2302 IF( hbatt(ji,jj) > 0._wp) THEN 2303 DO jk = 1, mbathy(ji,jj) 2304 ! check coordinate is monotonically increasing 2305 IF (e3w_n(ji,jj,jk) <= 0._wp .OR. e3t_n(ji,jj,jk) <= 0._wp ) THEN 2306 WRITE(ctmp1,*) 'ERROR zgr_sco : e3w or e3t =< 0 at point (i,j,k)= ', ji, jj, jk 2307 WRITE(numout,*) 'ERROR zgr_sco : e3w or e3t =< 0 at point (i,j,k)= ', ji, jj, jk 2308 WRITE(numout,*) 'e3w',e3w_n(ji,jj,:) 2309 WRITE(numout,*) 'e3t',e3t_n(ji,jj,:) 2310 CALL ctl_stop( ctmp1 ) 2311 ENDIF 2312 ! and check it has never gone negative 2313 IF( gdepw_n(ji,jj,jk) < 0._wp .OR. gdept_n(ji,jj,jk) < 0._wp ) THEN 2314 WRITE(ctmp1,*) 'ERROR zgr_sco : gdepw or gdept =< 0 at point (i,j,k)= ', ji, jj, jk 2315 WRITE(numout,*) 'ERROR zgr_sco : gdepw or gdept =< 0 at point (i,j,k)= ', ji, jj, jk 2316 WRITE(numout,*) 'gdepw',gdepw_n(ji,jj,:) 2317 WRITE(numout,*) 'gdept',gdept_n(ji,jj,:) 2318 CALL ctl_stop( ctmp1 ) 2319 ENDIF 2320 ! and check it never exceeds the total depth 2321 IF( gdepw_n(ji,jj,jk) > hbatt(ji,jj) ) THEN 2322 WRITE(ctmp1,*) 'ERROR zgr_sco : gdepw > hbatt at point (i,j,k)= ', ji, jj, jk 2323 WRITE(numout,*) 'ERROR zgr_sco : gdepw > hbatt at point (i,j,k)= ', ji, jj, jk 2324 WRITE(numout,*) 'gdepw',gdepw_n(ji,jj,:) 2325 CALL ctl_stop( ctmp1 ) 2326 ENDIF 2327 END DO 2328 ! 2329 DO jk = 1, mbathy(ji,jj)-1 2330 ! and check it never exceeds the total depth 2331 IF( gdept_n(ji,jj,jk) > hbatt(ji,jj) ) THEN 2332 WRITE(ctmp1,*) 'ERROR zgr_sco : gdept > hbatt at point (i,j,k)= ', ji, jj, jk 2333 WRITE(numout,*) 'ERROR zgr_sco : gdept > hbatt at point (i,j,k)= ', ji, jj, jk 2334 WRITE(numout,*) 'gdept',gdept_n(ji,jj,:) 2335 CALL ctl_stop( ctmp1 ) 2336 ENDIF 2337 END DO 2338 ENDIF 2339 END DO 2340 END DO 2341 ! 2342 CALL wrk_dealloc( jpi, jpj, zenv, ztmp, zmsk, zri, zrj, zhbat , ztmpi1, ztmpi2, ztmpj1, ztmpj2 ) 2343 ! 2344 IF( nn_timing == 1 ) CALL timing_stop('zgr_sco') 2345 ! 2346 END SUBROUTINE zgr_sco 2347 2348 2349 SUBROUTINE s_sh94() 2350 !!---------------------------------------------------------------------- 2351 !! *** ROUTINE s_sh94 *** 2352 !! 2353 !! ** Purpose : stretch the s-coordinate system 2354 !! 2355 !! ** Method : s-coordinate stretch using the Song and Haidvogel 1994 2356 !! mixed S/sigma coordinate 2357 !! 2358 !! Reference : Song and Haidvogel 1994. 2359 !!---------------------------------------------------------------------- 2360 INTEGER :: ji, jj, jk ! dummy loop argument 2361 REAL(wp) :: zcoeft, zcoefw ! temporary scalars 2362 REAL(wp) :: ztmpu, ztmpv, ztmpf 2363 REAL(wp) :: ztmpu1, ztmpv1, ztmpf1 2364 ! 2365 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_gsigw3, z_gsigt3, z_gsi3w3 2366 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 2367 !!---------------------------------------------------------------------- 2368 2369 CALL wrk_alloc( jpi,jpj,jpk, z_gsigw3, z_gsigt3, z_gsi3w3 ) 2370 CALL wrk_alloc( jpi,jpj,jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) 2371 2372 z_gsigw3 = 0._wp ; z_gsigt3 = 0._wp ; z_gsi3w3 = 0._wp 2373 z_esigt3 = 0._wp ; z_esigw3 = 0._wp 2374 z_esigtu3 = 0._wp ; z_esigtv3 = 0._wp ; z_esigtf3 = 0._wp 2375 z_esigwu3 = 0._wp ; z_esigwv3 = 0._wp 2376 ! 2377 DO ji = 1, jpi 2378 DO jj = 1, jpj 2379 ! 2380 IF( hbatt(ji,jj) > rn_hc ) THEN !deep water, stretched sigma 2381 DO jk = 1, jpk 2382 z_gsigw3(ji,jj,jk) = -fssig1( REAL(jk,wp)-0.5_wp, rn_bb ) 2383 z_gsigt3(ji,jj,jk) = -fssig1( REAL(jk,wp) , rn_bb ) 2384 END DO 2385 ELSE ! shallow water, uniform sigma 2386 DO jk = 1, jpk 2387 z_gsigw3(ji,jj,jk) = REAL(jk-1,wp) / REAL(jpk-1,wp) 2388 z_gsigt3(ji,jj,jk) = ( REAL(jk-1,wp) + 0.5_wp ) / REAL(jpk-1,wp) 2389 END DO 2390 ENDIF 2391 ! 2392 DO jk = 1, jpkm1 2393 z_esigt3(ji,jj,jk ) = z_gsigw3(ji,jj,jk+1) - z_gsigw3(ji,jj,jk) 2394 z_esigw3(ji,jj,jk+1) = z_gsigt3(ji,jj,jk+1) - z_gsigt3(ji,jj,jk) 2395 END DO 2396 z_esigw3(ji,jj,1 ) = 2._wp * ( z_gsigt3(ji,jj,1 ) - z_gsigw3(ji,jj,1 ) ) 2397 z_esigt3(ji,jj,jpk) = 2._wp * ( z_gsigt3(ji,jj,jpk) - z_gsigw3(ji,jj,jpk) ) 2398 ! 2399 ! Coefficients for vertical depth as the sum of e3w scale factors 2400 z_gsi3w3(ji,jj,1) = 0.5_wp * z_esigw3(ji,jj,1) 2401 DO jk = 2, jpk 2402 z_gsi3w3(ji,jj,jk) = z_gsi3w3(ji,jj,jk-1) + z_esigw3(ji,jj,jk) 2403 END DO 2404 ! 2405 DO jk = 1, jpk 2406 zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 2407 zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 2408 gdept_0(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigt3(ji,jj,jk)+rn_hc*zcoeft ) 2409 gdepw_0(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigw3(ji,jj,jk)+rn_hc*zcoefw ) 2410 gde3w_0(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsi3w3(ji,jj,jk)+rn_hc*zcoeft ) 2411 END DO 2412 ! 2413 END DO ! for all jj's 2414 END DO ! for all ji's 2415 2416 DO ji = 1, jpim1 2417 DO jj = 1, jpjm1 2418 ! extended for Wetting/Drying case 2419 ztmpu = hbatt(ji,jj)+hbatt(ji+1,jj) 2420 ztmpv = hbatt(ji,jj)+hbatt(ji,jj+1) 2421 ztmpf = hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) 2422 ztmpu1 = hbatt(ji,jj)*hbatt(ji+1,jj) 2423 ztmpv1 = hbatt(ji,jj)*hbatt(ji,jj+1) 2424 ztmpf1 = MIN(hbatt(ji,jj), hbatt(ji+1,jj), hbatt(ji,jj+1), hbatt(ji+1,jj+1)) * & 2425 & MAX(hbatt(ji,jj), hbatt(ji+1,jj), hbatt(ji,jj+1), hbatt(ji+1,jj+1)) 2426 DO jk = 1, jpk 2427 IF( ln_wd .AND. (ztmpu1 < 0._wp.OR.ABS(ztmpu) < rn_wdmin1) ) THEN 2428 z_esigtu3(ji,jj,jk) = 0.5_wp * ( z_esigt3(ji,jj,jk) + z_esigt3(ji+1,jj,jk) ) 2429 z_esigwu3(ji,jj,jk) = 0.5_wp * ( z_esigw3(ji,jj,jk) + z_esigw3(ji+1,jj,jk) ) 2430 ELSE 2431 z_esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj,jk) ) & 2432 & / ztmpu 2433 z_esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigw3(ji+1,jj,jk) ) & 2434 & / ztmpu 2435 END IF 2436 2437 IF( ln_wd .AND. (ztmpv1 < 0._wp.OR.ABS(ztmpv) < rn_wdmin1) ) THEN 2438 z_esigtv3(ji,jj,jk) = 0.5_wp * ( z_esigt3(ji,jj,jk) + z_esigt3(ji,jj+1,jk) ) 2439 z_esigwv3(ji,jj,jk) = 0.5_wp * ( z_esigw3(ji,jj,jk) + z_esigw3(ji,jj+1,jk) ) 2440 ELSE 2441 z_esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigt3(ji,jj+1,jk) ) & 2442 & / ztmpv 2443 z_esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigw3(ji,jj+1,jk) ) & 2444 & / ztmpv 2445 END IF 2446 2447 IF( ln_wd .AND. (ztmpf1 < 0._wp.OR.ABS(ztmpf) < rn_wdmin1) ) THEN 2448 z_esigtf3(ji,jj,jk) = 0.25_wp * ( z_esigt3(ji,jj ,jk) + z_esigt3(ji+1,jj ,jk) & 2449 & + z_esigt3(ji,jj+1,jk) + z_esigt3(ji+1,jj+1,jk) ) 2450 ELSE 2451 z_esigtf3(ji,jj,jk) = ( hbatt(ji ,jj )*z_esigt3(ji ,jj ,jk) & 2452 & + hbatt(ji+1,jj )*z_esigt3(ji+1,jj ,jk) & 2453 & + hbatt(ji ,jj+1)*z_esigt3(ji ,jj+1,jk) & 2454 & + hbatt(ji+1,jj+1)*z_esigt3(ji+1,jj+1,jk) ) / ztmpf 2455 END IF 2456 2457 ! 2458 e3t_0(ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigt3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 2459 e3u_0(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigtu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 2460 e3v_0(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigtv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 2461 e3f_0(ji,jj,jk) = ( (hbatf(ji,jj)-rn_hc)*z_esigtf3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 2462 ! 2463 e3w_0 (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigw3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 2464 e3uw_0(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigwu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 2465 e3vw_0(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigwv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 2466 END DO 2467 END DO 2468 END DO 2469 ! 2470 CALL wrk_dealloc( jpi,jpj,jpk, z_gsigw3, z_gsigt3, z_gsi3w3 ) 2471 CALL wrk_dealloc( jpi,jpj,jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) 2472 ! 2473 END SUBROUTINE s_sh94 2474 2475 2476 SUBROUTINE s_sf12 2477 !!---------------------------------------------------------------------- 2478 !! *** ROUTINE s_sf12 *** 2479 !! 2480 !! ** Purpose : stretch the s-coordinate system 2481 !! 2482 !! ** Method : s-coordinate stretch using the Siddorn and Furner 2012? 2483 !! mixed S/sigma/Z coordinate 2484 !! 2485 !! This method allows the maintenance of fixed surface and or 2486 !! bottom cell resolutions (cf. geopotential coordinates) 2487 !! within an analytically derived stretched S-coordinate framework. 2488 !! 2489 !! 2490 !! Reference : Siddorn and Furner 2012 (submitted Ocean modelling). 2491 !!---------------------------------------------------------------------- 2492 INTEGER :: ji, jj, jk ! dummy loop argument 2493 REAL(wp) :: zsmth ! smoothing around critical depth 2494 REAL(wp) :: zzs, zzb ! Surface and bottom cell thickness in sigma space 2495 REAL(wp) :: ztmpu, ztmpv, ztmpf 2496 REAL(wp) :: ztmpu1, ztmpv1, ztmpf1 2497 ! 2498 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_gsigw3, z_gsigt3, z_gsi3w3 2499 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 2500 !!---------------------------------------------------------------------- 2501 ! 2502 CALL wrk_alloc( jpi, jpj, jpk, z_gsigw3, z_gsigt3, z_gsi3w3 ) 2503 CALL wrk_alloc( jpi, jpj, jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) 2504 2505 z_gsigw3 = 0._wp ; z_gsigt3 = 0._wp ; z_gsi3w3 = 0._wp 2506 z_esigt3 = 0._wp ; z_esigw3 = 0._wp 2507 z_esigtu3 = 0._wp ; z_esigtv3 = 0._wp ; z_esigtf3 = 0._wp 2508 z_esigwu3 = 0._wp ; z_esigwv3 = 0._wp 2509 2510 DO ji = 1, jpi 2511 DO jj = 1, jpj 2512 2513 IF (hbatt(ji,jj)>rn_hc) THEN !deep water, stretched sigma 2514 2515 zzb = hbatt(ji,jj)*rn_zb_a + rn_zb_b ! this forces a linear bottom cell depth relationship with H,. 2516 ! could be changed by users but care must be taken to do so carefully 2517 zzb = 1.0_wp-(zzb/hbatt(ji,jj)) 2518 2519 zzs = rn_zs / hbatt(ji,jj) 2520 2521 IF (rn_efold /= 0.0_wp) THEN 2522 zsmth = tanh( (hbatt(ji,jj)- rn_hc ) / rn_efold ) 2523 ELSE 2524 zsmth = 1.0_wp 2525 ENDIF 2526 2527 DO jk = 1, jpk 2528 z_gsigw3(ji,jj,jk) = REAL(jk-1,wp) /REAL(jpk-1,wp) 2529 z_gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5_wp)/REAL(jpk-1,wp) 2530 ENDDO 2531 z_gsigw3(ji,jj,:) = fgamma( z_gsigw3(ji,jj,:), zzb, zzs, zsmth ) 2532 z_gsigt3(ji,jj,:) = fgamma( z_gsigt3(ji,jj,:), zzb, zzs, zsmth ) 2533 2534 ELSE IF (ln_sigcrit) THEN ! shallow water, uniform sigma 2535 2536 DO jk = 1, jpk 2537 z_gsigw3(ji,jj,jk) = REAL(jk-1,wp) /REAL(jpk-1,wp) 2538 z_gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5)/REAL(jpk-1,wp) 2539 END DO 2540 2541 ELSE ! shallow water, z coordinates 2542 2543 DO jk = 1, jpk 2544 z_gsigw3(ji,jj,jk) = REAL(jk-1,wp) /REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) 2545 z_gsigt3(ji,jj,jk) = (REAL(jk-1,wp)+0.5_wp)/REAL(jpk-1,wp)*(rn_hc/hbatt(ji,jj)) 2546 END DO 2547 2548 ENDIF 2549 2550 DO jk = 1, jpkm1 2551 z_esigt3(ji,jj,jk) = z_gsigw3(ji,jj,jk+1) - z_gsigw3(ji,jj,jk) 2552 z_esigw3(ji,jj,jk+1) = z_gsigt3(ji,jj,jk+1) - z_gsigt3(ji,jj,jk) 2553 END DO 2554 z_esigw3(ji,jj,1 ) = 2.0_wp * (z_gsigt3(ji,jj,1 ) - z_gsigw3(ji,jj,1 )) 2555 z_esigt3(ji,jj,jpk) = 2.0_wp * (z_gsigt3(ji,jj,jpk) - z_gsigw3(ji,jj,jpk)) 2556 2557 ! Coefficients for vertical depth as the sum of e3w scale factors 2558 z_gsi3w3(ji,jj,1) = 0.5 * z_esigw3(ji,jj,1) 2559 DO jk = 2, jpk 2560 z_gsi3w3(ji,jj,jk) = z_gsi3w3(ji,jj,jk-1) + z_esigw3(ji,jj,jk) 2561 END DO 2562 2563 DO jk = 1, jpk 2564 gdept_0(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigt3(ji,jj,jk) 2565 gdepw_0(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigw3(ji,jj,jk) 2566 gde3w_0(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsi3w3(ji,jj,jk) 2567 END DO 2568 2569 ENDDO ! for all jj's 2570 ENDDO ! for all ji's 2571 2572 DO ji=1,jpi-1 2573 DO jj=1,jpj-1 2574 2575 ! extend to suit for Wetting/Drying case 2576 ztmpu = hbatt(ji,jj)+hbatt(ji+1,jj) 2577 ztmpv = hbatt(ji,jj)+hbatt(ji,jj+1) 2578 ztmpf = hbatt(ji,jj)+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) 2579 ztmpu1 = hbatt(ji,jj)*hbatt(ji+1,jj) 2580 ztmpv1 = hbatt(ji,jj)*hbatt(ji,jj+1) 2581 ztmpf1 = MIN(hbatt(ji,jj), hbatt(ji+1,jj), hbatt(ji,jj+1), hbatt(ji+1,jj+1)) * & 2582 & MAX(hbatt(ji,jj), hbatt(ji+1,jj), hbatt(ji,jj+1), hbatt(ji+1,jj+1)) 2583 DO jk = 1, jpk 2584 IF( ln_wd .AND. (ztmpu1 < 0._wp.OR.ABS(ztmpu) < rn_wdmin1) ) THEN 2585 z_esigtu3(ji,jj,jk) = 0.5_wp * ( z_esigt3(ji,jj,jk) + z_esigt3(ji+1,jj,jk) ) 2586 z_esigwu3(ji,jj,jk) = 0.5_wp * ( z_esigw3(ji,jj,jk) + z_esigw3(ji+1,jj,jk) ) 2587 ELSE 2588 z_esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj,jk) ) & 2589 & / ztmpu 2590 z_esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigw3(ji+1,jj,jk) ) & 2591 & / ztmpu 2592 END IF 2593 2594 IF( ln_wd .AND. (ztmpv1 < 0._wp.OR.ABS(ztmpv) < rn_wdmin1) ) THEN 2595 z_esigtv3(ji,jj,jk) = 0.5_wp * ( z_esigt3(ji,jj,jk) + z_esigt3(ji,jj+1,jk) ) 2596 z_esigwv3(ji,jj,jk) = 0.5_wp * ( z_esigw3(ji,jj,jk) + z_esigw3(ji,jj+1,jk) ) 2597 ELSE 2598 z_esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigt3(ji,jj+1,jk) ) & 2599 & / ztmpv 2600 z_esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigw3(ji,jj+1,jk) ) & 2601 & / ztmpv 2602 END IF 2603 2604 IF( ln_wd .AND. (ztmpf1 < 0._wp.OR.ABS(ztmpf) < rn_wdmin1) ) THEN 2605 z_esigtf3(ji,jj,jk) = 0.25_wp * ( z_esigt3(ji,jj,jk) + z_esigt3(ji+1,jj,jk) & 2606 & + z_esigt3(ji,jj+1,jk) + z_esigt3(ji+1,jj+1,jk) ) 2607 ELSE 2608 z_esigtf3(ji,jj,jk) = ( hbatt(ji ,jj )*z_esigt3(ji ,jj ,jk) & 2609 & + hbatt(ji+1,jj )*z_esigt3(ji+1,jj ,jk) & 2610 & + hbatt(ji ,jj+1)*z_esigt3(ji ,jj+1,jk) & 2611 & + hbatt(ji+1,jj+1)*z_esigt3(ji+1,jj+1,jk) ) / ztmpf 2612 END IF 2613 2614 ! Code prior to wetting and drying option (for reference) 2615 !z_esigtu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigt3(ji+1,jj,jk) ) & 2616 ! /( hbatt(ji,jj)+hbatt(ji+1,jj) ) 2617 ! 2618 !z_esigwu3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji+1,jj)*z_esigw3(ji+1,jj,jk) ) & 2619 ! /( hbatt(ji,jj)+hbatt(ji+1,jj) ) 2620 ! 2621 !z_esigtv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigt3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigt3(ji,jj+1,jk) ) & 2622 ! /( hbatt(ji,jj)+hbatt(ji,jj+1) ) 2623 ! 2624 !z_esigwv3(ji,jj,jk) = ( hbatt(ji,jj)*z_esigw3(ji,jj,jk)+hbatt(ji,jj+1)*z_esigw3(ji,jj+1,jk) ) & 2625 ! /( hbatt(ji,jj)+hbatt(ji,jj+1) ) 2626 ! 2627 !z_esigtf3(ji,jj,jk) = ( hbatt(ji ,jj )*z_esigt3(ji ,jj ,jk) & 2628 ! & +hbatt(ji+1,jj )*z_esigt3(ji+1,jj ,jk) & 2629 ! +hbatt(ji ,jj+1)*z_esigt3(ji ,jj+1,jk) & 2630 ! & +hbatt(ji+1,jj+1)*z_esigt3(ji+1,jj+1,jk) ) & 2631 ! /( hbatt(ji ,jj )+hbatt(ji+1,jj)+hbatt(ji,jj+1)+hbatt(ji+1,jj+1) ) 2632 2633 e3t_0(ji,jj,jk)=(scosrf(ji,jj)+hbatt(ji,jj))*z_esigt3(ji,jj,jk) 2634 e3u_0(ji,jj,jk)=(scosrf(ji,jj)+hbatu(ji,jj))*z_esigtu3(ji,jj,jk) 2635 e3v_0(ji,jj,jk)=(scosrf(ji,jj)+hbatv(ji,jj))*z_esigtv3(ji,jj,jk) 2636 e3f_0(ji,jj,jk)=(scosrf(ji,jj)+hbatf(ji,jj))*z_esigtf3(ji,jj,jk) 2637 ! 2638 e3w_0 (ji,jj,jk)=hbatt(ji,jj)*z_esigw3(ji,jj,jk) 2639 e3uw_0(ji,jj,jk)=hbatu(ji,jj)*z_esigwu3(ji,jj,jk) 2640 e3vw_0(ji,jj,jk)=hbatv(ji,jj)*z_esigwv3(ji,jj,jk) 2641 END DO 2642 2643 ENDDO 2644 ENDDO 2645 ! 2646 CALL lbc_lnk(e3t_0 ,'T',1.) ; CALL lbc_lnk(e3u_0 ,'T',1.) 2647 CALL lbc_lnk(e3v_0 ,'T',1.) ; CALL lbc_lnk(e3f_0 ,'T',1.) 2648 CALL lbc_lnk(e3w_0 ,'T',1.) 2649 CALL lbc_lnk(e3uw_0,'T',1.) ; CALL lbc_lnk(e3vw_0,'T',1.) 2650 ! 2651 CALL wrk_dealloc( jpi,jpj,jpk, z_gsigw3, z_gsigt3, z_gsi3w3 ) 2652 CALL wrk_dealloc( jpi,jpj,jpk, z_esigt3, z_esigw3, z_esigtu3, z_esigtv3, z_esigtf3, z_esigwu3, z_esigwv3 ) 2653 ! 2654 END SUBROUTINE s_sf12 2655 2656 2657 SUBROUTINE s_tanh() 2658 !!---------------------------------------------------------------------- 2659 !! *** ROUTINE s_tanh*** 2660 !! 2661 !! ** Purpose : stretch the s-coordinate system 2662 !! 2663 !! ** Method : s-coordinate stretch 2664 !! 2665 !! Reference : Madec, Lott, Delecluse and Crepon, 1996. JPO, 26, 1393-1408. 2666 !!---------------------------------------------------------------------- 2667 INTEGER :: ji, jj, jk ! dummy loop argument 2668 REAL(wp) :: zcoeft, zcoefw ! temporary scalars 2669 REAL(wp), POINTER, DIMENSION(:) :: z_gsigw, z_gsigt, z_gsi3w 2670 REAL(wp), POINTER, DIMENSION(:) :: z_esigt, z_esigw 2671 !!---------------------------------------------------------------------- 2672 2673 CALL wrk_alloc( jpk, z_gsigw, z_gsigt, z_gsi3w ) 2674 CALL wrk_alloc( jpk, z_esigt, z_esigw ) 2675 2676 z_gsigw = 0._wp ; z_gsigt = 0._wp ; z_gsi3w = 0._wp 2677 z_esigt = 0._wp ; z_esigw = 0._wp 2678 2679 DO jk = 1, jpk 2680 z_gsigw(jk) = -fssig( REAL(jk,wp)-0.5_wp ) 2681 z_gsigt(jk) = -fssig( REAL(jk,wp) ) 2682 END DO 2683 IF( nprint == 1 .AND. lwp ) WRITE(numout,*) 'z_gsigw 1 jpk ', z_gsigw(1), z_gsigw(jpk) 2684 ! 2685 ! Coefficients for vertical scale factors at w-, t- levels 2686 !!gm bug : define it from analytical function, not like juste bellow.... 2687 !!gm or betteroffer the 2 possibilities.... 2688 DO jk = 1, jpkm1 2689 z_esigt(jk ) = z_gsigw(jk+1) - z_gsigw(jk) 2690 z_esigw(jk+1) = z_gsigt(jk+1) - z_gsigt(jk) 2691 END DO 2692 z_esigw( 1 ) = 2._wp * ( z_gsigt(1 ) - z_gsigw(1 ) ) 2693 z_esigt(jpk) = 2._wp * ( z_gsigt(jpk) - z_gsigw(jpk) ) 2694 ! 2695 ! Coefficients for vertical depth as the sum of e3w scale factors 2696 z_gsi3w(1) = 0.5_wp * z_esigw(1) 2697 DO jk = 2, jpk 2698 z_gsi3w(jk) = z_gsi3w(jk-1) + z_esigw(jk) 2699 END DO 2700 !!gm: depuw, depvw can be suppressed (modif in ldfslp) and depw=dep3w can be set (save 3 3D arrays) 2701 DO jk = 1, jpk 2702 zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 2703 zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 2704 gdept_0(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigt(jk) + hift(:,:)*zcoeft ) 2705 gdepw_0(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigw(jk) + hift(:,:)*zcoefw ) 2706 gde3w_0(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsi3w(jk) + hift(:,:)*zcoeft ) 2707 END DO 2708 !!gm: e3uw, e3vw can be suppressed (modif in dynzdf, dynzdf_iso, zdfbfr) (save 2 3D arrays) 2709 DO jj = 1, jpj 2710 DO ji = 1, jpi 2711 DO jk = 1, jpk 2712 e3t_0(ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigt(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 2713 e3u_0(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigt(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 2714 e3v_0(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigt(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 2715 e3f_0(ji,jj,jk) = ( (hbatf(ji,jj)-hiff(ji,jj))*z_esigt(jk) + hiff(ji,jj)/REAL(jpkm1,wp) ) 2716 ! 2717 e3w_0 (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigw(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 2718 e3uw_0(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigw(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 2719 e3vw_0(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigw(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 2720 END DO 2721 END DO 2722 END DO 2723 ! 2724 CALL wrk_dealloc( jpk, z_gsigw, z_gsigt, z_gsi3w ) 2725 CALL wrk_dealloc( jpk, z_esigt, z_esigw ) 2726 ! 2727 END SUBROUTINE s_tanh 2728 2729 2730 FUNCTION fssig( pk ) RESULT( pf ) 2731 !!---------------------------------------------------------------------- 2732 !! *** ROUTINE fssig *** 2733 !! 2734 !! ** Purpose : provide the analytical function in s-coordinate 2735 !! 2736 !! ** Method : the function provide the non-dimensional position of 2737 !! T and W (i.e. between 0 and 1) 2738 !! T-points at integer values (between 1 and jpk) 2739 !! W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 2740 !!---------------------------------------------------------------------- 2741 REAL(wp), INTENT(in) :: pk ! continuous "k" coordinate 2742 REAL(wp) :: pf ! sigma value 2743 !!---------------------------------------------------------------------- 2744 ! 2745 pf = ( TANH( rn_theta * ( -(pk-0.5_wp) / REAL(jpkm1) + rn_thetb ) ) & 2746 & - TANH( rn_thetb * rn_theta ) ) & 2747 & * ( COSH( rn_theta ) & 2748 & + COSH( rn_theta * ( 2._wp * rn_thetb - 1._wp ) ) ) & 2749 & / ( 2._wp * SINH( rn_theta ) ) 2750 ! 2751 END FUNCTION fssig 2752 2753 2754 FUNCTION fssig1( pk1, pbb ) RESULT( pf1 ) 2755 !!---------------------------------------------------------------------- 2756 !! *** ROUTINE fssig1 *** 2757 !! 2758 !! ** Purpose : provide the Song and Haidvogel version of the analytical function in s-coordinate 2759 !! 2760 !! ** Method : the function provides the non-dimensional position of 2761 !! T and W (i.e. between 0 and 1) 2762 !! T-points at integer values (between 1 and jpk) 2763 !! W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 2764 !!---------------------------------------------------------------------- 2765 REAL(wp), INTENT(in) :: pk1 ! continuous "k" coordinate 2766 REAL(wp), INTENT(in) :: pbb ! Stretching coefficient 2767 REAL(wp) :: pf1 ! sigma value 2768 !!---------------------------------------------------------------------- 2769 ! 2770 IF ( rn_theta == 0 ) then ! uniform sigma 2771 pf1 = - ( pk1 - 0.5_wp ) / REAL( jpkm1 ) 2772 ELSE ! stretched sigma 2773 pf1 = ( 1._wp - pbb ) * ( SINH( rn_theta*(-(pk1-0.5_wp)/REAL(jpkm1)) ) ) / SINH( rn_theta ) & 2774 & + pbb * ( (TANH( rn_theta*( (-(pk1-0.5_wp)/REAL(jpkm1)) + 0.5_wp) ) - TANH( 0.5_wp * rn_theta ) ) & 2775 & / ( 2._wp * TANH( 0.5_wp * rn_theta ) ) ) 2776 ENDIF 2777 ! 2778 END FUNCTION fssig1 2779 2780 2781 FUNCTION fgamma( pk1, pzb, pzs, psmth) RESULT( p_gamma ) 2782 !!---------------------------------------------------------------------- 2783 !! *** ROUTINE fgamma *** 2784 !! 2785 !! ** Purpose : provide analytical function for the s-coordinate 2786 !! 2787 !! ** Method : the function provides the non-dimensional position of 2788 !! T and W (i.e. between 0 and 1) 2789 !! T-points at integer values (between 1 and jpk) 2790 !! W-points at integer values - 1/2 (between 0.5 and jpk-0.5) 2791 !! 2792 !! This method allows the maintenance of fixed surface and or 2793 !! bottom cell resolutions (cf. geopotential coordinates) 2794 !! within an analytically derived stretched S-coordinate framework. 2795 !! 2796 !! Reference : Siddorn and Furner, in prep 2797 !!---------------------------------------------------------------------- 2798 REAL(wp), INTENT(in ) :: pk1(jpk) ! continuous "k" coordinate 2799 REAL(wp) :: p_gamma(jpk) ! stretched coordinate 2800 REAL(wp), INTENT(in ) :: pzb ! Bottom box depth 2801 REAL(wp), INTENT(in ) :: pzs ! surface box depth 2802 REAL(wp), INTENT(in ) :: psmth ! Smoothing parameter 2803 ! 2804 INTEGER :: jk ! dummy loop index 2805 REAL(wp) :: za1,za2,za3 ! local scalar 2806 REAL(wp) :: zn1,zn2 ! - - 2807 REAL(wp) :: za,zb,zx ! - - 2808 !!---------------------------------------------------------------------- 2809 ! 2810 zn1 = 1._wp / REAL( jpkm1, wp ) 2811 zn2 = 1._wp - zn1 2812 ! 2813 za1 = (rn_alpha+2.0_wp)*zn1**(rn_alpha+1.0_wp)-(rn_alpha+1.0_wp)*zn1**(rn_alpha+2.0_wp) 2814 za2 = (rn_alpha+2.0_wp)*zn2**(rn_alpha+1.0_wp)-(rn_alpha+1.0_wp)*zn2**(rn_alpha+2.0_wp) 2815 za3 = (zn2**3.0_wp - za2)/( zn1**3.0_wp - za1) 2816 ! 2817 za = pzb - za3*(pzs-za1)-za2 2818 za = za/( zn2-0.5_wp*(za2+zn2**2.0_wp) - za3*(zn1-0.5_wp*(za1+zn1**2.0_wp) ) ) 2819 zb = (pzs - za1 - za*( zn1-0.5_wp*(za1+zn1**2.0_wp ) ) ) / (zn1**3.0_wp - za1) 2820 zx = 1.0_wp-za/2.0_wp-zb 2821 ! 2822 DO jk = 1, jpk 2823 p_gamma(jk) = za*(pk1(jk)*(1.0_wp-pk1(jk)/2.0_wp))+zb*pk1(jk)**3.0_wp + & 2824 & zx*( (rn_alpha+2.0_wp)*pk1(jk)**(rn_alpha+1.0_wp)- & 2825 & (rn_alpha+1.0_wp)*pk1(jk)**(rn_alpha+2.0_wp) ) 2826 p_gamma(jk) = p_gamma(jk)*psmth+pk1(jk)*(1.0_wp-psmth) 2827 END DO 2828 ! 2829 END FUNCTION fgamma 314 zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( zk, 'U', 1. ) ; miku(:,:) = MAX( INT( zk(:,:) ), 1 ) 315 zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( zk, 'V', 1. ) ; mikv(:,:) = MAX( INT( zk(:,:) ), 1 ) 316 zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( zk, 'F', 1. ) ; mikf(:,:) = MAX( INT( zk(:,:) ), 1 ) 317 ! 318 zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( zk, 'U', 1. ) ; mbku(:,:) = MAX( INT( zk(:,:) ), 1 ) 319 zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( zk, 'V', 1. ) ; mbkv(:,:) = MAX( INT( zk(:,:) ), 1 ) 320 ! 321 CALL wrk_dealloc( jpi,jpj, zk ) 322 ! 323 IF( nn_timing == 1 ) CALL timing_stop('zgr_top_bot') 324 ! 325 END SUBROUTINE zgr_top_bot 2830 326 2831 327 !!====================================================================== -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/dtatsd.F90
r6140 r7646 53 53 LOGICAL, INTENT(in), OPTIONAL :: ld_tradmp ! force the initialization when tradp is used 54 54 ! 55 INTEGER :: i err0, ierr1, ierr2, ierr3 ! temporaryintegers56 ! 55 INTEGER :: ios, ierr0, ierr1, ierr2, ierr3 ! local integers 56 !! 57 57 CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files 58 58 TYPE(FLD_N), DIMENSION( jpts) :: slf_i ! array of namelist informations on the fields to read … … 60 60 !! 61 61 NAMELIST/namtsd/ ln_tsd_init, ln_tsd_tradmp, cn_dir, sn_tem, sn_sal 62 INTEGER :: ios63 62 !!---------------------------------------------------------------------- 64 63 ! … … 117 116 ! ! fill sf_tsd with sn_tem & sn_sal and control print 118 117 slf_i(jp_tem) = sn_tem ; slf_i(jp_sal) = sn_sal 119 CALL fld_fill( sf_tsd, slf_i, cn_dir, 'dta_tsd', 'Temperature & Salinity data', 'namtsd' )118 CALL fld_fill( sf_tsd, slf_i, cn_dir, 'dta_tsd', 'Temperature & Salinity data', 'namtsd', no_print ) 120 119 ! 121 120 ENDIF … … 155 154 ! 156 155 ! 156 !!gm This should be removed from the code ===>>>> T & S files has to be changed 157 ! 157 158 ! !== ORCA_R2 configuration and T & S damping ==! 158 IF( c p_cfg == "orca" .AND. jp_cfg == 2 .AND. ln_tsd_tradmp ) THEN ! some hand made alterations159 IF( cn_cfg == "orca" .AND. nn_cfg == 2 .AND. ln_tsd_tradmp ) THEN ! some hand made alterations 159 160 ! 160 161 ij0 = 101 ; ij1 = 109 ! Reduced T & S in the Alboran Sea … … 178 179 sf_tsd(jp_tem)%fnow( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 14:20 ) = 6.0_wp 179 180 ENDIF 181 !!gm end 180 182 ! 181 183 ptsd(:,:,:,jp_tem) = sf_tsd(jp_tem)%fnow(:,:,:) ! NO mask -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90
r6140 r7646 1 1 MODULE iscplhsb 2 2 !!====================================================================== 3 !! *** MODULE iscplhsb ***3 !! *** MODULE iscplhsb *** 4 4 !! Ocean forcing: ice sheet/ocean coupling (conservation) 5 5 !!===================================================================== -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/iscplini.F90
r6140 r7646 1 1 MODULE iscplini 2 2 !!====================================================================== 3 !! *** MODULE sbciscpl ***3 !! *** MODULE sbciscpl *** 4 4 !! Ocean forcing: river runoff 5 5 !!===================================================================== -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/iscplrst.F90
r6140 r7646 1 1 MODULE iscplrst 2 2 !!====================================================================== 3 !! *** MODULE iscplrst ***3 !! *** MODULE iscplrst *** 4 4 !! Ocean forcing: update the restart file in case of ice sheet/ocean coupling 5 5 !!===================================================================== … … 50 50 !!---------------------------------------------------------------------- 51 51 INTEGER :: inum0 52 REAL(wp), DIMENSION(:,: ), POINTER :: zsmask_b53 REAL(wp), DIMENSION(:,:,:), POINTER :: ztmask_b, zumask_b, zvmask_b54 REAL(wp), DIMENSION(:,:,:), POINTER :: ze3t_b , ze3u_b , ze3v_b55 REAL(wp), DIMENSION(:,:,:), POINTER :: zdepw_b52 REAL(wp), DIMENSION(:,: ), POINTER :: zsmask_b 53 REAL(wp), DIMENSION(:,:,:), POINTER :: ztmask_b, zumask_b, zvmask_b 54 REAL(wp), DIMENSION(:,:,:), POINTER :: ze3t_b , ze3u_b , ze3v_b 55 REAL(wp), DIMENSION(:,:,:), POINTER :: zdepw_b 56 56 CHARACTER(20) :: cfile 57 57 !!---------------------------------------------------------------------- 58 58 59 CALL wrk_alloc(jpi,jpj,jpk, ztmask_b, zumask_b, zvmask_b) ! mask before60 CALL wrk_alloc(jpi,jpj,jpk, ze3t_b , ze3u_b , ze3v_b ) ! e3 before61 CALL wrk_alloc(jpi,jpj,jpk, zdepw_b )62 CALL wrk_alloc(jpi,jpj, zsmask_b )59 CALL wrk_alloc(jpi,jpj,jpk, ztmask_b, zumask_b, zvmask_b) ! mask before 60 CALL wrk_alloc(jpi,jpj,jpk, ze3t_b , ze3u_b , ze3v_b ) ! e3 before 61 CALL wrk_alloc(jpi,jpj,jpk, zdepw_b ) 62 CALL wrk_alloc(jpi,jpj, zsmask_b ) 63 63 64 64 … … 86 86 87 87 !! print mesh/mask 88 IF( n msh /= 0 .AND. ln_iscpl ) CALL dom_wri ! Create a domain file88 IF( nn_msh /= 0 .AND. ln_iscpl ) CALL dom_wri ! Create a domain file 89 89 90 90 IF ( ln_hsb ) THEN … … 98 98 END IF 99 99 100 CALL wrk_dealloc(jpi,jpj,jpk, ztmask_b,zumask_b,zvmask_b )101 CALL wrk_dealloc(jpi,jpj,jpk, ze3t_b ,ze3u_b ,ze3v_b )102 CALL wrk_dealloc(jpi,jpj,jpk, zdepw_b )103 CALL wrk_dealloc(jpi,jpj, zsmask_b )100 CALL wrk_dealloc(jpi,jpj,jpk, ztmask_b,zumask_b,zvmask_b ) 101 CALL wrk_dealloc(jpi,jpj,jpk, ze3t_b ,ze3u_b ,ze3v_b ) 102 CALL wrk_dealloc(jpi,jpj,jpk, zdepw_b ) 103 CALL wrk_dealloc(jpi,jpj, zsmask_b ) 104 104 105 105 !! next step is an euler time step … … 108 108 !! set _b and _n variables equal 109 109 tsb (:,:,:,:) = tsn (:,:,:,:) 110 ub (:,:,: ) = un (:,:,:)111 vb (:,:,: ) = vn (:,:,:)112 sshb(:,: )= sshn(:,:)110 ub (:,:,:) = un (:,:,:) 111 vb (:,:,:) = vn (:,:,:) 112 sshb(:,:) = sshn(:,:) 113 113 114 114 !! set _b and _n vertical scale factor equal … … 117 117 e3v_b (:,:,:) = e3v_n (:,:,:) 118 118 119 e3uw_b (:,:,:) = e3uw_n(:,:,:)120 e3vw_b (:,:,:) = e3vw_n(:,:,:)121 gdept_b(:,:,:) 119 e3uw_b (:,:,:) = e3uw_n (:,:,:) 120 e3vw_b (:,:,:) = e3vw_n (:,:,:) 121 gdept_b(:,:,:) = gdept_n(:,:,:) 122 122 gdepw_b(:,:,:) = gdepw_n(:,:,:) 123 hu_b (:,:) = hu_n(:,:)124 hv_b (:,:) = hv_n(:,:)125 r1_hu_b(:,:) = r1_hu_n(:,:)126 r1_hv_b(:,:) = r1_hv_n(:,:)123 hu_b (:,:) = hu_n (:,:) 124 hv_b (:,:) = hv_n (:,:) 125 r1_hu_b(:,:) = r1_hu_n(:,:) 126 r1_hv_b(:,:) = r1_hv_n(:,:) 127 127 ! 128 128 END SUBROUTINE iscpl_stp 129 129 130 130 131 SUBROUTINE iscpl_rst_interpol (ptmask_b, pumask_b, pvmask_b, psmask_b, pe3t_b, pe3u_b, pe3v_b, pdepw_b) 131 132 !!---------------------------------------------------------------------- … … 436 437 CALL wrk_dealloc(jpi,jpj, zbub , zbvb , zbun , zbvn ) 437 438 CALL wrk_dealloc(jpi,jpj, zssh0 , zssh1 , zhu1 , zhv1 ) 438 439 ! 439 440 END SUBROUTINE iscpl_rst_interpol 440 441 442 !!====================================================================== 441 443 END MODULE iscplrst -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90
r6140 r7646 14 14 !! 3.3 ! 2010-10 (C. Ethe) merge TRC-TRA 15 15 !! 3.4 ! 2011-04 (G. Madec) Merge of dtatem and dtasal & suppression of tb,tn/sb,sn 16 !! 3.7 ! 2016-04 (S. Flavoni) introduce user defined initial state 16 17 !!---------------------------------------------------------------------- 17 18 18 19 !!---------------------------------------------------------------------- 19 20 !! istate_init : initial state setting 20 !! istate_tem : analytical profile for initial Temperature21 !! istate_sal : analytical profile for initial Salinity22 !! istate_eel : initial state setting of EEL R5 configuration23 !! istate_gyre : initial state setting of GYRE configuration24 21 !! istate_uvg : initial velocity in geostropic balance 25 22 !!---------------------------------------------------------------------- 26 USE oce ! ocean dynamics and active tracers 27 USE dom_oce ! ocean space and time domain 28 USE c1d ! 1D vertical configuration 29 USE daymod ! calendar 30 USE eosbn2 ! eq. of state, Brunt Vaisala frequency (eos routine) 31 USE ldftra ! lateral physics: ocean active tracers 32 USE zdf_oce ! ocean vertical physics 33 USE phycst ! physical constants 34 USE dtatsd ! data temperature and salinity (dta_tsd routine) 35 USE dtauvd ! data: U & V current (dta_uvd routine) 23 USE oce ! ocean dynamics and active tracers 24 USE dom_oce ! ocean space and time domain 25 USE daymod ! calendar 26 USE divhor ! horizontal divergence (div_hor routine) 27 USE dtatsd ! data temperature and salinity (dta_tsd routine) 28 USE dtauvd ! data: U & V current (dta_uvd routine) 36 29 USE domvvl ! varying vertical mesh 37 30 USE iscplrst ! ice sheet coupling 31 USE wet_dry ! wetting and drying (needed for wad_istate) 32 USE usrdef_istate ! User defined initial state 38 33 ! 39 34 USE in_out_manager ! I/O manager … … 70 65 IF( nn_timing == 1 ) CALL timing_start('istate_init') 71 66 ! 67 IF(lwp) WRITE(numout,*) 68 IF(lwp) WRITE(numout,*) 'istate_init : Initialization of the dynamics and tracers' 69 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 72 70 73 IF(lwp) WRITE(numout,*) 74 IF(lwp) WRITE(numout,*) 'istate_ini : Initialization of the dynamics and tracers' 75 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 76 71 !!gm Why not include in the first call of dta_tsd ? 72 !!gm probably associated with the use of internal damping... 77 73 CALL dta_tsd_init ! Initialisation of T & S input data 78 IF( lk_c1d ) CALL dta_uvd_init ! Initialization of U & V input data 74 !!gm to be moved in usrdef of C1D case 75 ! IF( lk_c1d ) CALL dta_uvd_init ! Initialization of U & V input data 76 !!gm 79 77 80 78 rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk … … 86 84 ! ! ------------------- 87 85 CALL rst_read ! Read the restart file 88 IF (ln_iscpl) CALL iscpl_stp ! extra loate restart to wet and dry86 IF (ln_iscpl) CALL iscpl_stp ! extrapolate restart to wet and dry 89 87 CALL day_init ! model calendar (using both namelist and restart infos) 90 ELSE91 !! Start from rest88 ! 89 ELSE ! Start from rest 92 90 ! ! --------------- 93 numror = 0 ! define numror = 0 -> no restart file to read 94 neuler = 0 ! Set time-step indicator at nit000 (euler forward) 95 CALL day_init ! model calendar (using both namelist and restart infos) 96 ! ! Initialization of ocean to zero 97 ! before fields ! now fields 98 sshb (:,:) = 0._wp ; sshn (:,:) = 0._wp 99 ub (:,:,:) = 0._wp ; un (:,:,:) = 0._wp 100 vb (:,:,:) = 0._wp ; vn (:,:,:) = 0._wp 101 hdivn(:,:,:) = 0._wp 91 numror = 0 ! define numror = 0 -> no restart file to read 92 neuler = 0 ! Set time-step indicator at nit000 (euler forward) 93 CALL day_init ! model calendar (using both namelist and restart infos) 94 ! ! Initialization of ocean to zero 102 95 ! 103 IF( cp_cfg == 'eel' ) THEN 104 CALL istate_eel ! EEL configuration : start from pre-defined U,V T-S fields 105 ELSEIF( cp_cfg == 'gyre' ) THEN 106 CALL istate_gyre ! GYRE configuration : start from pre-defined T-S fields 107 ELSE ! Initial T-S, U-V fields read in files 108 IF ( ln_tsd_init ) THEN ! read 3D T and S data at nit000 109 CALL dta_tsd( nit000, tsb ) 110 tsn(:,:,:,:) = tsb(:,:,:,:) 111 ! 112 ELSE ! Initial T-S fields defined analytically 113 CALL istate_t_s 114 ENDIF 115 IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 116 CALL wrk_alloc( jpi,jpj,jpk,2, zuvd ) 117 CALL dta_uvd( nit000, zuvd ) 118 ub(:,:,:) = zuvd(:,:,:,1) ; un(:,:,:) = ub(:,:,:) 119 vb(:,:,:) = zuvd(:,:,:,2) ; vn(:,:,:) = vb(:,:,:) 120 CALL wrk_dealloc( jpi,jpj,jpk,2, zuvd ) 121 ENDIF 96 IF( ln_tsd_init ) THEN 97 CALL dta_tsd( nit000, tsb ) ! read 3D T and S data at nit000 98 ! 99 sshb(:,:) = 0._wp ! set the ocean at rest 100 ub (:,:,:) = 0._wp 101 vb (:,:,:) = 0._wp 102 ! 103 ELSE ! user defined initial T and S 104 CALL usr_def_istate( gdept_b, tmask, tsb, ub, vb, sshb ) 122 105 ENDIF 106 tsn (:,:,:,:) = tsb (:,:,:,:) ! set now values from to before ones 107 sshn (:,:) = sshb(:,:) 108 un (:,:,:) = ub (:,:,:) 109 vn (:,:,:) = vb (:,:,:) 110 hdivn(:,:,jpk) = 0._wp ! bottom divergence set one for 0 to zero at jpk level 111 CALL div_hor( 0 ) ! compute interior hdivn value 112 !!gm hdivn(:,:,:) = 0._wp 113 114 !!gm POTENTIAL BUG : 115 !!gm ISSUE : if sshb /= 0 then, in non linear free surface, the e3._n, e3._b should be recomputed 116 !! as well as gdept and gdepw.... !!!!! 117 !! ===>>>> probably a call to domvvl initialisation here.... 118 119 120 ! 121 !!gm to be moved in usrdef of C1D case 122 ! IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 123 ! CALL wrk_alloc( jpi,jpj,jpk,2, zuvd ) 124 ! CALL dta_uvd( nit000, zuvd ) 125 ! ub(:,:,:) = zuvd(:,:,:,1) ; un(:,:,:) = ub(:,:,:) 126 ! vb(:,:,:) = zuvd(:,:,:,2) ; vn(:,:,:) = vb(:,:,:) 127 ! CALL wrk_dealloc( jpi,jpj,jpk,2, zuvd ) 128 ! ENDIF 123 129 ! 124 130 !!gm This is to be changed !!!! 125 ! - ML - sshn could be modified by istate_eel, so that initialization of e3t_b is done here126 IF( .NOT.ln_linssh ) THEN127 DO jk = 1, jpk128 e3t_b(:,:,jk) = e3t_n(:,:,jk)129 END DO130 ENDIF131 ! ! - ML - sshn could be modified by istate_eel, so that initialization of e3t_b is done here 132 ! IF( .NOT.ln_linssh ) THEN 133 ! DO jk = 1, jpk 134 ! e3t_b(:,:,jk) = e3t_n(:,:,jk) 135 ! END DO 136 ! ENDIF 131 137 !!gm 132 138 ! 133 ENDIF 139 ENDIF 134 140 ! 135 141 ! Initialize "now" and "before" barotropic velocities: … … 139 145 ub_b(:,:) = 0._wp ; vb_b(:,:) = 0._wp 140 146 ! 141 !!gm the use of umsak & vmask is not necessary belo xas un, vn, ub, vb are always masked147 !!gm the use of umsak & vmask is not necessary below as un, vn, ub, vb are always masked 142 148 DO jk = 1, jpkm1 143 149 DO jj = 1, jpj … … 162 168 END SUBROUTINE istate_init 163 169 164 165 SUBROUTINE istate_t_s 166 !!--------------------------------------------------------------------- 167 !! *** ROUTINE istate_t_s *** 168 !! 169 !! ** Purpose : Intialization of the temperature field with an 170 !! analytical profile or a file (i.e. in EEL configuration) 171 !! 172 !! ** Method : - temperature: use Philander analytic profile 173 !! - salinity : use to a constant value 35.5 174 !! 175 !! References : Philander ??? 176 !!---------------------------------------------------------------------- 177 INTEGER :: ji, jj, jk 178 REAL(wp) :: zsal = 35.50_wp 179 !!---------------------------------------------------------------------- 180 ! 181 IF(lwp) WRITE(numout,*) 182 IF(lwp) WRITE(numout,*) 'istate_t_s : Philander s initial temperature profile' 183 IF(lwp) WRITE(numout,*) '~~~~~~~~~~ and constant salinity (',zsal,' psu)' 184 ! 185 DO jk = 1, jpk 186 tsn(:,:,jk,jp_tem) = ( ( ( 7.5 - 0. * ABS( gphit(:,:) )/30. ) * ( 1.-TANH((gdept_n(:,:,jk)-80.)/30.) ) & 187 & + 10. * ( 5000. - gdept_n(:,:,jk) ) /5000.) ) * tmask(:,:,jk) 188 tsb(:,:,jk,jp_tem) = tsn(:,:,jk,jp_tem) 189 END DO 190 tsn(:,:,:,jp_sal) = zsal * tmask(:,:,:) 191 tsb(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) 192 ! 193 END SUBROUTINE istate_t_s 194 195 196 SUBROUTINE istate_eel 197 !!---------------------------------------------------------------------- 198 !! *** ROUTINE istate_eel *** 199 !! 200 !! ** Purpose : Initialization of the dynamics and tracers for EEL R5 201 !! configuration (channel with or without a topographic bump) 202 !! 203 !! ** Method : - set temprature field 204 !! - set salinity field 205 !! - set velocity field including horizontal divergence 206 !! and relative vorticity fields 207 !!---------------------------------------------------------------------- 208 USE divhor ! hor. divergence (div_hor routine) 209 USE iom 210 ! 211 INTEGER :: inum ! temporary logical unit 212 INTEGER :: ji, jj, jk ! dummy loop indices 213 INTEGER :: ijloc 214 REAL(wp) :: zh1, zh2, zslope, zcst, zfcor ! temporary scalars 215 REAL(wp) :: zt1 = 15._wp ! surface temperature value (EEL R5) 216 REAL(wp) :: zt2 = 5._wp ! bottom temperature value (EEL R5) 217 REAL(wp) :: zsal = 35.0_wp ! constant salinity (EEL R2, R5 and R6) 218 REAL(wp) :: zueel = 0.1_wp ! constant uniform zonal velocity (EEL R5) 219 REAL(wp), DIMENSION(jpiglo,jpjglo) :: zssh ! initial ssh over the global domain 220 !!---------------------------------------------------------------------- 221 ! 222 SELECT CASE ( jp_cfg ) 223 ! ! ==================== 224 CASE ( 5 ) ! EEL R5 configuration 225 ! ! ==================== 226 ! 227 ! set temperature field with a linear profile 228 ! ------------------------------------------- 229 IF(lwp) WRITE(numout,*) 230 IF(lwp) WRITE(numout,*) 'istate_eel : EEL R5: linear temperature profile' 231 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 232 ! 233 zh1 = gdept_1d( 1 ) 234 zh2 = gdept_1d(jpkm1) 235 ! 236 zslope = ( zt1 - zt2 ) / ( zh1 - zh2 ) 237 zcst = ( zt1 * ( zh1 - zh2) - ( zt1 - zt2 ) * zh1 ) / ( zh1 - zh2 ) 238 ! 239 DO jk = 1, jpk 240 tsn(:,:,jk,jp_tem) = ( zt2 + zt1 * exp( - gdept_n(:,:,jk) / 1000 ) ) * tmask(:,:,jk) 241 tsb(:,:,jk,jp_tem) = tsn(:,:,jk,jp_tem) 242 END DO 243 ! 244 ! set salinity field to a constant value 245 ! -------------------------------------- 246 IF(lwp) WRITE(numout,*) 247 IF(lwp) WRITE(numout,*) 'istate_eel : EEL R5: constant salinity field, S = ', zsal 248 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 249 ! 250 tsn(:,:,:,jp_sal) = zsal * tmask(:,:,:) 251 tsb(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) 252 ! 253 ! set the dynamics: U,V, hdiv (and ssh if necessary) 254 ! ---------------- 255 ! Start EEL5 configuration with barotropic geostrophic velocities 256 ! according the sshb and sshn SSH imposed. 257 ! we assume a uniform grid (hence the use of e1t(1,1) for delta_y) 258 ! we use the Coriolis frequency at mid-channel. 259 ub(:,:,:) = zueel * umask(:,:,:) 260 un(:,:,:) = ub(:,:,:) 261 ijloc = mj0(INT(jpjglo-1)/2) 262 zfcor = ff(1,ijloc) 263 ! 264 DO jj = 1, jpjglo 265 zssh(:,jj) = - (FLOAT(jj)- FLOAT(jpjglo-1)/2.)*zueel*e1t(1,1)*zfcor/grav 266 END DO 267 ! 268 IF(lwp) THEN 269 WRITE(numout,*) ' Uniform zonal velocity for EEL R5:',zueel 270 WRITE(numout,*) ' Geostrophic SSH profile as a function of y:' 271 WRITE(numout,'(12(1x,f6.2))') zssh(1,:) 272 ENDIF 273 ! 274 DO jj = 1, nlcj 275 DO ji = 1, nlci 276 sshb(ji,jj) = zssh( mig(ji) , mjg(jj) ) * tmask(ji,jj,1) 277 END DO 278 END DO 279 sshb(nlci+1:jpi, : ) = 0.e0 ! set to zero extra mpp columns 280 sshb( : ,nlcj+1:jpj) = 0.e0 ! set to zero extra mpp rows 281 ! 282 sshn(:,:) = sshb(:,:) ! set now ssh to the before value 283 ! 284 IF( nn_rstssh /= 0 ) THEN 285 nn_rstssh = 0 ! hand-made initilization of ssh 286 CALL ctl_warn( 'istate_eel: force nn_rstssh = 0' ) 287 ENDIF 288 ! 289 !!gm Check here call to div_hor should not be necessary 290 !!gm div_hor call runoffs not sure they are defined at that level 291 CALL div_hor( nit000 ) ! horizontal divergence and relative vorticity (curl) 292 ! N.B. the vertical velocity will be computed from the horizontal divergence field 293 ! in istate by a call to wzv routine 294 295 296 ! ! ========================== 297 CASE ( 2 , 6 ) ! EEL R2 or R6 configuration 298 ! ! ========================== 299 ! 300 ! set temperature field with a NetCDF file 301 ! ---------------------------------------- 302 IF(lwp) WRITE(numout,*) 303 IF(lwp) WRITE(numout,*) 'istate_eel : EEL R2 or R6: read initial temperature in a NetCDF file' 304 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 305 ! 306 CALL iom_open ( 'eel.initemp', inum ) 307 CALL iom_get ( inum, jpdom_data, 'initemp', tsb(:,:,:,jp_tem) ) ! read before temprature (tb) 308 CALL iom_close( inum ) 309 ! 310 tsn(:,:,:,jp_tem) = tsb(:,:,:,jp_tem) ! set nox temperature to tb 311 ! 312 ! set salinity field to a constant value 313 ! -------------------------------------- 314 IF(lwp) WRITE(numout,*) 315 IF(lwp) WRITE(numout,*) 'istate_eel : EEL R5: constant salinity field, S = ', zsal 316 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 317 ! 318 tsn(:,:,:,jp_sal) = zsal * tmask(:,:,:) 319 tsb(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) 320 ! 321 ! ! =========================== 322 CASE DEFAULT ! NONE existing configuration 323 ! ! =========================== 324 WRITE(ctmp1,*) 'EEL with a ', jp_cfg,' km resolution is not coded' 325 CALL ctl_stop( ctmp1 ) 326 ! 327 END SELECT 328 ! 329 END SUBROUTINE istate_eel 330 331 332 SUBROUTINE istate_gyre 333 !!---------------------------------------------------------------------- 334 !! *** ROUTINE istate_gyre *** 335 !! 336 !! ** Purpose : Initialization of the dynamics and tracers for GYRE 337 !! configuration (double gyre with rotated domain) 338 !! 339 !! ** Method : - set temprature field 340 !! - set salinity field 341 !!---------------------------------------------------------------------- 342 INTEGER :: ji, jj, jk ! dummy loop indices 343 INTEGER :: inum ! temporary logical unit 344 INTEGER, PARAMETER :: ntsinit = 0 ! (0/1) (analytical/input data files) T&S initialization 345 !!---------------------------------------------------------------------- 346 ! 347 SELECT CASE ( ntsinit) 348 ! 349 CASE ( 0 ) ! analytical T/S profil deduced from LEVITUS 350 IF(lwp) WRITE(numout,*) 351 IF(lwp) WRITE(numout,*) 'istate_gyre : initial analytical T and S profil deduced from LEVITUS ' 352 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 353 ! 354 DO jk = 1, jpk 355 DO jj = 1, jpj 356 DO ji = 1, jpi 357 tsn(ji,jj,jk,jp_tem) = ( 16. - 12. * TANH( (gdept_n(ji,jj,jk) - 400) / 700 ) ) & 358 & * (-TANH( (500-gdept_n(ji,jj,jk)) / 150 ) + 1) / 2 & 359 & + ( 15. * ( 1. - TANH( (gdept_n(ji,jj,jk)-50.) / 1500.) ) & 360 & - 1.4 * TANH((gdept_n(ji,jj,jk)-100.) / 100.) & 361 & + 7. * (1500. - gdept_n(ji,jj,jk)) / 1500. ) & 362 & * (-TANH( (gdept_n(ji,jj,jk) - 500) / 150) + 1) / 2 363 tsn(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) 364 tsb(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) 365 366 tsn(ji,jj,jk,jp_sal) = ( 36.25 - 1.13 * TANH( (gdept_n(ji,jj,jk) - 305) / 460 ) ) & 367 & * (-TANH((500 - gdept_n(ji,jj,jk)) / 150) + 1) / 2 & 368 & + ( 35.55 + 1.25 * (5000. - gdept_n(ji,jj,jk)) / 5000. & 369 & - 1.62 * TANH( (gdept_n(ji,jj,jk) - 60. ) / 650. ) & 370 & + 0.2 * TANH( (gdept_n(ji,jj,jk) - 35. ) / 100. ) & 371 & + 0.2 * TANH( (gdept_n(ji,jj,jk) - 1000.) / 5000.) ) & 372 & * (-TANH((gdept_n(ji,jj,jk) - 500) / 150) + 1) / 2 373 tsn(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) 374 tsb(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) 375 END DO 376 END DO 377 END DO 378 ! 379 CASE ( 1 ) ! T/S data fields read in dta_tem.nc/data_sal.nc files 380 IF(lwp) WRITE(numout,*) 381 IF(lwp) WRITE(numout,*) 'istate_gyre : initial T and S read from dta_tem.nc/data_sal.nc files' 382 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 383 IF(lwp) WRITE(numout,*) ' NetCDF FORMAT' 384 385 ! Read temperature field 386 ! ---------------------- 387 CALL iom_open ( 'data_tem', inum ) 388 CALL iom_get ( inum, jpdom_data, 'votemper', tsn(:,:,:,jp_tem) ) 389 CALL iom_close( inum ) 390 391 tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * tmask(:,:,:) 392 tsb(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) 393 394 ! Read salinity field 395 ! ------------------- 396 CALL iom_open ( 'data_sal', inum ) 397 CALL iom_get ( inum, jpdom_data, 'vosaline', tsn(:,:,:,jp_sal) ) 398 CALL iom_close( inum ) 399 400 tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask(:,:,:) 401 tsb(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) 402 ! 403 END SELECT 404 ! 405 IF(lwp) THEN 406 WRITE(numout,*) 407 WRITE(numout,*) ' Initial temperature and salinity profiles:' 408 WRITE(numout, "(9x,' level gdept_1d temperature salinity ')" ) 409 WRITE(numout, "(10x, i4, 3f10.2)" ) ( jk, gdept_1d(jk), tsn(2,2,jk,jp_tem), tsn(2,2,jk,jp_sal), jk = 1, jpk ) 410 ENDIF 411 ! 412 END SUBROUTINE istate_gyre 413 414 415 SUBROUTINE istate_uvg 416 !!---------------------------------------------------------------------- 417 !! *** ROUTINE istate_uvg *** 418 !! 419 !! ** Purpose : Compute the geostrophic velocities from (tn,sn) fields 420 !! 421 !! ** Method : Using the hydrostatic hypothesis the now hydrostatic 422 !! pressure is computed by integrating the in-situ density from the 423 !! surface to the bottom. 424 !! p=integral [ rau*g dz ] 425 !!---------------------------------------------------------------------- 426 USE divhor ! hor. divergence (div_hor routine) 427 USE lbclnk ! ocean lateral boundary condition (or mpp link) 428 ! 429 INTEGER :: ji, jj, jk ! dummy loop indices 430 REAL(wp) :: zmsv, zphv, zmsu, zphu, zalfg ! temporary scalars 431 REAL(wp), POINTER, DIMENSION(:,:,:) :: zprn 432 !!---------------------------------------------------------------------- 433 ! 434 CALL wrk_alloc( jpi,jpj,jpk, zprn) 435 ! 436 IF(lwp) WRITE(numout,*) 437 IF(lwp) WRITE(numout,*) 'istate_uvg : Start from Geostrophy' 438 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 439 440 ! Compute the now hydrostatic pressure 441 ! ------------------------------------ 442 443 zalfg = 0.5 * grav * rau0 444 445 zprn(:,:,1) = zalfg * e3w_n(:,:,1) * ( 1 + rhd(:,:,1) ) ! Surface value 446 447 DO jk = 2, jpkm1 ! Vertical integration from the surface 448 zprn(:,:,jk) = zprn(:,:,jk-1) & 449 & + zalfg * e3w_n(:,:,jk) * ( 2. + rhd(:,:,jk) + rhd(:,:,jk-1) ) 450 END DO 451 452 ! Compute geostrophic balance 453 ! --------------------------- 454 DO jk = 1, jpkm1 455 DO jj = 2, jpjm1 456 DO ji = fs_2, fs_jpim1 ! vertor opt. 457 zmsv = 1. / MAX( umask(ji-1,jj+1,jk) + umask(ji ,jj+1,jk) & 458 + umask(ji-1,jj ,jk) + umask(ji ,jj ,jk) , 1. ) 459 zphv = ( zprn(ji ,jj+1,jk) - zprn(ji-1,jj+1,jk) ) * umask(ji-1,jj+1,jk) / e1u(ji-1,jj+1) & 460 + ( zprn(ji+1,jj+1,jk) - zprn(ji ,jj+1,jk) ) * umask(ji ,jj+1,jk) / e1u(ji ,jj+1) & 461 + ( zprn(ji ,jj ,jk) - zprn(ji-1,jj ,jk) ) * umask(ji-1,jj ,jk) / e1u(ji-1,jj ) & 462 + ( zprn(ji+1,jj ,jk) - zprn(ji ,jj ,jk) ) * umask(ji ,jj ,jk) / e1u(ji ,jj ) 463 zphv = 1. / rau0 * zphv * zmsv * vmask(ji,jj,jk) 464 465 zmsu = 1. / MAX( vmask(ji+1,jj ,jk) + vmask(ji ,jj ,jk) & 466 + vmask(ji+1,jj-1,jk) + vmask(ji ,jj-1,jk) , 1. ) 467 zphu = ( zprn(ji+1,jj+1,jk) - zprn(ji+1,jj ,jk) ) * vmask(ji+1,jj ,jk) / e2v(ji+1,jj ) & 468 + ( zprn(ji ,jj+1,jk) - zprn(ji ,jj ,jk) ) * vmask(ji ,jj ,jk) / e2v(ji ,jj ) & 469 + ( zprn(ji+1,jj ,jk) - zprn(ji+1,jj-1,jk) ) * vmask(ji+1,jj-1,jk) / e2v(ji+1,jj-1) & 470 + ( zprn(ji ,jj ,jk) - zprn(ji ,jj-1,jk) ) * vmask(ji ,jj-1,jk) / e2v(ji ,jj-1) 471 zphu = 1. / rau0 * zphu * zmsu * umask(ji,jj,jk) 472 473 ! Compute the geostrophic velocities 474 un(ji,jj,jk) = -2. * zphu / ( ff(ji,jj) + ff(ji ,jj-1) ) 475 vn(ji,jj,jk) = 2. * zphv / ( ff(ji,jj) + ff(ji-1,jj ) ) 476 END DO 477 END DO 478 END DO 479 480 IF(lwp) WRITE(numout,*) ' we force to zero bottom velocity' 481 482 ! Susbtract the bottom velocity (level jpk-1 for flat bottom case) 483 ! to have a zero bottom velocity 484 485 DO jk = 1, jpkm1 486 un(:,:,jk) = ( un(:,:,jk) - un(:,:,jpkm1) ) * umask(:,:,jk) 487 vn(:,:,jk) = ( vn(:,:,jk) - vn(:,:,jpkm1) ) * vmask(:,:,jk) 488 END DO 489 490 CALL lbc_lnk( un, 'U', -1. ) 491 CALL lbc_lnk( vn, 'V', -1. ) 492 493 ub(:,:,:) = un(:,:,:) 494 vb(:,:,:) = vn(:,:,:) 495 496 ! 497 !!gm Check here call to div_hor should not be necessary 498 !!gm div_hor call runoffs not sure they are defined at that level 499 CALL div_hor( nit000 ) ! now horizontal divergence 500 ! 501 CALL wrk_dealloc( jpi,jpj,jpk, zprn) 502 ! 503 END SUBROUTINE istate_uvg 504 505 !!===================================================================== 170 !!====================================================================== 506 171 END MODULE istate -
trunk/NEMOGCM/NEMO/OPA_SRC/DOM/phycst.F90
r5147 r7646 100 100 !! *** ROUTINE phy_cst *** 101 101 !! 102 !! ** Purpose : Print model parameters and set and print the constants 103 !!---------------------------------------------------------------------- 104 CHARACTER (len=64) :: cform = "(A12, 3(A13, I7) )" 102 !! ** Purpose : set and print the constants 105 103 !!---------------------------------------------------------------------- 106 104 107 105 IF(lwp) WRITE(numout,*) 108 IF(lwp) WRITE(numout,*) ' 109 IF(lwp) WRITE(numout,*) ' 106 IF(lwp) WRITE(numout,*) 'phy_cst : initialization of ocean parameters and constants' 107 IF(lwp) WRITE(numout,*) '~~~~~~~' 110 108 111 ! Ocean Parameters 112 ! ---------------- 113 IF(lwp) THEN 114 WRITE(numout,*) ' Domain info' 115 WRITE(numout,*) ' dimension of model' 116 WRITE(numout,*) ' Local domain Global domain Data domain ' 117 WRITE(numout,cform) ' ',' jpi : ', jpi, ' jpiglo : ', jpiglo, ' jpidta : ', jpidta 118 WRITE(numout,cform) ' ',' jpj : ', jpj, ' jpjglo : ', jpjglo, ' jpjdta : ', jpjdta 119 WRITE(numout,cform) ' ',' jpk : ', jpk, ' jpk : ', jpk , ' jpkdta : ', jpkdta 120 WRITE(numout,*) ' ',' jpij : ', jpij 121 WRITE(numout,*) ' mpp local domain info (mpp)' 122 WRITE(numout,*) ' jpni : ', jpni, ' jpreci : ', jpreci 123 WRITE(numout,*) ' jpnj : ', jpnj, ' jprecj : ', jprecj 124 WRITE(numout,*) ' jpnij : ', jpnij 125 WRITE(numout,*) ' lateral domain boundary condition type : jperio = ', jperio 126 ENDIF 127 128 ! Define constants 129 ! ---------------- 109 ! Define & print constants 110 ! ------------------------ 130 111 IF(lwp) WRITE(numout,*) 131 112 IF(lwp) WRITE(numout,*) ' Constants'
Note: See TracChangeset
for help on using the changeset viewer.
