Changeset 14098 for NEMO/branches
- Timestamp:
- 2020-12-04T15:36:00+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r13787_doc_latex_recovery
- Files:
-
- 66 edited
- 14 copied
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r13787_doc_latex_recovery
- Property svn:externals
-
old new 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 ^/vendors/PPR@HEAD ext/PPR 8 9 9 10 # SETTE
-
- Property svn:externals
-
NEMO/branches/2020/dev_r13787_doc_latex_recovery/cfgs/AGRIF_DEMO/EXPREF/1_context_nemo.xml
r13476 r14098 4 4 ============================================================================================== 5 5 --> 6 <context id=" 1_nemo">6 <context id="nemo"> 7 7 <!-- $id$ --> 8 8 <variable_definition> … … 22 22 <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> 23 23 <field_definition src="./field_def_nemo-ice.xml"/> <!-- NEMO ocean sea ice --> 24 <field_definition src="./field_def_nemo-pisces.xml"/> <!-- NEMO ocean biogeochemical --> 25 <field_definition src="./field_def_nemo-innerttrc.xml"/> <!-- NEMO ocean inert passive tracer --> 24 26 25 27 … … 27 29 <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> 28 30 <file_definition src="./file_def_nemo-ice.xml"/> <!-- NEMO ocean sea ice --> 31 <file_definition src="./file_def_nemo-innerttrc.xml"/> <!-- NEMO ocean inert passive tracer --> 29 32 30 33 <!-- Axis definition --> -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/cfgs/AGRIF_DEMO/EXPREF/2_context_nemo.xml
r13476 r14098 4 4 ============================================================================================== 5 5 --> 6 <context id=" 2_nemo">6 <context id="nemo"> 7 7 <!-- $id$ --> 8 8 <variable_definition> … … 22 22 <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> 23 23 <field_definition src="./field_def_nemo-ice.xml"/> <!-- NEMO ocean sea ice --> 24 <field_definition src="./field_def_nemo-pisces.xml"/> <!-- NEMO ocean biogeochemical --> 25 <field_definition src="./field_def_nemo-innerttrc.xml"/> <!-- NEMO ocean inert passive tracer --> 24 26 25 27 … … 27 29 <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> 28 30 <file_definition src="./file_def_nemo-ice.xml"/> <!-- NEMO ocean sea ice --> 31 <file_definition src="./file_def_nemo-innerttrc.xml"/> <!-- NEMO ocean inert passive tracer --> 29 32 30 33 <!-- Axis definition --> -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/cfgs/AGRIF_DEMO/EXPREF/2_namelist_cfg
r13558 r14098 158 158 !----------------------------------------------------------------------- 159 159 ln_spc_dyn = .true. ! use 0 as special value for dynamics 160 ln_chk_bathy = . true.! =T check the parent bathymetry160 ln_chk_bathy = .false. ! =T check the parent bathymetry 161 161 / 162 162 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/cfgs/AGRIF_DEMO/EXPREF/3_context_nemo.xml
r13476 r14098 4 4 ============================================================================================== 5 5 --> 6 <context id=" 3_nemo">6 <context id="nemo"> 7 7 <!-- $id$ --> 8 8 <variable_definition> … … 22 22 <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> 23 23 <field_definition src="./field_def_nemo-ice.xml"/> <!-- NEMO ocean sea ice --> 24 <field_definition src="./field_def_nemo-pisces.xml"/> <!-- NEMO ocean biogeochemical --> 25 <field_definition src="./field_def_nemo-innerttrc.xml"/> <!-- NEMO ocean inert passive tracer --> 24 26 25 27 … … 27 29 <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> 28 30 <file_definition src="./file_def_nemo-ice.xml"/> <!-- NEMO ocean sea ice --> 31 <file_definition src="./file_def_nemo-innerttrc.xml"/> <!-- NEMO ocean inert passive tracer --> 29 32 30 33 <!-- Axis definition --> -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/cfgs/AGRIF_DEMO/EXPREF/3_namelist_cfg
r13558 r14098 158 158 !----------------------------------------------------------------------- 159 159 ln_spc_dyn = .true. ! use 0 as special value for dynamics 160 ln_chk_bathy = . true. ! =T check the parent bathymetry160 ln_chk_bathy = .false. ! =T check the parent bathymetry 161 161 / 162 162 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/cfgs/AGRIF_DEMO/EXPREF/context_nemo.xml
r13476 r14098 22 22 <field_definition src="./field_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> 23 23 <field_definition src="./field_def_nemo-ice.xml"/> <!-- NEMO ocean sea ice --> 24 <field_definition src="./field_def_nemo-pisces.xml"/> <!-- NEMO ocean biogeochemical --> 25 <field_definition src="./field_def_nemo-innerttrc.xml"/> <!-- NEMO ocean inert passive tracer --> 24 26 25 27 … … 27 29 <file_definition src="./file_def_nemo-oce.xml"/> <!-- NEMO ocean dynamics --> 28 30 <file_definition src="./file_def_nemo-ice.xml"/> <!-- NEMO ocean sea ice --> 31 <file_definition src="./file_def_nemo-innerttrc.xml"/> <!-- NEMO ocean inert passive tracer --> 29 32 30 33 <!-- Axis definition --> -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/cfgs/AGRIF_DEMO/cpp_AGRIF_DEMO.fcm
r12208 r14098 1 bld::tool::fppkeys key_si3 key_ iomput key_mpp_mpi key_agrif1 bld::tool::fppkeys key_si3 key_top key_iomput key_mpp_mpi key_agrif -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/cfgs/SHARED/namelist_ref
r14085 r14098 678 678 ln_agrif_2way = .true. ! activate two way nesting 679 679 ln_init_chfrpar = .false. ! initialize child grids from parent 680 ln_vert_remap = .false. ! use vertical remapping 680 681 ln_spc_dyn = .true. ! use 0 as special value for dynamics 682 ln_chk_bathy = .false. ! =T check the parent bathymetry 681 683 rn_sponge_tra = 0.002 ! coefficient for tracer sponge layer [] 682 684 rn_sponge_dyn = 0.002 ! coefficient for dynamics sponge layer [] 683 685 rn_trelax_tra = 0.01 ! inverse of relaxation time (in steps) for tracers [] 684 686 rn_trelax_dyn = 0.01 ! inverse of relaxation time (in steps) for dynamics [] 685 ln_chk_bathy = .false. ! =T check the parent bathymetry686 687 / 687 688 !----------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/cfgs/ref_cfgs.txt
r14085 r14098 1 AGRIF_DEMO OCE ICE NST1 AGRIF_DEMO OCE ICE TOP NST 2 2 AMM12 OCE 3 3 C1D_PAPA OCE -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/ICE/iceistate.F90
r14085 r14098 18 18 USE oce ! dynamics and tracers variables 19 19 USE dom_oce ! ocean domain 20 USE sbc_oce , ONLY : sst_m, sss_m, ln_ice_embd 20 USE sbc_oce , ONLY : sst_m, sss_m, ln_ice_embd 21 21 USE sbc_ice , ONLY : tn_ice, snwice_mass, snwice_mass_b 22 22 USE eosbn2 ! equation of state … … 39 39 # if defined key_agrif 40 40 USE agrif_oce 41 USE agrif_ice 42 USE agrif_ice_interp 43 # endif 41 USE agrif_ice_interp 42 # endif 44 43 45 44 IMPLICIT NONE … … 91 90 !! 92 91 !! ** Method : This routine will put some ice where ocean 93 !! is at the freezing point, then fill in ice 94 !! state variables using prescribed initial 95 !! values in the namelist 92 !! is at the freezing point, then fill in ice 93 !! state variables using prescribed initial 94 !! values in the namelist 96 95 !! 97 96 !! ** Steps : 1) Set initial surface and basal temperatures … … 103 102 !! where there is no ice 104 103 !!-------------------------------------------------------------------- 105 INTEGER, INTENT(in) :: kt ! time step 104 INTEGER, INTENT(in) :: kt ! time step 106 105 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa ! ocean time level indices 107 106 ! … … 129 128 ! basal temperature (considered at freezing point) [Kelvin] 130 129 CALL eos_fzp( sss_m(:,:), t_bo(:,:) ) 131 t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) 130 t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) 132 131 ! 133 132 ! surface temperature and conductivity … … 154 153 e_i (:,:,:,:) = 0._wp 155 154 e_s (:,:,:,:) = 0._wp 156 155 157 156 ! general fields 158 157 a_i (:,:,:) = 0._wp … … 184 183 IF( ln_iceini ) THEN 185 184 ! 186 IF( Agrif_Root() ) THEN 185 #if defined key_agrif 186 IF ( ( Agrif_Root() ).OR.(.NOT.ln_init_chfrpar ) ) THEN 187 #endif 187 188 ! !---------------! 188 189 IF( nn_iceini_file == 1 )THEN ! Read a file ! … … 229 230 IF( TRIM(si(jp_apd)%clrootname) == 'NOT USED' ) & 230 231 & si(jp_apd)%fnow(:,:,1) = ( rn_apd_ini_n * zswitch + rn_apd_ini_s * (1._wp - zswitch) ) * tmask(:,:,1) & ! rn_apd = pond fraction => rn_apnd * a_i = pond conc. 231 & * si(jp_ati)%fnow(:,:,1) 232 & * si(jp_ati)%fnow(:,:,1) 232 233 ! 233 234 ! pond depth … … 248 249 ! 249 250 ! change the switch for the following 250 WHERE( zat_i_ini(:,:) > 0._wp ) ; zswitch(:,:) = tmask(:,:,1) 251 WHERE( zat_i_ini(:,:) > 0._wp ) ; zswitch(:,:) = tmask(:,:,1) 251 252 ELSEWHERE ; zswitch(:,:) = 0._wp 252 253 END WHERE … … 256 257 ! !---------------! 257 258 ! no ice if (sst - Tfreez) >= thresold 258 WHERE( ( sst_m(:,:) - (t_bo(:,:) - rt0) ) * tmask(:,:,1) >= rn_thres_sst ) ; zswitch(:,:) = 0._wp 259 WHERE( ( sst_m(:,:) - (t_bo(:,:) - rt0) ) * tmask(:,:,1) >= rn_thres_sst ) ; zswitch(:,:) = 0._wp 259 260 ELSEWHERE ; zswitch(:,:) = tmask(:,:,1) 260 261 END WHERE … … 269 270 zt_su_ini(:,:) = rn_tsu_ini_n * zswitch(:,:) 270 271 ztm_s_ini(:,:) = rn_tms_ini_n * zswitch(:,:) 271 zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. 272 zapnd_ini(:,:) = rn_apd_ini_n * zswitch(:,:) * zat_i_ini(:,:) ! rn_apd = pond fraction => rn_apd * a_i = pond conc. 272 273 zhpnd_ini(:,:) = rn_hpd_ini_n * zswitch(:,:) 273 274 zhlid_ini(:,:) = rn_hld_ini_n * zswitch(:,:) … … 295 296 zhlid_ini(:,:) = 0._wp 296 297 ENDIF 297 298 298 299 IF ( .NOT.ln_pnd_lids ) THEN 299 300 zhlid_ini(:,:) = 0._wp 300 301 ENDIF 301 302 302 303 !----------------! 303 304 ! 3) fill fields ! … … 323 324 CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d(1:npti) , zhpnd_ini ) 324 325 CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d(1:npti) , zhlid_ini ) 325 326 326 327 ! allocate temporary arrays 327 328 ALLOCATE( zhi_2d (npti,jpl), zhs_2d (npti,jpl), zai_2d (npti,jpl), & … … 377 378 DO jl = 1, jpl 378 379 DO_3D( 1, 1, 1, 1, 1, nlay_i ) 379 t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl) 380 t_i (ji,jj,jk,jl) = zti_3d(ji,jj,jl) 380 381 ztmelts = - rTmlt * sz_i(ji,jj,jk,jl) + rt0 ! melting temperature in K 381 382 e_i(ji,jj,jk,jl) = zswitch(ji,jj) * v_i(ji,jj,jl) * r1_nlay_i * & … … 385 386 END_3D 386 387 END DO 387 388 #if 388 ! 389 #if defined key_agrif 389 390 ELSE 390 391 Agrif_SpecialValue = -9999. 392 Agrif_UseSpecialValue = .TRUE. 393 CALL Agrif_init_variable(tra_iceini_id,procname=interp_tra_ice) 394 use_sign_north = .TRUE. 395 sign_north = -1. 396 CALL Agrif_init_variable(u_iceini_id ,procname=interp_u_ice) 397 CALL Agrif_init_variable(v_iceini_id ,procname=interp_v_ice) 398 Agrif_SpecialValue = 0._wp 399 use_sign_north = .FALSE. 400 Agrif_UseSpecialValue = .FALSE. 401 ! lbc ???? 402 ! Here we know : a_i, v_i, v_s, sv_i, oa_i, a_ip, v_ip, v_il, t_su, e_s, e_i 403 CALL ice_var_glo2eqv 404 CALL ice_var_zapsmall 405 CALL ice_var_agg(2) 391 CALL agrif_istate_ice 392 ENDIF 406 393 #endif 407 ENDIF ! Agrif_Root408 !409 394 ! Melt ponds 410 395 WHERE( a_i > epsi10 ) ; a_ip_eff(:,:,:) = a_ip(:,:,:) / a_i(:,:,:) … … 413 398 v_ip(:,:,:) = h_ip(:,:,:) * a_ip(:,:,:) 414 399 v_il(:,:,:) = h_il(:,:,:) * a_ip(:,:,:) 415 400 416 401 ! specific temperatures for coupled runs 417 402 tn_ice(:,:,:) = t_su(:,:,:) … … 423 408 WHERE( at_i(:,:) > rn_amax_2d(:,:) ) a_i(:,:,jl) = a_i(:,:,jl) * rn_amax_2d(:,:) / at_i(:,:) 424 409 END DO 425 410 at_i(:,:) = SUM( a_i, dim=3 ) 426 411 ! 427 412 ENDIF ! ln_iceini … … 456 441 !!------------------------------------------------------------------- 457 442 !! *** ROUTINE ice_istate_init *** 458 !! 459 !! ** Purpose : Definition of initial state of the ice 460 !! 461 !! ** Method : Read the namini namelist and check the parameter 443 !! 444 !! ** Purpose : Definition of initial state of the ice 445 !! 446 !! ** Method : Read the namini namelist and check the parameter 462 447 !! values called at the first timestep (nit000) 463 448 !! … … 500 485 WRITE(numout,*) ' max ocean temp. above Tfreeze with initial ice rn_thres_sst = ', rn_thres_sst 501 486 IF( ln_iceini .AND. nn_iceini_file == 0 ) THEN 502 WRITE(numout,*) ' initial snw thickness in the north-south rn_hts_ini = ', rn_hts_ini_n,rn_hts_ini_s 487 WRITE(numout,*) ' initial snw thickness in the north-south rn_hts_ini = ', rn_hts_ini_n,rn_hts_ini_s 503 488 WRITE(numout,*) ' initial ice thickness in the north-south rn_hti_ini = ', rn_hti_ini_n,rn_hti_ini_s 504 489 WRITE(numout,*) ' initial ice concentr in the north-south rn_ati_ini = ', rn_ati_ini_n,rn_ati_ini_s -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/NST/agrif_ice_interp.F90
r13472 r14098 25 25 USE agrif_oce 26 26 USE phycst , ONLY: rt0 27 USE icevar 28 USE sbc_ice, ONLY : tn_ice 27 29 28 30 IMPLICIT NONE … … 30 32 31 33 PUBLIC agrif_interp_ice ! called by agrif_user.F90 32 PUBLIC interp_tra_ice, interp_u_ice, interp_v_ice ! called by iceistate.F9034 PUBLIC agrif_istate_ice ! called by icerst.F90 33 35 34 36 !!---------------------------------------------------------------------- … … 39 41 40 42 CONTAINS 43 44 SUBROUTINE agrif_istate_ice 45 !!----------------------------------------------------------------------- 46 !! *** ROUTINE agrif_istate_ice *** 47 !! 48 !! ** Method : Set initial ice fields from parent grid 49 !! 50 !!----------------------------------------------------------------------- 51 IF(lwp) WRITE(numout,*) ' ' 52 IF(lwp) WRITE(numout,*) 'Agrif_istate_ice : interp child ice initial state from parent' 53 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~' 54 IF(lwp) WRITE(numout,*) ' ' 55 56 ! Set a_i, v_i, v_s, sv_i, oa_i, a_ip, v_ip, t_su, e_s, e_i: 57 Agrif_SpecialValue = -9999. 58 Agrif_UseSpecialValue = .TRUE. 59 CALL Agrif_init_variable(tra_iceini_id,procname=interp_tra_ice) 60 ! 61 ! Set u_ice, v_ice: 62 use_sign_north = .TRUE. 63 sign_north = -1. 64 Agrif_UseSpecialValue = .TRUE. 65 CALL Agrif_init_variable(u_iceini_id ,procname=interp_u_ice) 66 CALL Agrif_init_variable(v_iceini_id ,procname=interp_v_ice) 67 Agrif_SpecialValue = 0._wp 68 use_sign_north = .FALSE. 69 Agrif_UseSpecialValue = .FALSE. 70 ! lbc ???? 71 ! JC: do we really need the 3 lines below ? 72 CALL ice_var_glo2eqv 73 CALL ice_var_zapsmall 74 CALL ice_var_agg(2) 75 76 ! Melt ponds 77 WHERE( a_i > epsi10 ) 78 a_ip_frac(:,:,:) = a_ip(:,:,:) / a_i(:,:,:) 79 ELSEWHERE 80 a_ip_frac(:,:,:) = 0._wp 81 END WHERE 82 WHERE( a_ip > 0._wp ) ! ??????? 83 h_ip(:,:,:) = v_ip(:,:,:) / a_ip(:,:,:) 84 ELSEWHERE 85 h_ip(:,:,:) = 0._wp 86 END WHERE 87 88 tn_ice(:,:,:) = t_su(:,:,:) 89 t1_ice(:,:,:) = t_i (:,:,1,:) 90 91 END SUBROUTINE agrif_istate_ice 41 92 42 93 SUBROUTINE agrif_interp_ice( cd_type, kiter, kitermax ) -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/NST/agrif_oce.F90
r13286 r14098 23 23 LOGICAL , PUBLIC :: ln_spc_dyn = .FALSE. !: use zeros (.false.) or not (.true.) in 24 24 !: bdys dynamical fields interpolation 25 REAL(wp), PUBLIC :: rn_sponge_tra = 2800. !: sponge coeff. for tracers 26 REAL(wp), PUBLIC :: rn_sponge_dyn = 2800. !: sponge coeff. for dynamics 25 LOGICAL , PUBLIC :: ln_vert_remap = .FALSE. !: use vertical remapping 26 REAL(wp), PUBLIC :: rn_sponge_tra = 0.002 !: sponge coeff. for tracers 27 REAL(wp), PUBLIC :: rn_sponge_dyn = 0.002 !: sponge coeff. for dynamics 27 28 REAL(wp), PUBLIC :: rn_trelax_tra = 0.01 !: time relaxation parameter for tracers 28 29 REAL(wp), PUBLIC :: rn_trelax_dyn = 0.01 !: time relaxation parameter for momentum … … 30 31 ! 31 32 INTEGER , PUBLIC, PARAMETER :: nn_sponge_len = 2 !: Sponge width (in number of parent grid points) 33 INTEGER , PUBLIC, PARAMETER :: nn_shift_bar = 0 !: nb of coarse grid points by which we shift 2d interface 32 34 33 35 LOGICAL , PUBLIC :: spongedoneT = .FALSE. !: tracer sponge layer indicator … … 35 37 LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE. !: if true: first step 36 38 LOGICAL , PUBLIC :: lk_agrif_debug = .FALSE. !: if true: print debugging info 37 39 LOGICAL , PUBLIC :: lk_tint2d_notinterp = .FALSE. !: if true, no time interp 38 40 LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_tsn 39 41 # if defined key_top … … 46 48 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fspu, fspv !: sponge arrays 47 49 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fspt, fspf !: " " 50 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fspu_2d,fspv_2d !: sponge arrays (2d mode) 51 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fspt_2d, fspf_2d !: " " " " 48 52 49 53 ! Barotropic arrays used to store open boundary data during time-splitting loop: … … 51 55 INTEGER , PUBLIC, SAVE :: Kbb_a, Kmm_a, Krhs_a !: AGRIF module-specific copies of time-level indices 52 56 53 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht0_parent, hu0_parent, hv0_parent 54 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt_parent, mbku_parent, mbkv_parent 57 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht0_parent, hu0_parent, hv0_parent 58 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t0_parent, e3u0_parent, e3v0_parent 59 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt_parent, mbku_parent, mbkv_parent 55 60 56 INTEGER, PUBLIC :: tsn_id ! AGRIF profile for tracers interpolation and update 61 62 INTEGER, PUBLIC :: ts_interp_id, ts_update_id ! AGRIF profile for tracers interpolation and update 57 63 INTEGER, PUBLIC :: un_interp_id, vn_interp_id ! AGRIF profiles for interpolations 58 64 INTEGER, PUBLIC :: un_update_id, vn_update_id ! AGRIF profiles for udpates 59 INTEGER, PUBLIC :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers 65 INTEGER, PUBLIC :: ts_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers (3d) 66 INTEGER, PUBLIC :: unb_sponge_id, vnb_sponge_id ! AGRIF profiles for sponge layers (2d) 60 67 INTEGER, PUBLIC :: tsini_id, uini_id, vini_id, sshini_id ! AGRIF profile for initialization 61 68 # if defined key_top 62 69 INTEGER, PUBLIC :: trn_id, trn_sponge_id 63 70 # endif 64 INTEGER, PUBLIC :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 65 INTEGER, PUBLIC :: ub2b_update_id, vb2b_update_id 66 INTEGER, PUBLIC :: e3t_id, e1u_id, e2v_id, sshn_id 71 INTEGER, PUBLIC :: unb_interp_id, vnb_interp_id, ub2b_interp_id, vb2b_interp_id 72 INTEGER, PUBLIC :: ub2b_update_id, vb2b_update_id, unb_update_id, vnb_update_id 73 INTEGER, PUBLIC :: ub2b_cor_id, vb2b_cor_id 74 INTEGER, PUBLIC :: e3t_id, sshn_id 67 75 INTEGER, PUBLIC :: scales_t_id 68 76 INTEGER, PUBLIC :: avt_id, avm_id, en_id ! TKE related identificators 69 INTEGER, PUBLIC :: mbkt_id, ht0_id 77 INTEGER, PUBLIC :: mbkt_id, ht0_id, e3t0_interp_id 70 78 INTEGER, PUBLIC :: glamt_id, gphit_id 79 INTEGER, PUBLIC :: batupd_id 71 80 INTEGER, PUBLIC :: kindic_agr 72 81 … … 74 83 !$AGRIF_DO_NOT_TREAT 75 84 LOGICAL, PUBLIC :: use_sign_north 76 REAL, PUBLIC :: sign_north85 REAL, PUBLIC :: sign_north 77 86 LOGICAL, PUBLIC :: l_ini_child = .FALSE. 78 # if defined key_vertical79 LOGICAL, PUBLIC :: l_vremap = .TRUE.80 # else81 87 LOGICAL, PUBLIC :: l_vremap = .FALSE. 82 # endif83 88 !$AGRIF_END_DO_NOT_TREAT 84 89 … … 100 105 ALLOCATE( fspu(jpi,jpj), fspv(jpi,jpj), & 101 106 & fspt(jpi,jpj), fspf(jpi,jpj), & 107 & fspu_2d(jpi,jpj), fspv_2d(jpi,jpj), & 108 & fspt_2d(jpi,jpj), fspf_2d(jpi,jpj), & 102 109 & tabspongedone_tsn(jpi,jpj), & 103 110 & utint_stage(jpi,jpj), vtint_stage(jpi,jpj), & … … 116 123 ! 117 124 END FUNCTION agrif_oce_alloc 118 119 125 #endif 120 126 !!====================================================================== -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/NST/agrif_oce_interp.F90
r14066 r14098 45 45 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b 46 46 PUBLIC interpe3t, interpglamt, interpgphit 47 PUBLIC interpht0, interpmbkt 48 PUBLIC agrif_initts, agrif_initssh 47 PUBLIC interpht0, interpmbkt, interpe3t0_vremap 48 PUBLIC agrif_istate_oce, agrif_istate_ssh ! called by icestate.F90 and domvvl.F90 49 PUBLIC agrif_check_bat 49 50 50 51 INTEGER :: bdy_tinterp = 0 … … 58 59 CONTAINS 59 60 60 SUBROUTINE Agrif_tra 61 !!---------------------------------------------------------------------- 62 !! *** ROUTINE Agrif_tra *** 63 !!---------------------------------------------------------------------- 64 ! 65 IF( Agrif_Root() ) RETURN 66 ! 61 SUBROUTINE Agrif_istate_oce( Kbb, Kmm, Kaa ) 62 !!---------------------------------------------------------------------- 63 !! *** ROUTINE agrif_istate_oce *** 64 !! 65 !! set initial t, s, u, v, ssh from parent 66 !!---------------------------------------------------------------------- 67 ! 68 IMPLICIT NONE 69 ! 70 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 71 INTEGER :: jn 72 !!---------------------------------------------------------------------- 73 IF(lwp) WRITE(numout,*) ' ' 74 IF(lwp) WRITE(numout,*) 'Agrif_istate_oce : interp child initial state from parent' 75 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~' 76 IF(lwp) WRITE(numout,*) ' ' 77 78 IF ( ln_rstart ) & 79 & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode') 80 81 IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 82 & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') 83 84 l_ini_child = .TRUE. 85 Agrif_SpecialValue = 0.0_wp 86 Agrif_UseSpecialValue = .TRUE. 87 88 ts(:,:,:,:,:) = 0.0_wp 89 uu(:,:,:,:) = 0.0_wp 90 vv(:,:,:,:) = 0.0_wp 91 ssh(:,:,:) = 0._wp 92 93 Krhs_a = Kbb ; Kmm_a = Kbb 94 95 CALL Agrif_Init_Variable(tsini_id, procname=interptsn) 96 CALL Agrif_Init_Variable(sshini_id, procname=interpsshn) 97 98 Agrif_UseSpecialValue = ln_spc_dyn 99 use_sign_north = .TRUE. 100 sign_north = -1._wp 101 CALL Agrif_Init_Variable(uini_id , procname=interpun ) 102 CALL Agrif_Init_Variable(vini_id , procname=interpvn ) 103 use_sign_north = .FALSE. 104 105 Agrif_UseSpecialValue = .FALSE. 106 l_ini_child = .FALSE. 107 108 Krhs_a = Kaa ; Kmm_a = Kmm 109 110 ssh(:,:,Kbb) = ssh(:,:,Kbb) * tmask(:,:,1) 111 112 DO jn = 1, jpts 113 ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:) 114 END DO 115 uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:) 116 vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:) 117 118 CALL lbc_lnk_multi( 'agrif_istate_oce', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp ) 119 CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T', 1.0_wp ) 120 CALL lbc_lnk( 'agrif_istate_oce', ssh(:,:,Kbb), 'T', 1.0_wp ) 121 122 END SUBROUTINE Agrif_istate_oce 123 124 125 SUBROUTINE Agrif_istate_ssh( Kbb, Kmm ) 126 !!---------------------------------------------------------------------- 127 !! *** ROUTINE agrif_istate_ssh *** 128 !! 129 !! set initial ssh from parent 130 !!---------------------------------------------------------------------- 131 ! 132 IMPLICIT NONE 133 ! 134 INTEGER, INTENT(in) :: Kbb, Kmm 135 !!---------------------------------------------------------------------- 136 IF(lwp) WRITE(numout,*) ' ' 137 IF(lwp) WRITE(numout,*) 'Agrif_istate_ssh : interp child ssh from parent' 138 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~' 139 IF(lwp) WRITE(numout,*) ' ' 140 141 IF ( ln_rstart ) & 142 & CALL ctl_stop('AGRIF hot start should be desactivated in restarting mode') 143 144 IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 145 & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') 146 147 Kmm_a = Kmm 148 ssh(:,:,Kmm) = 0._wp 149 67 150 Agrif_SpecialValue = 0._wp 68 151 Agrif_UseSpecialValue = .TRUE. 69 ! 70 CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 152 l_ini_child = .TRUE. 153 ! 154 CALL Agrif_Init_Variable(sshini_id, procname=interpsshn) 71 155 ! 72 156 Agrif_UseSpecialValue = .FALSE. 157 l_ini_child = .FALSE. 158 CALL lbc_lnk( 'dom_vvl_rst', ssh(:,:,Kmm), 'T', 1._wp ) 159 160 END SUBROUTINE Agrif_istate_ssh 161 162 163 SUBROUTINE Agrif_tra 164 !!---------------------------------------------------------------------- 165 !! *** ROUTINE Agrif_tra *** 166 !!---------------------------------------------------------------------- 167 ! 168 IF( Agrif_Root() ) RETURN 169 ! 170 Agrif_SpecialValue = 0._wp 171 Agrif_UseSpecialValue = .TRUE. 172 l_vremap = ln_vert_remap 173 ! 174 CALL Agrif_Bc_variable( ts_interp_id, procname=interptsn ) 175 ! 176 Agrif_UseSpecialValue = .FALSE. 177 l_vremap = .FALSE. 73 178 ! 74 179 END SUBROUTINE Agrif_tra … … 90 195 Agrif_SpecialValue = 0.0_wp 91 196 Agrif_UseSpecialValue = ln_spc_dyn 197 l_vremap = ln_vert_remap 92 198 ! 93 199 use_sign_north = .TRUE. … … 95 201 CALL Agrif_Bc_variable( un_interp_id, procname=interpun ) 96 202 CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn ) 203 204 IF( .NOT.ln_dynspg_ts ) THEN ! Get transports 205 ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp 206 CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb ) 207 CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb ) 208 ENDIF 209 97 210 use_sign_north = .FALSE. 98 211 ! 99 212 Agrif_UseSpecialValue = .FALSE. 213 l_vremap = .FALSE. 214 ! 215 ! Ensure below that vertically integrated transports match 216 ! either transports out of time splitting procedure (ln_dynspg_ts=.TRUE.) 217 ! or parent grid transports (ln_dynspg_ts=.FALSE.) 100 218 ! 101 219 ! --- West --- ! 102 220 IF( lk_west ) THEN 103 221 ibdy1 = nn_hls + 2 ! halo + land + 1 104 ibdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells222 ibdy2 = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells 105 223 ! 106 224 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 107 225 DO ji = mi0(ibdy1), mi1(ibdy2) 108 uu_b(ji,:,Krhs_a) = 0._wp109 DO jk = 1, jpkm1110 DO jj = 1, jpj111 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)112 END DO113 END DO114 226 DO jj = 1, jpj 115 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 227 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 228 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 116 229 END DO 117 230 END DO … … 119 232 ! 120 233 DO ji = mi0(ibdy1), mi1(ibdy2) 121 zub(ji,:) = 0._wp ! Correct transport234 zub(ji,:) = 0._wp 122 235 DO jk = 1, jpkm1 123 236 DO jj = 1, jpj … … 135 248 END DO 136 249 ! 137 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 138 DO ji = mi0(ibdy1), mi1(ibdy2) 139 zvb(ji,:) = 0._wp 140 DO jk = 1, jpkm1 141 DO jj = 1, jpj 142 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 143 END DO 144 END DO 250 DO ji = mi0(ibdy1), mi1(ibdy2) 251 zvb(ji,:) = 0._wp 252 DO jk = 1, jpkm1 145 253 DO jj = 1, jpj 146 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 147 END DO 148 DO jk = 1, jpkm1 149 DO jj = 1, jpj 150 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) )*vmask(ji,jj,jk) 151 END DO 152 END DO 153 END DO 154 ENDIF 254 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 255 END DO 256 END DO 257 DO jj = 1, jpj 258 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 259 END DO 260 DO jk = 1, jpkm1 261 DO jj = 1, jpj 262 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) )*vmask(ji,jj,jk) 263 END DO 264 END DO 265 END DO 155 266 ! 156 267 ENDIF … … 158 269 ! --- East --- ! 159 270 IF( lk_east) THEN 160 ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells161 ibdy2 = jpiglo - ( nn_hls + 2 ) ! halo + land + 1162 ! 163 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport271 ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox() 272 ibdy2 = jpiglo - ( nn_hls + 2 ) 273 ! 274 IF( .NOT.ln_dynspg_ts ) THEN 164 275 DO ji = mi0(ibdy1), mi1(ibdy2) 165 276 uu_b(ji,:,Krhs_a) = 0._wp … … 170 281 END DO 171 282 DO jj = 1, jpj 172 uu_b(ji,jj,Krhs_a) = u u_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)283 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 173 284 END DO 174 285 END DO … … 176 287 ! 177 288 DO ji = mi0(ibdy1), mi1(ibdy2) 178 zub(ji,:) = 0._wp ! Correct transport289 zub(ji,:) = 0._wp 179 290 DO jk = 1, jpkm1 180 291 DO jj = 1, jpj … … 192 303 END DO 193 304 ! 194 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate195 ibdy1 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1196 ibdy2 = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1305 ibdy1 = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 306 ibdy2 = jpiglo - ( nn_hls + 1 ) ! 307 IF( .NOT.ln_dynspg_ts ) THEN 197 308 DO ji = mi0(ibdy1), mi1(ibdy2) 198 zvb(ji,:) = 0._wp309 vv_b(ji,:,Krhs_a) = 0._wp 199 310 DO jk = 1, jpkm1 200 311 DO jj = 1, jpj 312 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 313 END DO 314 END DO 315 DO jj = 1, jpj 316 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 317 END DO 318 END DO 319 ENDIF 320 321 DO ji = mi0(ibdy1), mi1(ibdy2) 322 zvb(ji,:) = 0._wp 323 DO jk = 1, jpkm1 324 DO jj = 1, jpj 201 325 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 202 END DO 203 END DO 326 END DO 327 END DO 328 DO jj = 1, jpj 329 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 330 END DO 331 DO jk = 1, jpkm1 204 332 DO jj = 1, jpj 205 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)206 END DO207 DO jk = 1, jpkm1208 DO jj = 1, jpj209 333 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 210 END DO 211 END DO 212 END DO 213 ENDIF 334 END DO 335 END DO 336 END DO 214 337 ! 215 338 ENDIF … … 217 340 ! --- South --- ! 218 341 IF( lk_south ) THEN 219 jbdy1 = nn_hls + 2 ! halo + land + 1220 jbdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells221 ! 222 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport342 jbdy1 = nn_hls + 2 343 jbdy2 = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() 344 ! 345 IF( .NOT.ln_dynspg_ts ) THEN 223 346 DO jj = mj0(jbdy1), mj1(jbdy2) 224 347 vv_b(:,jj,Krhs_a) = 0._wp … … 229 352 END DO 230 353 DO ji=1,jpi 231 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 354 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 355 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 232 356 END DO 233 357 END DO … … 235 359 ! 236 360 DO jj = mj0(jbdy1), mj1(jbdy2) 237 zvb(:,jj) = 0._wp ! Correct transport361 zvb(:,jj) = 0._wp 238 362 DO jk=1,jpkm1 239 363 DO ji=1,jpi … … 251 375 END DO 252 376 ! 253 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 254 DO jj = mj0(jbdy1), mj1(jbdy2) 255 zub(:,jj) = 0._wp 256 DO jk = 1, jpkm1 257 DO ji = 1, jpi 258 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 259 END DO 260 END DO 377 DO jj = mj0(jbdy1), mj1(jbdy2) 378 zub(:,jj) = 0._wp 379 DO jk = 1, jpkm1 261 380 DO ji = 1, jpi 262 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 263 END DO 264 DO jk = 1, jpkm1 265 DO ji = 1, jpi 266 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 267 END DO 268 END DO 269 END DO 270 ENDIF 381 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 382 END DO 383 END DO 384 DO ji = 1, jpi 385 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 386 END DO 387 DO jk = 1, jpkm1 388 DO ji = 1, jpi 389 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 390 END DO 391 END DO 392 END DO 271 393 ! 272 394 ENDIF … … 274 396 ! --- North --- ! 275 397 IF( lk_north ) THEN 276 jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells277 jbdy2 = jpjglo - ( nn_hls + 2 ) ! halo + land + 1278 ! 279 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport398 jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy() 399 jbdy2 = jpjglo - ( nn_hls + 2 ) 400 ! 401 IF( .NOT.ln_dynspg_ts ) THEN 280 402 DO jj = mj0(jbdy1), mj1(jbdy2) 281 403 vv_b(:,jj,Krhs_a) = 0._wp … … 286 408 END DO 287 409 DO ji=1,jpi 288 vv_b(ji,jj,Krhs_a) = v v_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a)410 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 289 411 END DO 290 412 END DO … … 292 414 ! 293 415 DO jj = mj0(jbdy1), mj1(jbdy2) 294 zvb(:,jj) = 0._wp ! Correct transport416 zvb(:,jj) = 0._wp 295 417 DO jk=1,jpkm1 296 418 DO ji=1,jpi … … 308 430 END DO 309 431 ! 310 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate311 jbdy1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1312 jbdy2 = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1432 jbdy1 = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 433 jbdy2 = jpjglo - ( nn_hls + 1 ) 434 IF( .NOT.ln_dynspg_ts ) THEN 313 435 DO jj = mj0(jbdy1), mj1(jbdy2) 314 zub(:,jj) = 0._wp436 uu_b(:,jj,Krhs_a) = 0._wp 315 437 DO jk = 1, jpkm1 316 438 DO ji = 1, jpi 317 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 318 END DO 319 END DO 439 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 440 END DO 441 END DO 442 DO ji=1,jpi 443 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 444 END DO 445 END DO 446 ENDIF 447 448 DO jj = mj0(jbdy1), mj1(jbdy2) 449 zub(:,jj) = 0._wp 450 DO jk = 1, jpkm1 320 451 DO ji = 1, jpi 321 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 322 END DO 323 DO jk = 1, jpkm1 324 DO ji = 1, jpi 452 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 453 END DO 454 END DO 455 DO ji = 1, jpi 456 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 457 END DO 458 DO jk = 1, jpkm1 459 DO ji = 1, jpi 325 460 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 326 END DO 327 END DO 328 END DO 329 ENDIF 461 END DO 462 END DO 463 END DO 330 464 ! 331 465 ENDIF … … 349 483 IF( lk_west ) THEN 350 484 istart = nn_hls + 2 ! halo + land + 1 351 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells485 iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells 352 486 DO ji = mi0(istart), mi1(iend) 353 487 DO jj=1,jpj … … 360 494 !--- East ---! 361 495 IF( lk_east ) THEN 362 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1363 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1496 istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 497 iend = jpiglo - ( nn_hls + 1 ) 364 498 DO ji = mi0(istart), mi1(iend) 365 499 … … 368 502 END DO 369 503 END DO 370 istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells371 iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1504 istart = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox() 505 iend = jpiglo - ( nn_hls + 2 ) 372 506 DO ji = mi0(istart), mi1(iend) 373 507 DO jj=1,jpj … … 379 513 !--- South ---! 380 514 IF( lk_south ) THEN 381 jstart = nn_hls + 2 ! halo + land + 1382 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells515 jstart = nn_hls + 2 516 jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() 383 517 DO jj = mj0(jstart), mj1(jend) 384 518 … … 392 526 !--- North ---! 393 527 IF( lk_north ) THEN 394 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1395 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1528 jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 529 jend = jpjglo - ( nn_hls + 1 ) 396 530 DO jj = mj0(jstart), mj1(jend) 397 531 DO ji=1,jpi … … 399 533 END DO 400 534 END DO 401 jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells402 jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1535 jstart = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy() 536 jend = jpjglo - ( nn_hls + 2 ) 403 537 DO jj = mj0(jstart), mj1(jend) 404 538 DO ji=1,jpi … … 426 560 !--- West ---! 427 561 IF( lk_west ) THEN 428 istart = nn_hls + 2 ! halo + land + 1429 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells562 istart = nn_hls + 2 563 iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() 430 564 DO ji = mi0(istart), mi1(iend) 431 565 DO jj=1,jpj … … 438 572 !--- East ---! 439 573 IF( lk_east ) THEN 440 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1441 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1574 istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 575 iend = jpiglo - ( nn_hls + 1 ) 442 576 DO ji = mi0(istart), mi1(iend) 443 577 DO jj=1,jpj … … 445 579 END DO 446 580 END DO 447 istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells448 iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1581 istart = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox() 582 iend = jpiglo - ( nn_hls + 2 ) 449 583 DO ji = mi0(istart), mi1(iend) 450 584 DO jj=1,jpj … … 456 590 !--- South ---! 457 591 IF( lk_south ) THEN 458 jstart = nn_hls + 2 ! halo + land + 1459 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells592 jstart = nn_hls + 2 593 jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() 460 594 DO jj = mj0(jstart), mj1(jend) 461 595 DO ji=1,jpi … … 468 602 !--- North ---! 469 603 IF( lk_north ) THEN 470 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1471 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1604 jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 605 jend = jpjglo - ( nn_hls + 1 ) 472 606 DO jj = mj0(jstart), mj1(jend) 473 607 DO ji=1,jpi … … 475 609 END DO 476 610 END DO 477 jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells478 jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1611 jstart = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy() 612 jend = jpjglo - ( nn_hls + 2 ) 479 613 DO jj = mj0(jstart), mj1(jend) 480 614 DO ji=1,jpi … … 493 627 INTEGER, INTENT(in) :: kt 494 628 !! 495 INTEGER :: ji, jj496 629 LOGICAL :: ll_int_cons 497 630 !!---------------------------------------------------------------------- … … 517 650 ! 518 651 IF( ll_int_cons ) THEN ! Conservative interpolation 519 ! order matters here !!!!!! 520 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 521 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 522 ! 523 bdy_tinterp = 1 524 CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After 525 CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb ) 526 ! 527 bdy_tinterp = 2 528 CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before 529 CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb ) 652 IF ( lk_tint2d_notinterp ) THEN 653 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b_const ) 654 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b_const ) 655 ! Divergence conserving correction terms: 656 CALL Agrif_Bc_variable( ub2b_cor_id, calledweight=1._wp, procname= ub2b_cor ) 657 CALL Agrif_Bc_variable( vb2b_cor_id, calledweight=1._wp, procname= vb2b_cor ) 658 ELSE 659 ! order matters here !!!!!! 660 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 661 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 662 ! 663 bdy_tinterp = 1 664 CALL Agrif_Bc_variable( unb_interp_id , calledweight=1._wp, procname=interpunb ) ! After 665 CALL Agrif_Bc_variable( vnb_interp_id , calledweight=1._wp, procname=interpvnb ) 666 ! 667 bdy_tinterp = 2 668 CALL Agrif_Bc_variable( unb_interp_id , calledweight=0._wp, procname=interpunb ) ! Before 669 CALL Agrif_Bc_variable( vnb_interp_id , calledweight=0._wp, procname=interpvnb ) 670 ENDIF 530 671 ELSE ! Linear interpolation 531 672 ! 532 673 ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp 533 CALL Agrif_Bc_variable( unb_i d, procname=interpunb )534 CALL Agrif_Bc_variable( vnb_i d, procname=interpvnb )674 CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb ) 675 CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb ) 535 676 ENDIF 536 677 Agrif_UseSpecialValue = .FALSE. … … 561 702 ! --- West --- ! 562 703 IF(lk_west) THEN 563 istart = nn_hls + 2 ! halo + land + 1564 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells704 istart = nn_hls + 2 ! halo + land + 1 705 iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells 565 706 DO ji = mi0(istart), mi1(iend) 566 707 DO jj = 1, jpj … … 572 713 ! --- East --- ! 573 714 IF(lk_east) THEN 574 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1575 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1715 istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1 716 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 576 717 DO ji = mi0(istart), mi1(iend) 577 718 DO jj = 1, jpj … … 583 724 ! --- South --- ! 584 725 IF(lk_south) THEN 585 jstart = nn_hls + 2 ! halo + land + 1586 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells726 jstart = nn_hls + 2 ! halo + land + 1 727 jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells 587 728 DO jj = mj0(jstart), mj1(jend) 588 729 DO ji = 1, jpi … … 594 735 ! --- North --- ! 595 736 IF(lk_north) THEN 596 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1597 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1737 jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1 738 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 598 739 DO jj = mj0(jstart), mj1(jend) 599 740 DO ji = 1, jpi … … 620 761 ! --- West --- ! 621 762 IF(lk_west) THEN 622 istart = nn_hls + 2 ! halo + land + 1623 iend = nn_hls + 1 + nbghostcells 763 istart = nn_hls + 2 ! halo + land + 1 764 iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells 624 765 DO ji = mi0(istart), mi1(iend) 625 766 DO jj = 1, jpj … … 631 772 ! --- East --- ! 632 773 IF(lk_east) THEN 633 istart = jpiglo - ( nn_hls + nbghostcells ) 634 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1774 istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1 775 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 635 776 DO ji = mi0(istart), mi1(iend) 636 777 DO jj = 1, jpj … … 642 783 ! --- South --- ! 643 784 IF(lk_south) THEN 644 jstart = nn_hls + 2 ! halo + land + 1645 jend = nn_hls + 1 + nbghostcells 785 jstart = nn_hls + 2 ! halo + land + 1 786 jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells 646 787 DO jj = mj0(jstart), mj1(jend) 647 788 DO ji = 1, jpi … … 653 794 ! --- North --- ! 654 795 IF(lk_north) THEN 655 jstart = jpjglo - ( nn_hls + nbghostcells ) 656 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1796 jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1 797 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 657 798 DO jj = mj0(jstart), mj1(jend) 658 799 DO ji = 1, jpi … … 679 820 Agrif_SpecialValue = 0.e0 680 821 Agrif_UseSpecialValue = .TRUE. 822 l_vremap = ln_vert_remap 681 823 ! 682 824 CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm ) 683 825 ! 684 826 Agrif_UseSpecialValue = .FALSE. 827 l_vremap = .FALSE. 685 828 ! 686 829 END SUBROUTINE Agrif_avm … … 688 831 689 832 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 690 !!----------------------------------------------------------------------691 !! *** ROUTINE interptsn ***692 833 !!---------------------------------------------------------------------- 693 834 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab … … 699 840 INTEGER :: item 700 841 ! vertical interpolation: 701 REAL(wp) :: zhtot 702 REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin 703 REAL(wp), DIMENSION(k1:k2) :: h_in, z_in842 REAL(wp) :: zhtot, zwgt 843 REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin, tabin_i 844 REAL(wp), DIMENSION(k1:k2) :: z_in, h_in_i, z_in_i 704 845 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 705 846 !!---------------------------------------------------------------------- … … 720 861 END DO 721 862 722 IF( l_vremap .OR. l_ini_child) THEN 723 ! Interpolate thicknesses 863 IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN 864 865 ! Fill cell depths (i.e. gdept) to be interpolated 724 866 ! Warning: these are masked, hence extrapolated prior interpolation. 725 DO jk=k1,k2 726 DO jj=j1,j2 727 DO ji=i1,i2 728 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 729 730 END DO 731 END DO 732 END DO 733 734 ! Extrapolate thicknesses in partial bottom cells: 735 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 736 IF (ln_zps) THEN 737 DO jj=j1,j2 738 DO ji=i1,i2 739 jk = mbkt(ji,jj) 740 ptab(ji,jj,jk,jpts+1) = 0._wp 741 END DO 742 END DO 743 END IF 744 867 DO jj=j1,j2 868 DO ji=i1,i2 869 ptab(ji,jj,k1,jpts+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kmm_a) 870 DO jk=k1+1,k2 871 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * & 872 & ( ptab(ji,jj,jk-1,jpts+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kmm_a)+e3t(ji,jj,jk,Kmm_a)) ) 873 END DO 874 END DO 875 END DO 876 745 877 ! Save ssh at last level: 746 878 IF (.NOT.ln_linssh) THEN 747 879 ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 748 ELSE749 ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp750 880 END IF 751 881 ENDIF … … 758 888 IF( l_vremap .OR. l_ini_child ) THEN 759 889 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 760 761 890 DO jj=j1,j2 762 891 DO ji=i1,i2 763 ts(ji,jj,:,:,Krhs_a) = 0. 764 ! IF( l_ini_child) ts(ji,jj,:,:,Krhs_a) = ptab(ji,jj,:,1:jpts) 892 ts(ji,jj,:,:,Krhs_a) = 0. 893 ! 894 ! Build vertical grids: 765 895 N_in = mbkt_parent(ji,jj) 766 zhtot = 0._wp 767 DO jk=1,N_in !k2 = jpk of parent grid 768 IF (jk==N_in) THEN 769 h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot 770 ELSE 771 h_in(jk) = ptab(ji,jj,jk,n2) 772 ENDIF 773 zhtot = zhtot + h_in(jk) 774 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 775 END DO 776 z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj) 777 DO jk=2,N_in 778 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 779 END DO 780 781 N_out = 0 782 DO jk=1,jpk ! jpk of child grid 783 IF (tmask(ji,jj,jk) == 0._wp) EXIT 784 N_out = N_out + 1 896 ! Input grid (account for partial cells if any): 897 DO jk=1,N_in 898 z_in(jk) = ptab(ji,jj,jk,n2) - ptab(ji,jj,k2,n2) 899 tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts) 900 END DO 901 902 ! Intermediate grid: 903 IF ( l_vremap ) THEN 904 DO jk = 1, N_in 905 h_in_i(jk) = e3t0_parent(ji,jj,jk) * & 906 & (1._wp + ptab(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj))) 907 END DO 908 z_in_i(1) = 0.5_wp * h_in_i(1) 909 DO jk=2,N_in 910 z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) ) 911 END DO 912 z_in_i(1:N_in) = z_in_i(1:N_in) - ptab(ji,jj,k2,n2) 913 ENDIF 914 915 ! Output (Child) grid: 916 N_out = mbkt(ji,jj) 917 DO jk=1,N_out 785 918 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 786 919 END DO 787 788 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj) 920 z_out(1) = 0.5_wp * h_out(1) 789 921 DO jk=2,N_out 790 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 791 END DO 922 z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) ) 923 END DO 924 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a) 792 925 793 926 IF (N_in*N_out > 0) THEN 794 927 IF( l_ini_child ) THEN 795 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), &928 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 796 929 & z_out(1:N_out),N_in,N_out,jpts) 797 930 ELSE 798 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 931 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),tabin_i(1:N_in,1:jpts), & 932 & z_in_i(1:N_in),N_in,N_in,jpts) 933 CALL reconstructandremap(tabin_i(1:N_in,1:jpts),h_in_i(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 799 934 & h_out(1:N_out),N_in,N_out,jpts) 800 935 ENDIF … … 806 941 ELSE 807 942 808 DO jn=1, jpts 809 ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 943 IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells 944 ! linear vertical interpolation 945 DO jj=j1,j2 946 DO ji=i1,i2 947 ! 948 N_in = mbkt(ji,jj) 949 N_out = mbkt(ji,jj) 950 z_in(1) = ptab(ji,jj,1,n2) 951 tabin(1,1:jpts) = ptab(ji,jj,1,1:jpts) 952 DO jk=2, N_in 953 z_in(jk) = ptab(ji,jj,jk,n2) 954 tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts) 955 END DO 956 IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - ptab(ji,jj,k2,n2) 957 z_out(1) = 0.5_wp * e3t(ji,jj,1,Krhs_a) 958 DO jk=2, N_out 959 z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Krhs_a) + e3t(ji,jj,jk,Krhs_a)) 960 END DO 961 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a) 962 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ptab(ji,jj,1:N_out,1:jpts), & 963 & z_out(1:N_out),N_in,N_out,jpts) 964 END DO 965 END DO 966 ENDIF 967 968 DO jn =1, jpts 969 ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a) = ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 810 970 END DO 811 971 ENDIF … … 829 989 ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a) 830 990 ELSE 831 hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 991 IF( l_ini_child ) THEN 992 ssh(i1:i2,j1:j2,Kmm_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 993 ELSE 994 hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 995 ENDIF 832 996 ENDIF 833 997 ! … … 870 1034 END DO 871 1035 872 IF( l_vremap .OR. l_ini_child ) THEN1036 IF( l_vremap .OR. l_ini_child ) THEN 873 1037 ! Extrapolate thicknesses in partial bottom cells: 874 1038 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on … … 909 1073 zhtot = 0._wp 910 1074 DO jk=1,N_in 911 IF (jk==N_in) THEN 912 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1075 !IF (jk==N_in) THEN 1076 ! h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1077 !ELSE 1078 ! h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 1079 !ENDIF 1080 IF ( l_vremap ) THEN 1081 h_in(jk) = e3u0_parent(ji,jj,jk) 913 1082 ELSE 914 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 1083 IF (jk==N_in) THEN 1084 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1085 ELSE 1086 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 1087 ENDIF 915 1088 ENDIF 916 1089 zhtot = zhtot + h_in(jk) … … 923 1096 z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 924 1097 DO jk=2,N_in 925 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)1098 z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk)+h_in(jk-1)) 926 1099 END DO 927 1100 … … 935 1108 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj) 936 1109 DO jk=2,N_out 937 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)1110 z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1) + h_out(jk)) 938 1111 END DO 939 1112 … … 1031 1204 zhtot = 0._wp 1032 1205 DO jk=1,N_in 1033 IF (jk==N_in) THEN 1034 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1206 !IF (jk==N_in) THEN 1207 ! h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1208 !ELSE 1209 ! h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1210 !ENDIF 1211 IF (l_vremap) THEN 1212 h_in(jk) = e3v0_parent(ji,jj,jk) 1035 1213 ELSE 1036 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1214 IF (jk==N_in) THEN 1215 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1216 ELSE 1217 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1218 ENDIF 1037 1219 ENDIF 1038 1220 zhtot = zhtot + h_in(jk) … … 1046 1228 z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj) 1047 1229 DO jk=2,N_in 1048 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk)1230 z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk-1)+h_in(jk)) 1049 1231 END DO 1050 1232 … … 1058 1240 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj) 1059 1241 DO jk=2,N_out 1060 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk)1242 z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1)+h_out(jk)) 1061 1243 END DO 1062 1244 … … 1215 1397 END SUBROUTINE interpub2b 1216 1398 1399 SUBROUTINE interpub2b_const( ptab, i1, i2, j1, j2, before ) 1400 !!---------------------------------------------------------------------- 1401 !! *** ROUTINE interpub2b_const *** 1402 !!---------------------------------------------------------------------- 1403 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1404 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1405 LOGICAL , INTENT(in ) :: before 1406 ! 1407 REAL(wp) :: zrhoy 1408 !!---------------------------------------------------------------------- 1409 IF( before ) THEN 1410 ! IF ( ln_bt_fw ) THEN 1411 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2) 1412 ! ELSE 1413 ! ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2) 1414 ! ENDIF 1415 ELSE 1416 zrhoy = Agrif_Rhoy() 1417 ! 1418 ubdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) & 1419 & / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1) 1420 ! 1421 ENDIF 1422 ! 1423 END SUBROUTINE interpub2b_const 1424 1425 1426 SUBROUTINE ub2b_cor( ptab, i1, i2, j1, j2, before ) 1427 !!---------------------------------------------------------------------- 1428 !! *** ROUTINE ub2b_cor *** 1429 !!---------------------------------------------------------------------- 1430 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1431 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1432 LOGICAL , INTENT(in ) :: before 1433 ! 1434 INTEGER :: ji, jj 1435 REAL(wp) :: zrhox, zrhoy, zx 1436 !!---------------------------------------------------------------------- 1437 IF( before ) THEN 1438 ptab(:,:) = 0._wp 1439 DO ji=i1+1,i2-1 1440 DO jj=j1+1,j2 1441 ptab(ji,jj) = 0.25_wp*( ( vb2_b(ji+1,jj )*e1v(ji+1,jj ) & 1442 & -vb2_b(ji-1,jj )*e1v(ji-1,jj ) ) & 1443 & -( vb2_b(ji+1,jj-1)*e1v(ji+1,jj-1) & 1444 & -vb2_b(ji-1,jj-1)*e1v(ji-1,jj-1) ) ) 1445 END DO 1446 END DO 1447 ELSE 1448 ! 1449 zrhox = Agrif_Rhox() 1450 zrhoy = Agrif_Rhoy() 1451 DO ji=i1,i2 1452 DO jj=j1,j2 1453 IF (utint_stage(ji,jj)==0) THEN 1454 zx = 2._wp*MOD(ABS(mig0(ji)-nbghostcells-1), INT(Agrif_Rhox()))/zrhox - 1._wp 1455 ubdy(ji,jj) = ubdy(ji,jj) + 0.25_wp*(1._wp-zx*zx) * ptab(ji,jj) & 1456 & / zrhoy *r1_e2u(ji,jj) * umask(ji,jj,1) 1457 utint_stage(ji,jj) = 1 1458 ENDIF 1459 END DO 1460 END DO 1461 ! 1462 ENDIF 1463 ! 1464 END SUBROUTINE ub2b_cor 1465 1217 1466 1218 1467 SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before ) … … 1252 1501 1253 1502 1503 SUBROUTINE interpvb2b_const( ptab, i1, i2, j1, j2, before ) 1504 !!---------------------------------------------------------------------- 1505 !! *** ROUTINE interpub2b_const *** 1506 !!---------------------------------------------------------------------- 1507 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1508 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1509 LOGICAL , INTENT(in ) :: before 1510 ! 1511 REAL(wp) :: zrhox 1512 !!---------------------------------------------------------------------- 1513 IF( before ) THEN 1514 ! IF ( ln_bt_fw ) THEN 1515 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 1516 ! ELSE 1517 ! ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2) 1518 ! ENDIF 1519 ELSE 1520 zrhox = Agrif_Rhox() 1521 ! 1522 vbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) & 1523 & / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1) 1524 ! 1525 ENDIF 1526 ! 1527 END SUBROUTINE interpvb2b_const 1528 1529 1530 SUBROUTINE vb2b_cor( ptab, i1, i2, j1, j2, before ) 1531 !!---------------------------------------------------------------------- 1532 !! *** ROUTINE vb2b_cor *** 1533 !!---------------------------------------------------------------------- 1534 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1535 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1536 LOGICAL , INTENT(in ) :: before 1537 ! 1538 INTEGER :: ji, jj 1539 REAL(wp) :: zrhox, zrhoy, zy 1540 !!---------------------------------------------------------------------- 1541 IF( before ) THEN 1542 ptab(:,:) = 0._wp 1543 DO ji=i1+1,i2-1 1544 DO jj=j1+1,j2 1545 ptab(ji,jj) = 0.25_wp*( ( ub2_b(ji ,jj+1)*e2u(ji ,jj+1) & 1546 & -ub2_b(ji ,jj-1)*e2u(ji ,jj-1) ) & 1547 & -( ub2_b(ji-1,jj+1)*e2u(ji-1,jj+1) & 1548 & -ub2_b(ji-1,jj-1)*e2u(ji-1,jj-1) ) ) 1549 END DO 1550 END DO 1551 ELSE 1552 ! 1553 zrhox = Agrif_Rhox() 1554 zrhoy = Agrif_Rhoy() 1555 DO ji=i1,i2 1556 DO jj=j1,j2 1557 IF (vtint_stage(ji,jj)==0) THEN 1558 zy = 2._wp*MOD(ABS(mjg0(jj)-nbghostcells-1), INT(Agrif_Rhoy()))/zrhoy - 1._wp 1559 vbdy(ji,jj) = vbdy(ji,jj) + 0.25_wp*(1._wp-zy*zy) * ptab(ji,jj) & 1560 & / zrhox * r1_e1v(ji,jj) * vmask(ji,jj,1) 1561 vtint_stage(ji,jj) = 1 1562 ENDIF 1563 END DO 1564 END DO 1565 ! 1566 ENDIF 1567 ! 1568 END SUBROUTINE vb2b_cor 1569 1570 1254 1571 SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before ) 1255 1572 !!---------------------------------------------------------------------- … … 1273 1590 WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', & 1274 1591 & ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), & 1275 & mig0(ji), m ig0(jj), jk1592 & mig0(ji), mjg0(jj), jk 1276 1593 ! kindic_agr = kindic_agr + 1 1277 1594 ENDIF … … 1283 1600 ! 1284 1601 END SUBROUTINE interpe3t 1602 1603 1604 SUBROUTINE interpe3t0_vremap( ptab, i1, i2, j1, j2, k1, k2, before ) 1605 !!---------------------------------------------------------------------- 1606 !! *** ROUTINE interpe3t0_vremap *** 1607 !!---------------------------------------------------------------------- 1608 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 1609 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1610 LOGICAL , INTENT(in ) :: before 1611 ! 1612 INTEGER :: ji, jj, jk 1613 REAL(wp) :: zh 1614 !!---------------------------------------------------------------------- 1615 ! 1616 IF( before ) THEN 1617 IF ( ln_zps ) THEN 1618 DO jk = k1, k2 1619 DO jj = j1, j2 1620 DO ji = i1, i2 1621 ptab(ji, jj, jk) = e3t_1d(jk) 1622 END DO 1623 END DO 1624 END DO 1625 ELSE 1626 ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2) 1627 ENDIF 1628 ELSE 1629 ! 1630 DO jk = k1, k2 1631 DO jj = j1, j2 1632 DO ji = i1, i2 1633 e3t0_parent(ji,jj,jk) = ptab(ji,jj,jk) 1634 END DO 1635 END DO 1636 END DO 1637 1638 ! Retrieve correct scale factor at the bottom: 1639 DO jj = j1, j2 1640 DO ji = i1, i2 1641 zh = 0._wp 1642 DO jk = 1, mbkt_parent(ji, jj)-1 1643 zh = zh + e3t0_parent(ji,jj,jk) 1644 END DO 1645 e3t0_parent(ji,jj,mbkt_parent(ji,jj)) = ht0_parent(ji, jj) - zh 1646 END DO 1647 END DO 1648 1649 ENDIF 1650 ! 1651 END SUBROUTINE interpe3t0_vremap 1652 1285 1653 1286 1654 SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before ) … … 1429 1797 SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before ) 1430 1798 !!---------------------------------------------------------------------- 1431 !! *** ROUTINE interp sshn***1799 !! *** ROUTINE interpmbkt *** 1432 1800 !!---------------------------------------------------------------------- 1433 1801 INTEGER , INTENT(in ) :: i1, i2, j1, j2 … … 1448 1816 SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before ) 1449 1817 !!---------------------------------------------------------------------- 1450 !! *** ROUTINE interp sshn***1818 !! *** ROUTINE interpht0 *** 1451 1819 !!---------------------------------------------------------------------- 1452 1820 INTEGER , INTENT(in ) :: i1, i2, j1, j2 … … 1464 1832 END SUBROUTINE interpht0 1465 1833 1466 1467 SUBROUTINE agrif_initts(tabres,i1,i2,j1,j2,k1,k2,m1,m2,before) 1468 INTEGER :: i1, i2, j1, j2, k1, k2, m1, m2 1469 REAL(wp):: tabres(i1:i2,j1:j2,k1:k2,m1:m2) 1470 LOGICAL :: before 1471 1472 INTEGER :: jm 1473 1474 IF (before) THEN 1475 DO jm=1,jpts 1476 tabres(i1:i2,j1:j2,k1:k2,jm) = ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a) 1477 END DO 1478 ELSE 1479 DO jm=1,jpts 1480 ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a)=tabres(i1:i2,j1:j2,k1:k2,jm) 1481 END DO 1482 ENDIF 1483 END SUBROUTINE agrif_initts 1484 1485 1486 SUBROUTINE agrif_initssh( ptab, i1, i2, j1, j2, before ) 1487 !!---------------------------------------------------------------------- 1488 !! *** ROUTINE interpsshn *** 1489 !!---------------------------------------------------------------------- 1490 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1491 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1492 LOGICAL , INTENT(in ) :: before 1493 ! 1494 !!---------------------------------------------------------------------- 1495 ! 1496 IF( before) THEN 1497 ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kbb_a) 1498 ELSE 1499 ssh(i1:i2,j1:j2,Kbb_a) = ptab(i1:i2,j1:j2)*tmask(i1:i2,j1:j2,1) 1500 ENDIF 1501 ! 1502 END SUBROUTINE agrif_initssh 1834 SUBROUTINE Agrif_check_bat( iindic ) 1835 !!---------------------------------------------------------------------- 1836 !! *** ROUTINE Agrif_check_bat *** 1837 !!---------------------------------------------------------------------- 1838 INTEGER, INTENT(inout) :: iindic 1839 !! 1840 INTEGER :: ji, jj 1841 INTEGER :: istart, iend, jstart, jend, ispon 1842 !!---------------------------------------------------------------------- 1843 ! 1844 ! 1845 ! --- West --- ! 1846 IF(lk_west) THEN 1847 ispon = nn_sponge_len * Agrif_irhox() 1848 istart = nn_hls + 2 ! halo + land + 1 1849 iend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge 1850 jstart = nn_hls + 2 1851 jend = jpjglo - nn_hls - 1 1852 DO ji = mi0(istart), mi1(iend) 1853 DO jj = mj0(jstart), mj1(jend) 1854 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1855 END DO 1856 DO jj = mj0(jstart), mj1(jend-1) 1857 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1858 END DO 1859 END DO 1860 DO ji = mi0(istart), mi1(iend-1) 1861 DO jj = mj0(jstart), mj1(jend) 1862 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1863 END DO 1864 END DO 1865 ENDIF 1866 ! 1867 ! --- East --- ! 1868 IF(lk_east) THEN 1869 ispon = nn_sponge_len * Agrif_irhox() 1870 istart = jpiglo - ( nn_hls + nbghostcells + ispon ) ! halo + land + nbghostcells + sponge - 1 1871 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 1872 jstart = nn_hls + 2 1873 jend = jpjglo - nn_hls - 1 1874 DO ji = mi0(istart), mi1(iend) 1875 DO jj = mj0(jstart), mj1(jend) 1876 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1877 END DO 1878 DO jj = mj0(jstart), mj1(jend-1) 1879 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1880 END DO 1881 END DO 1882 DO ji = mi0(istart+1), mi1(iend-1) 1883 DO jj = mj0(jstart), mj1(jend) 1884 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1885 END DO 1886 END DO 1887 ENDIF 1888 ! 1889 ! --- South --- ! 1890 IF(lk_south) THEN 1891 ispon = nn_sponge_len * Agrif_irhoy() 1892 jstart = nn_hls + 2 ! halo + land + 1 1893 jend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge 1894 istart = nn_hls + 2 1895 iend = jpiglo - nn_hls - 1 1896 DO jj = mj0(jstart), mj1(jend) 1897 DO ji = mi0(istart), mi1(iend) 1898 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1899 END DO 1900 DO ji = mi0(istart), mi1(iend-1) 1901 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1902 END DO 1903 END DO 1904 DO jj = mj0(jstart), mj1(jend-1) 1905 DO ji = mi0(istart), mi1(iend) 1906 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1907 END DO 1908 END DO 1909 ENDIF 1910 ! 1911 ! --- North --- ! 1912 IF(lk_north) THEN 1913 ispon = nn_sponge_len * Agrif_irhoy() 1914 jstart = jpjglo - ( nn_hls + nbghostcells + ispon) ! halo + land + nbghostcells +sponge - 1 1915 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 1916 istart = nn_hls + 2 1917 iend = jpiglo - nn_hls - 1 1918 DO jj = mj0(jstart), mj1(jend) 1919 DO ji = mi0(istart), mi1(iend) 1920 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1921 END DO 1922 DO ji = mi0(istart), mi1(iend-1) 1923 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1924 END DO 1925 END DO 1926 DO jj = mj0(jstart+1), mj1(jend-1) 1927 DO ji = mi0(istart), mi1(iend) 1928 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1929 END DO 1930 END DO 1931 ENDIF 1932 ! 1933 END SUBROUTINE Agrif_check_bat 1503 1934 1504 1935 #else -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/NST/agrif_oce_sponge.F90
r14066 r14098 28 28 PRIVATE 29 29 30 PUBLIC Agrif_Sponge, Agrif_Sponge_ Tra, Agrif_Sponge_Dyn30 PUBLIC Agrif_Sponge, Agrif_Sponge_2d, Agrif_Sponge_Tra, Agrif_Sponge_Dyn 31 31 PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge 32 PUBLIC interpunb_sponge, interpvnb_sponge 32 33 33 34 !! * Substitutions … … 46 47 !!---------------------------------------------------------------------- 47 48 REAL(wp) :: zcoef ! local scalar 48 49 INTEGER :: istart, iend, jstart, jend 49 50 !!---------------------------------------------------------------------- 50 51 ! … … 53 54 zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot()) 54 55 55 CALL Agrif_Sponge56 56 Agrif_SpecialValue = 0._wp 57 57 Agrif_UseSpecialValue = .TRUE. 58 l_vremap = ln_vert_remap 58 59 tabspongedone_tsn = .FALSE. 59 60 ! 60 CALL Agrif_Bc_Variable( ts n_sponge_id, calledweight=zcoef, procname=interptsn_sponge )61 CALL Agrif_Bc_Variable( ts_sponge_id, calledweight=zcoef, procname=interptsn_sponge ) 61 62 ! 62 63 Agrif_UseSpecialValue = .FALSE. 64 l_vremap = .FALSE. 63 65 #endif 64 66 ! … … 81 83 Agrif_SpecialValue = 0._wp 82 84 Agrif_UseSpecialValue = ln_spc_dyn 85 l_vremap = ln_vert_remap 83 86 use_sign_north = .TRUE. 84 87 sign_north = -1._wp … … 91 94 tabspongedone_v = .FALSE. 92 95 CALL Agrif_Bc_Variable( vn_sponge_id, calledweight=zcoef, procname=interpvn_sponge ) 96 97 IF ( nn_shift_bar>0 ) THEN ! then split sponge between 2d and 3d 98 zcoef = REAL(Agrif_NbStepint(),wp)/REAL(Agrif_rhot()) ! forward tsplit 99 tabspongedone_u = .FALSE. 100 tabspongedone_v = .FALSE. 101 CALL Agrif_Bc_Variable( unb_sponge_id, calledweight=zcoef, procname=interpunb_sponge ) 102 ! 103 tabspongedone_u = .FALSE. 104 tabspongedone_v = .FALSE. 105 CALL Agrif_Bc_Variable( vnb_sponge_id, calledweight=zcoef, procname=interpvnb_sponge ) 106 ENDIF 93 107 ! 94 108 Agrif_UseSpecialValue = .FALSE. 95 109 use_sign_north = .FALSE. 110 l_vremap = .FALSE. 111 ! 96 112 #endif 97 113 ! … … 110 126 REAL(wp) :: z1_ispongearea, z1_jspongearea 111 127 REAL(wp), DIMENSION(jpi,jpj) :: ztabramp 112 #if defined key_vertical113 REAL(wp), DIMENSION(jpi,jpj) :: ztabrampu114 REAL(wp), DIMENSION(jpi,jpj) :: ztabrampv115 #endif116 REAL(wp), DIMENSION(jpjmax) :: zmskwest, zmskeast117 REAL(wp), DIMENSION(jpimax) :: zmsknorth, zmsksouth118 128 !!---------------------------------------------------------------------- 119 129 ! … … 124 134 !| | | | | 125 135 !fine : t u t u t u t u t u t u t u t u t u t u t 126 !sponge val:0 0 0 1 5/6 4/6 3/6 2/6 1/6 0 0136 !sponge val:0 1 1 1 1 5/6 4/6 3/6 2/6 1/6 0 127 137 ! | ghost | <-- sponge area -- > | 128 138 ! | points | | … … 130 140 131 141 #if defined SPONGE || defined SPONGE_TOP 132 IF (( .NOT. spongedoneT ).OR.( .NOT. spongedoneU )) THEN 133 ! 134 ! Retrieve masks at open boundaries: 135 136 IF( lk_west ) THEN ! --- West --- ! 137 ztabramp(:,:) = 0._wp 138 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 139 DO ji = mi0(ind1), mi1(ind1) 140 ztabramp(ji,:) = ssumask(ji,:) 141 END DO 142 zmskwest( 1:jpj ) = MAXVAL(ztabramp(:,:), dim=1) 143 zmskwest(jpj+1:jpjmax) = 0._wp 144 ENDIF 145 IF( lk_east ) THEN ! --- East --- ! 146 ztabramp(:,:) = 0._wp 147 ind1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 148 DO ji = mi0(ind1), mi1(ind1) 149 ztabramp(ji,:) = ssumask(ji,:) 150 END DO 151 zmskeast( 1:jpj ) = MAXVAL(ztabramp(:,:), dim=1) 152 zmskeast(jpj+1:jpjmax) = 0._wp 153 ENDIF 154 IF( lk_south ) THEN ! --- South --- ! 155 ztabramp(:,:) = 0._wp 156 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 157 DO jj = mj0(ind1), mj1(ind1) 158 ztabramp(:,jj) = ssvmask(:,jj) 159 END DO 160 zmsksouth( 1:jpi ) = MAXVAL(ztabramp(:,:), dim=2) 161 zmsksouth(jpi+1:jpimax) = 0._wp 162 ENDIF 163 IF( lk_north ) THEN ! --- North --- ! 164 ztabramp(:,:) = 0._wp 165 ind1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 166 DO jj = mj0(ind1), mj1(ind1) 167 ztabramp(:,jj) = ssvmask(:,jj) 168 END DO 169 zmsknorth( 1:jpi ) = MAXVAL(ztabramp(:,:), dim=2) 170 zmsknorth(jpi+1:jpimax) = 0._wp 171 ENDIF 172 173 ! JC: SPONGE MASKING TO BE SORTED OUT: 174 zmskwest(:) = 1._wp 175 zmskeast(:) = 1._wp 176 zmsksouth(:) = 1._wp 177 zmsknorth(:) = 1._wp 178 #if defined key_mpp_mpi 179 ! CALL mpp_max( 'AGRIF_sponge', zmskwest(:) , jpjmax ) 180 ! CALL mpp_max( 'AGRIF_Sponge', zmskeast(:) , jpjmax ) 181 ! CALL mpp_max( 'AGRIF_Sponge', zmsksouth(:), jpimax ) 182 ! CALL mpp_max( 'AGRIF_Sponge', zmsknorth(:), jpimax ) 142 ! Define ramp from boundaries towards domain interior at F-points 143 ! Store it in ztabramp 144 145 ispongearea = nn_sponge_len * Agrif_irhox() 146 z1_ispongearea = 1._wp / REAL( MAX(ispongearea,1), wp ) 147 jspongearea = nn_sponge_len * Agrif_irhoy() 148 z1_jspongearea = 1._wp / REAL( MAX(jspongearea,1), wp ) 149 150 ztabramp(:,:) = 0._wp 151 152 IF( lk_west ) THEN ! --- West --- ! 153 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 154 ind2 = nn_hls + 1 + nbghostcells + ispongearea 155 DO ji = mi0(ind1), mi1(ind2) 156 DO jj = 1, jpj 157 ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_ispongearea 158 END DO 159 END DO 160 ! ghost cells: 161 ind1 = 1 162 ind2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 163 DO ji = mi0(ind1), mi1(ind2) 164 DO jj = 1, jpj 165 ztabramp(ji,jj) = 1._wp 166 END DO 167 END DO 168 ENDIF 169 IF( lk_east ) THEN ! --- East --- ! 170 ind1 = jpiglo - ( nn_hls + nbghostcells ) - ispongearea - 1 171 ind2 = jpiglo - ( nn_hls + nbghostcells ) - 1 ! halo + land + nbghostcells - 1 172 DO ji = mi0(ind1), mi1(ind2) 173 DO jj = 1, jpj 174 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji) - ind1, wp) * z1_ispongearea ) 175 END DO 176 END DO 177 ! ghost cells: 178 ind1 = jpiglo - ( nn_hls + nbghostcells ) - 1 ! halo + land + nbghostcells - 1 179 ind2 = jpiglo - 1 180 DO ji = mi0(ind1), mi1(ind2) 181 DO jj = 1, jpj 182 ztabramp(ji,jj) = 1._wp 183 END DO 184 END DO 185 ENDIF 186 IF( lk_south ) THEN ! --- South --- ! 187 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 188 ind2 = nn_hls + 1 + nbghostcells + jspongearea 189 DO jj = mj0(ind1), mj1(ind2) 190 DO ji = 1, jpi 191 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj), wp) * z1_jspongearea ) 192 END DO 193 END DO 194 ! ghost cells: 195 ind1 = 1 196 ind2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 197 DO jj = mj0(ind1), mj1(ind2) 198 DO ji = 1, jpi 199 ztabramp(ji,jj) = 1._wp 200 END DO 201 END DO 202 ENDIF 203 IF( lk_north ) THEN ! --- North --- ! 204 ind1 = jpjglo - ( nn_hls + nbghostcells ) - jspongearea - 1 205 ind2 = jpjglo - ( nn_hls + nbghostcells ) - 1 ! halo + land + nbghostcells - 1 206 DO jj = mj0(ind1), mj1(ind2) 207 DO ji = 1, jpi 208 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj) - ind1, wp) * z1_jspongearea ) 209 END DO 210 END DO 211 ! ghost cells: 212 ind1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 213 ind2 = jpjglo 214 DO jj = mj0(ind1), mj1(ind2) 215 DO ji = 1, jpi 216 ztabramp(ji,jj) = 1._wp 217 END DO 218 END DO 219 ENDIF 220 ! 221 ! Tracers 222 fspu(:,:) = 0._wp 223 fspv(:,:) = 0._wp 224 DO_2D( 0, 0, 0, 0 ) 225 fspu(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji,jj-1) ) * ssumask(ji,jj) 226 fspv(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji-1,jj) ) * ssvmask(ji,jj) 227 END_2D 228 229 ! Dynamics 230 fspt(:,:) = 0._wp 231 fspf(:,:) = 0._wp 232 DO_2D( 0, 0, 0, 0 ) 233 fspt(ji,jj) = 0.25_wp * ( ztabramp(ji ,jj ) + ztabramp(ji-1,jj ) & 234 & +ztabramp(ji ,jj-1) + ztabramp(ji-1,jj-1) ) * ssmask(ji,jj) 235 fspf(ji,jj) = ztabramp(ji,jj) * ssvmask(ji,jj) * ssvmask(ji,jj+1) 236 END_2D 237 238 CALL lbc_lnk_multi( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp, fspt, 'T', 1._wp, fspf, 'F', 1._wp ) 239 ! 240 ! Remove vertical interpolation where not needed: 241 ! (A null value in mbkx arrays does the job) 242 WHERE (fspu(:,:) == 0._wp) mbku_parent(:,:) = 0 243 WHERE (fspv(:,:) == 0._wp) mbkv_parent(:,:) = 0 244 WHERE (fspt(:,:) == 0._wp) mbkt_parent(:,:) = 0 245 ! 183 246 #endif 184 185 ! Define ramp from boundaries towards domain interior at T-points 186 ! Store it in ztabramp 187 188 ispongearea = nn_sponge_len * Agrif_irhox() 189 z1_ispongearea = 1._wp / REAL( ispongearea, wp ) 190 jspongearea = nn_sponge_len * Agrif_irhoy() 191 z1_jspongearea = 1._wp / REAL( jspongearea, wp ) 192 193 ztabramp(:,:) = 0._wp 194 195 ! Trick to remove sponge in 2DV domains: 196 IF ( nbcellsx <= 3 ) ispongearea = -1 197 IF ( nbcellsy <= 3 ) jspongearea = -1 198 199 IF( lk_west ) THEN ! --- West --- ! 200 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 201 ind2 = nn_hls + 1 + nbghostcells + ispongearea 202 DO ji = mi0(ind1), mi1(ind2) 203 DO jj = 1, jpj 204 ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_ispongearea * zmskwest(jj) 205 END DO 206 END DO 207 ! ghost cells: 208 ind1 = 1 209 ind2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 210 DO ji = mi0(ind1), mi1(ind2) 211 DO jj = 1, jpj 212 ztabramp(ji,jj) = zmskwest(jj) 213 END DO 214 END DO 215 ENDIF 216 IF( lk_east ) THEN ! --- East --- ! 217 ind1 = jpiglo - ( nn_hls + nbghostcells ) - ispongearea 218 ind2 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 219 DO ji = mi0(ind1), mi1(ind2) 220 DO jj = 1, jpj 221 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji) - ind1, wp) * z1_ispongearea ) * zmskeast(jj) 222 END DO 223 END DO 224 ! ghost cells: 225 ind1 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 226 ind2 = jpiglo 227 DO ji = mi0(ind1), mi1(ind2) 228 DO jj = 1, jpj 229 ztabramp(ji,jj) = zmskeast(jj) 230 END DO 231 END DO 232 ENDIF 233 IF( lk_south ) THEN ! --- South --- ! 234 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 235 ind2 = nn_hls + 1 + nbghostcells + jspongearea 236 DO jj = mj0(ind1), mj1(ind2) 237 DO ji = 1, jpi 238 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj), wp) * z1_jspongearea ) * zmsksouth(ji) 239 END DO 240 END DO 241 ! ghost cells: 242 ind1 = 1 243 ind2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 244 DO jj = mj0(ind1), mj1(ind2) 245 DO ji = 1, jpi 246 ztabramp(ji,jj) = zmsksouth(ji) 247 END DO 248 END DO 249 ENDIF 250 IF( lk_north ) THEN ! --- North --- ! 251 ind1 = jpjglo - ( nn_hls + nbghostcells ) - jspongearea 252 ind2 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 253 DO jj = mj0(ind1), mj1(ind2) 254 DO ji = 1, jpi 255 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj) - ind1, wp) * z1_jspongearea ) * zmsknorth(ji) 256 END DO 257 END DO 258 ! ghost cells: 259 ind1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 260 ind2 = jpjglo 261 DO jj = mj0(ind1), mj1(ind2) 262 DO ji = 1, jpi 263 ztabramp(ji,jj) = zmsknorth(ji) 264 END DO 265 END DO 266 ENDIF 267 ! 247 ! 248 END SUBROUTINE Agrif_Sponge 249 250 251 SUBROUTINE Agrif_Sponge_2d 252 !!---------------------------------------------------------------------- 253 !! *** ROUTINE Agrif_Sponge_2d *** 254 !!---------------------------------------------------------------------- 255 INTEGER :: ji, jj, ind1, ind2, ishift, jshift 256 INTEGER :: ispongearea, jspongearea 257 REAL(wp) :: z1_ispongearea, z1_jspongearea 258 REAL(wp), DIMENSION(jpi,jpj) :: ztabramp 259 !!---------------------------------------------------------------------- 260 ! 261 ! Sponge 1d example with: 262 ! iraf = 3 ; nbghost = 3 ; nn_sponge_len = 2 263 ! 264 !coarse : U T U T U T U 265 !| | | | | 266 !fine : t u t u t u t u t u t u t u t u t u t u t 267 !sponge val:0 1 1 1 1 5/6 4/6 3/6 2/6 1/6 0 268 ! | ghost | <-- sponge area -- > | 269 ! | points | | 270 ! |--> dynamical interface 271 272 #if defined SPONGE || defined SPONGE_TOP 273 ! Define ramp from boundaries towards domain interior at F-points 274 ! Store it in ztabramp 275 276 ispongearea = nn_sponge_len * Agrif_irhox() 277 z1_ispongearea = 1._wp / REAL( MAX(ispongearea,1), wp ) 278 jspongearea = nn_sponge_len * Agrif_irhoy() 279 z1_jspongearea = 1._wp / REAL( MAX(jspongearea,1), wp ) 280 ishift = nn_shift_bar * Agrif_irhox() 281 jshift = nn_shift_bar * Agrif_irhoy() 282 283 ztabramp(:,:) = 0._wp 284 285 IF( lk_west ) THEN ! --- West --- ! 286 ind1 = nn_hls + 1 + nbghostcells + ishift 287 ind2 = nn_hls + 1 + nbghostcells + ishift + ispongearea 288 DO ji = mi0(ind1), mi1(ind2) 289 DO jj = 1, jpj 290 ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_ispongearea 291 END DO 292 END DO 293 ! ghost cells: 294 ind1 = 1 295 ind2 = nn_hls + 1 + nbghostcells + ishift ! halo + land + nbghostcells 296 DO ji = mi0(ind1), mi1(ind2) 297 DO jj = 1, jpj 298 ztabramp(ji,jj) = 1._wp 299 END DO 300 END DO 268 301 ENDIF 269 302 IF( lk_east ) THEN ! --- East --- ! 303 ind1 = jpiglo - ( nn_hls + nbghostcells + ishift) - ispongearea - 1 304 ind2 = jpiglo - ( nn_hls + nbghostcells + ishift) - 1 ! halo + land + nbghostcells - 1 305 DO ji = mi0(ind1), mi1(ind2) 306 DO jj = 1, jpj 307 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji) - ind1, wp) * z1_ispongearea ) 308 END DO 309 END DO 310 ! ghost cells: 311 ind1 = jpiglo - ( nn_hls + nbghostcells + ishift) - 1 ! halo + land + nbghostcells - 1 312 ind2 = jpiglo - 1 313 DO ji = mi0(ind1), mi1(ind2) 314 DO jj = 1, jpj 315 ztabramp(ji,jj) = 1._wp 316 END DO 317 END DO 318 ENDIF 319 IF( lk_south ) THEN ! --- South --- ! 320 ind1 = nn_hls + 1 + nbghostcells + jshift ! halo + land + nbghostcells 321 ind2 = nn_hls + 1 + nbghostcells + jshift + jspongearea 322 DO jj = mj0(ind1), mj1(ind2) 323 DO ji = 1, jpi 324 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj), wp) * z1_jspongearea ) 325 END DO 326 END DO 327 ! ghost cells: 328 ind1 = 1 329 ind2 = nn_hls + 1 + nbghostcells + jshift ! halo + land + nbghostcells 330 DO jj = mj0(ind1), mj1(ind2) 331 DO ji = 1, jpi 332 ztabramp(ji,jj) = 1._wp 333 END DO 334 END DO 335 ENDIF 336 IF( lk_north ) THEN ! --- North --- ! 337 ind1 = jpjglo - ( nn_hls + nbghostcells + jshift) - jspongearea - 1 338 ind2 = jpjglo - ( nn_hls + nbghostcells + jshift) - 1 ! halo + land + nbghostcells - 1 339 DO jj = mj0(ind1), mj1(ind2) 340 DO ji = 1, jpi 341 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj) - ind1, wp) * z1_jspongearea ) 342 END DO 343 END DO 344 ! ghost cells: 345 ind1 = jpjglo - ( nn_hls + nbghostcells + jshift) ! halo + land + nbghostcells - 1 346 ind2 = jpjglo 347 DO jj = mj0(ind1), mj1(ind2) 348 DO ji = 1, jpi 349 ztabramp(ji,jj) = 1._wp 350 END DO 351 END DO 352 ENDIF 353 ! 270 354 ! Tracers 271 IF( .NOT. spongedoneT ) THEN 272 fspu(:,:) = 0._wp 273 fspv(:,:) = 0._wp 274 DO_2D( 0, 0, 0, 0 ) 275 fspu(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji+1,jj ) ) * ssumask(ji,jj) 276 fspv(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji ,jj+1) ) * ssvmask(ji,jj) 355 fspu_2d(:,:) = 0._wp 356 fspv_2d(:,:) = 0._wp 357 DO_2D( 0, 0, 0, 0 ) 358 fspu_2d(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji,jj-1) ) * ssumask(ji,jj) 359 fspv_2d(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji-1,jj) ) * ssvmask(ji,jj) 360 END_2D 361 362 ! Dynamics 363 fspt_2d(:,:) = 0._wp 364 fspf_2d(:,:) = 0._wp 365 DO_2D( 0, 0, 0, 0 ) 366 fspt_2d(ji,jj) = 0.25_wp * ( ztabramp(ji ,jj ) + ztabramp(ji-1,jj ) & 367 & +ztabramp(ji ,jj-1) + ztabramp(ji-1,jj-1) ) * ssmask(ji,jj) 368 fspf_2d(ji,jj) = ztabramp(ji,jj) * ssvmask(ji,jj) * ssvmask(ji,jj+1) 277 369 END_2D 278 ENDIF 279 280 ! Dynamics 281 IF( .NOT. spongedoneU ) THEN 282 fspt(:,:) = 0._wp 283 fspf(:,:) = 0._wp 284 DO_2D( 0, 0, 0, 0 ) 285 fspt(ji,jj) = ztabramp(ji,jj) * ssmask(ji,jj) 286 fspf(ji,jj) = 0.25_wp * ( ztabramp(ji ,jj ) + ztabramp(ji ,jj+1) & 287 & +ztabramp(ji+1,jj+1) + ztabramp(ji+1,jj ) ) & 288 & * ssvmask(ji,jj) * ssvmask(ji,jj+1) 289 END_2D 290 ENDIF 291 292 IF( .NOT. spongedoneT .AND. .NOT. spongedoneU ) THEN 293 CALL lbc_lnk_multi( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp, fspt, 'T', 1._wp, fspf, 'F', 1._wp ) 294 spongedoneT = .TRUE. 295 spongedoneU = .TRUE. 296 ENDIF 297 IF( .NOT. spongedoneT ) THEN 298 CALL lbc_lnk_multi( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp ) 299 spongedoneT = .TRUE. 300 ENDIF 301 IF( .NOT. spongedoneT .AND. .NOT. spongedoneU ) THEN 302 CALL lbc_lnk_multi( 'agrif_Sponge', fspt, 'T', 1._wp, fspf, 'F', 1._wp ) 303 spongedoneU = .TRUE. 304 ENDIF 305 306 #if defined key_vertical 307 ! Remove vertical interpolation where not needed: 308 DO_2D( 0, 0, 0, 0 ) 309 IF ((fspu(ji-1,jj)==0._wp).AND.(fspu(ji,jj)==0._wp).AND. & 310 & (fspv(ji,jj-1)==0._wp).AND.(fspv(ji,jj)==0._wp)) mbkt_parent(ji,jj) = 0 311 ! 312 IF ((fspt(ji+1,jj)==0._wp).AND.(fspt(ji,jj)==0._wp).AND. & 313 & (fspf(ji,jj-1)==0._wp).AND.(fspf(ji,jj)==0._wp)) mbku_parent(ji,jj) = 0 314 ! 315 IF ((fspt(ji,jj+1)==0._wp).AND.(fspt(ji,jj)==0._wp).AND. & 316 & (fspf(ji-1,jj)==0._wp).AND.(fspf(ji,jj)==0._wp)) mbkv_parent(ji,jj) = 0 317 ! 318 IF ( ssmask(ji,jj) == 0._wp) mbkt_parent(ji,jj) = 0 319 IF (ssumask(ji,jj) == 0._wp) mbku_parent(ji,jj) = 0 320 IF (ssvmask(ji,jj) == 0._wp) mbkv_parent(ji,jj) = 0 321 END_2D 322 ! 323 ztabramp (:,:) = REAL( mbkt_parent(:,:), wp ) 324 ztabrampu(:,:) = REAL( mbku_parent(:,:), wp ) 325 ztabrampv(:,:) = REAL( mbkv_parent(:,:), wp ) 326 CALL lbc_lnk_multi( 'Agrif_Sponge', ztabramp, 'T', 1._wp, ztabrampu, 'U', 1._wp, ztabrampv, 'V', 1._wp ) 327 mbkt_parent(:,:) = NINT( ztabramp (:,:) ) 328 mbku_parent(:,:) = NINT( ztabrampu(:,:) ) 329 mbkv_parent(:,:) = NINT( ztabrampv(:,:) ) 370 CALL lbc_lnk_multi( 'agrif_Sponge_2d', fspu_2d, 'U', 1._wp, fspv_2d, 'V', 1._wp, fspt_2d, 'T', 1._wp, fspf_2d, 'F', 1._wp ) 371 ! 330 372 #endif 331 373 ! 332 #endif 333 ! 334 END SUBROUTINE Agrif_Sponge 335 336 337 SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 374 END SUBROUTINE Agrif_Sponge_2d 375 376 377 SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before) 338 378 !!---------------------------------------------------------------------- 339 379 !! *** ROUTINE interptsn_sponge *** … … 346 386 INTEGER :: iku, ikv 347 387 REAL(wp) :: ztsa, zabe1, zabe2, zbtr, zhtot 348 REAL(wp), DIMENSION(i1 :i2,j1:j2,jpk) :: ztu, ztv388 REAL(wp), DIMENSION(i1-1:i2,j1-1:j2,jpk) :: ztu, ztv 349 389 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tsbdiff 350 390 ! vertical interpolation: 351 391 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child 352 REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin 353 REAL(wp), DIMENSION(k1:k2) :: h_in354 REAL(wp), DIMENSION(1:jpk) :: h_out 392 REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin, tabin_i 393 REAL(wp), DIMENSION(k1:k2) :: z_in, z_in_i, h_in_i 394 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 355 395 INTEGER :: N_in, N_out 356 396 !!---------------------------------------------------------------------- … … 367 407 END DO 368 408 369 # if defined key_vertical 370 ! Interpolate thicknesses 371 ! Warning: these are masked, hence extrapolated prior interpolation. 372 DO jk=k1,k2 373 DO jj=j1,j2 374 DO ji=i1,i2 375 tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kbb_a) 376 END DO 377 END DO 378 END DO 379 380 ! Extrapolate thicknesses in partial bottom cells: 381 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 382 IF (ln_zps) THEN 383 DO jj=j1,j2 384 DO ji=i1,i2 385 jk = mbkt(ji,jj) 386 tabres(ji,jj,jk,jpts+1) = 0._wp 387 END DO 388 END DO 389 END IF 390 391 ! Save ssh at last level: 392 IF (.NOT.ln_linssh) THEN 393 tabres(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kbb_a)*tmask(i1:i2,j1:j2,1) 394 ELSE 395 tabres(i1:i2,j1:j2,k2,jpts+1) = 0._wp 396 END IF 397 # endif 398 399 ELSE 400 ! 401 # if defined key_vertical 402 403 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,n2) = 0._wp 404 405 DO jj=j1,j2 406 DO ji=i1,i2 407 tabres_child(ji,jj,:,:) = 0._wp 408 N_in = mbkt_parent(ji,jj) 409 zhtot = 0._wp 410 DO jk=1,N_in !k2 = jpk of parent grid 411 IF (jk==N_in) THEN 412 h_in(jk) = ht0_parent(ji,jj) + tabres(ji,jj,k2,n2) - zhtot 409 IF ( l_vremap.OR.ln_zps ) THEN 410 411 ! Fill cell depths (i.e. gdept) to be interpolated 412 ! Warning: these are masked, hence extrapolated prior interpolation. 413 DO jj=j1,j2 414 DO ji=i1,i2 415 tabres(ji,jj,k1,jpts+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kbb_a) 416 DO jk=k1+1,k2 417 tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * & 418 & ( tabres(ji,jj,jk-1,jpts+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kbb_a)+e3t(ji,jj,jk,Kbb_a)) ) 419 END DO 420 END DO 421 END DO 422 423 ! Save ssh at last level: 424 IF ( .NOT.ln_linssh ) THEN 425 tabres(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kbb_a)*tmask(i1:i2,j1:j2,1) 426 END IF 427 428 END IF 429 430 ELSE 431 ! 432 IF ( l_vremap ) THEN 433 434 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,n2) = 0._wp 435 436 DO jj=j1,j2 437 DO ji=i1,i2 438 439 tabres_child(ji,jj,:,:) = 0._wp 440 ! Build vertical grids: 441 N_in = mbkt_parent(ji,jj) 442 ! Input grid (account for partial cells if any): 443 DO jk=1,N_in 444 z_in(jk) = tabres(ji,jj,jk,n2) - tabres(ji,jj,k2,n2) 445 tabin(jk,1:jpts) = tabres(ji,jj,jk,1:jpts) 446 END DO 447 448 ! Intermediate grid: 449 DO jk = 1, N_in 450 h_in_i(jk) = e3t0_parent(ji,jj,jk) * & 451 & (1._wp + tabres(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj))) 452 END DO 453 z_in_i(1) = 0.5_wp * h_in_i(1) 454 DO jk=2,N_in 455 z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) ) 456 END DO 457 z_in_i(1:N_in) = z_in_i(1:N_in) - tabres(ji,jj,k2,n2) 458 459 ! Output (Child) grid: 460 N_out = mbkt(ji,jj) 461 DO jk=1,N_out 462 h_out(jk) = e3t(ji,jj,jk,Kbb_a) 463 END DO 464 z_out(1) = 0.5_wp * h_out(1) 465 DO jk=2,N_out 466 z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) ) 467 END DO 468 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Kbb_a) 469 470 ! Account for small differences in the free-surface 471 IF ( sum(h_out(1:N_out)) > sum(h_in_i(1:N_in) )) THEN 472 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in_i(1:N_in)) ) 413 473 ELSE 414 h_in(jk) = tabres(ji,jj,jk,n2) 474 h_in_i(1)= h_in_i(1) - ( sum(h_in_i(1:N_in))-sum(h_out(1:N_out)) ) 475 END IF 476 IF (N_in*N_out > 0) THEN 477 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),tabin_i(1:N_in,1:jpts),z_in_i(1:N_in),N_in,N_in,jpts) 478 CALL reconstructandremap(tabin_i(1:N_in,1:jpts),h_in_i(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts) 479 ! CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),z_out(1:N_in),N_in,N_out,jpts) 415 480 ENDIF 416 zhtot = zhtot + h_in(jk) 417 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1) 418 END DO 419 N_out = 0 420 DO jk=1,jpk ! jpk of child grid 421 IF (tmask(ji,jj,jk) == 0) EXIT 422 N_out = N_out + 1 423 h_out(jk) = e3t(ji,jj,jk,Kbb_a) !Child grid scale factors. Could multiply by e1e2t here instead of division above 424 END DO 425 426 ! Account for small differences in free-surface 427 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN 428 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) ) 429 ELSE 430 h_in(1) = h_in(1) - (sum(h_in(1:N_in))-sum(h_out(1:N_out)) ) 431 ENDIF 432 IF (N_in*N_out > 0) THEN 433 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts) 434 ENDIF 435 END DO 436 END DO 437 # endif 438 439 DO jj=j1,j2 440 DO ji=i1,i2 441 DO jk=1,jpkm1 442 # if defined key_vertical 443 tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres_child(ji,jj,jk,1:jpts)) * tmask(ji,jj,jk) 444 # else 445 tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres(ji,jj,jk,1:jpts))*tmask(ji,jj,jk) 446 # endif 447 END DO 448 END DO 449 END DO 481 END DO 482 END DO 483 484 DO jj=j1,j2 485 DO ji=i1,i2 486 DO jk=1,jpkm1 487 tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres_child(ji,jj,jk,1:jpts)) * tmask(ji,jj,jk) 488 END DO 489 END DO 490 END DO 491 492 ELSE 493 494 IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells 495 496 DO jj=j1,j2 497 DO ji=i1,i2 498 ! 499 N_in = mbkt(ji,jj) 500 N_out = mbkt(ji,jj) 501 z_in(1) = tabres(ji,jj,1,n2) 502 tabin(1,1:jpts) = tabres(ji,jj,1,1:jpts) 503 DO jk=2, N_in 504 z_in(jk) = tabres(ji,jj,jk,n2) 505 tabin(jk,1:jpts) = tabres(ji,jj,jk,1:jpts) 506 END DO 507 IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - tabres(ji,jj,k2,n2) 508 509 z_out(1) = 0.5_wp * e3t(ji,jj,1,Kbb_a) 510 DO jk=2, N_out 511 z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Kbb_a) + e3t(ji,jj,jk,Kbb_a)) 512 END DO 513 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Kbb_a) 514 515 CALL remap_linear(tabin(1:N_in,1:jpts), z_in(1:N_in), tabres(ji,jj,1:N_out,1:jpts), & 516 & z_out(1:N_out), N_in, N_out, jpts) 517 END DO 518 END DO 519 ENDIF 520 521 DO jj=j1,j2 522 DO ji=i1,i2 523 DO jk=1,jpkm1 524 tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres(ji,jj,jk,1:jpts))*tmask(ji,jj,jk) 525 END DO 526 END DO 527 END DO 528 529 END IF 450 530 451 531 DO jn = 1, jpts 452 532 DO jk = 1, jpkm1 453 ztu(i1 :i2,j1:j2,jk) = 0._wp533 ztu(i1-1:i2,j1-1:j2,jk) = 0._wp 454 534 DO jj = j1,j2 455 535 DO ji = i1,i2-1 456 zabe1 = rn_sponge_tra * r1_Dt * fspu(ji,jj) *umask(ji,jj,jk) * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a)457 ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) )458 END DO 459 END DO 460 ztv(i1 :i2,j1:j2,jk) = 0._wp536 zabe1 = rn_sponge_tra * r1_Dt * umask(ji,jj,jk) * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 537 ztu(ji,jj,jk) = zabe1 * fspu(ji,jj) * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 538 END DO 539 END DO 540 ztv(i1-1:i2,j1-1:j2,jk) = 0._wp 461 541 DO ji = i1,i2 462 542 DO jj = j1,j2-1 463 zabe2 = rn_sponge_tra * r1_Dt * fspv(ji,jj) *vmask(ji,jj,jk) * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a)464 ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) )543 zabe2 = rn_sponge_tra * r1_Dt * vmask(ji,jj,jk) * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 544 ztv(ji,jj,jk) = zabe2 * fspv(ji,jj) * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 465 545 END DO 466 546 END DO … … 479 559 END DO 480 560 ! 561 ! JC: there is something wrong with the Laplacian in corners 481 562 DO jk = 1, jpkm1 482 DO jj = j1 +1,j2-1483 DO ji = i1 +1,i2-1563 DO jj = j1,j2 564 DO ji = i1,i2 484 565 IF (.NOT. tabspongedone_tsn(ji,jj)) THEN 485 566 zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm_a) 486 567 ! horizontal diffusive trends 487 ztsa = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) & 488 & - rn_trelax_tra * r1_Dt * fspt(ji,jj) * tsbdiff(ji,jj,jk,jn) 568 ztsa = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & 569 & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) & 570 & - rn_trelax_tra * r1_Dt * fspt(ji,jj) * tsbdiff(ji,jj,jk,jn) 489 571 ! add it to the general tracer trends 490 572 ts(ji,jj,jk,jn,Krhs_a) = ts(ji,jj,jk,jn,Krhs_a) + ztsa … … 492 574 END DO 493 575 END DO 576 494 577 END DO 495 578 ! 496 579 END DO 497 580 ! 498 tabspongedone_tsn(i1 +1:i2-1,j1+1:j2-1) = .TRUE.581 tabspongedone_tsn(i1:i2,j1:j2) = .TRUE. 499 582 ! 500 583 ENDIF … … 529 612 DO ji=i1,i2 530 613 tabres(ji,jj,jk,m1) = uu(ji,jj,jk,Kbb_a) 531 # if defined key_vertical 532 tabres(ji,jj,jk,m2) = e3u(ji,jj,jk,Kbb_a)*umask(ji,jj,jk) 533 # endif 534 END DO 535 END DO 536 END DO 537 538 # if defined key_vertical 539 ! Extrapolate thicknesses in partial bottom cells: 540 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 541 IF (ln_zps) THEN 614 END DO 615 END DO 616 END DO 617 618 IF ( l_vremap ) THEN 619 620 DO jk=k1,k2 621 DO jj=j1,j2 622 DO ji=i1,i2 623 tabres(ji,jj,jk,m2) = e3u(ji,jj,jk,Kbb_a)*umask(ji,jj,jk) 624 END DO 625 END DO 626 END DO 627 628 ! Extrapolate thicknesses in partial bottom cells: 629 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 630 IF (ln_zps) THEN 631 DO jj=j1,j2 632 DO ji=i1,i2 633 jk = mbku(ji,jj) 634 tabres(ji,jj,jk,m2) = 0._wp 635 END DO 636 END DO 637 END IF 638 ! Save ssh at last level: 639 tabres(i1:i2,j1:j2,k2,m2) = 0._wp 640 IF (.NOT.ln_linssh) THEN 641 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 642 DO jk=1,jpk 643 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) + e3u(i1:i2,j1:j2,jk,Kbb_a) * umask(i1:i2,j1:j2,jk) 644 END DO 645 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) - hu_0(i1:i2,j1:j2) 646 END IF 647 END IF 648 649 ELSE 650 651 IF ( l_vremap ) THEN 652 653 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,m2) = 0._wp 654 542 655 DO jj=j1,j2 543 656 DO ji=i1,i2 544 jk = mbku(ji,jj) 545 tabres(ji,jj,jk,m2) = 0._wp 546 END DO 547 END DO 548 END IF 549 ! Save ssh at last level: 550 tabres(i1:i2,j1:j2,k2,m2) = 0._wp 551 IF (.NOT.ln_linssh) THEN 552 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 553 DO jk=1,jpk 554 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) + e3u(i1:i2,j1:j2,jk,Kbb_a) * umask(i1:i2,j1:j2,jk) 555 END DO 556 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) - hu_0(i1:i2,j1:j2) 557 END IF 558 # endif 559 560 ELSE 561 562 # if defined key_vertical 563 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,m2) = 0._wp 564 565 DO jj=j1,j2 566 DO ji=i1,i2 567 tabres_child(ji,jj,:) = 0._wp 568 N_in = mbku_parent(ji,jj) 569 zhtot = 0._wp 570 DO jk=1,N_in 571 IF (jk==N_in) THEN 572 h_in(jk) = hu0_parent(ji,jj) + tabres(ji,jj,k2,m2) - zhtot 657 tabres_child(ji,jj,:) = 0._wp 658 N_in = mbku_parent(ji,jj) 659 zhtot = 0._wp 660 DO jk=1,N_in 661 !IF (jk==N_in) THEN 662 ! h_in(jk) = hu0_parent(ji,jj) + tabres(ji,jj,k2,m2) - zhtot 663 !ELSE 664 ! h_in(jk) = tabres(ji,jj,jk,m2) 665 !ENDIF 666 h_in(jk) = e3u0_parent(ji,jj,jk) 667 zhtot = zhtot + h_in(jk) 668 tabin(jk) = tabres(ji,jj,jk,m1) 669 END DO 670 ! 671 N_out = 0 672 DO jk=1,jpk 673 IF (umask(ji,jj,jk) == 0) EXIT 674 N_out = N_out + 1 675 h_out(N_out) = e3u(ji,jj,jk,Kbb_a) 676 END DO 677 678 ! Account for small differences in free-surface 679 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN 680 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) ) 573 681 ELSE 574 h_in( jk) = tabres(ji,jj,jk,m2)682 h_in(1) = h_in(1) - (sum(h_in(1:N_in))-sum(h_out(1:N_out)) ) 575 683 ENDIF 576 zhtot = zhtot + h_in(jk)577 tabin(jk) = tabres(ji,jj,jk,m1)578 END DO579 !580 N_out = 0581 DO jk=1,jpk582 IF (umask(ji,jj,jk) == 0) EXIT583 N_out = N_out + 1584 h_out(N_out) = e3u(ji,jj,jk,Kbb_a)585 END DO586 587 ! Account for small differences in free-surface588 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN589 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) )590 ELSE591 h_in(1) = h_in(1) - (sum(h_in(1:N_in))-sum(h_out(1:N_out)) )592 ENDIF593 684 594 IF (N_in * N_out > 0) THEN 595 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 596 ENDIF 597 END DO 598 END DO 599 600 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) 601 #else 602 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) 603 #endif 685 IF (N_in * N_out > 0) THEN 686 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 687 ENDIF 688 END DO 689 END DO 690 691 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) 692 ELSE 693 694 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) 695 696 ENDIF 604 697 ! 605 698 DO jk = 1, jpkm1 ! Horizontal slab … … 706 799 DO ji=i1,i2 707 800 tabres(ji,jj,jk,m1) = vv(ji,jj,jk,Kbb_a) 708 # if defined key_vertical 709 tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v(ji,jj,jk,Kbb_a) 710 # endif 711 END DO 712 END DO 713 END DO 714 715 # if defined key_vertical 716 ! Extrapolate thicknesses in partial bottom cells: 717 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 718 IF (ln_zps) THEN 801 END DO 802 END DO 803 END DO 804 805 IF ( l_vremap ) THEN 806 807 DO jk=k1,k2 808 DO jj=j1,j2 809 DO ji=i1,i2 810 tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v(ji,jj,jk,Kbb_a) 811 END DO 812 END DO 813 END DO 814 ! Extrapolate thicknesses in partial bottom cells: 815 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 816 IF (ln_zps) THEN 817 DO jj=j1,j2 818 DO ji=i1,i2 819 jk = mbkv(ji,jj) 820 tabres(ji,jj,jk,m2) = 0._wp 821 END DO 822 END DO 823 END IF 824 ! Save ssh at last level: 825 tabres(i1:i2,j1:j2,k2,m2) = 0._wp 826 IF (.NOT.ln_linssh) THEN 827 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 828 DO jk=1,jpk 829 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) + e3v(i1:i2,j1:j2,jk,Kbb_a) * vmask(i1:i2,j1:j2,jk) 830 END DO 831 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) - hv_0(i1:i2,j1:j2) 832 END IF 833 834 END IF 835 836 ELSE 837 838 IF ( l_vremap ) THEN 839 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,m2) = 0._wp 719 840 DO jj=j1,j2 720 841 DO ji=i1,i2 721 jk = mbkv(ji,jj) 722 tabres(ji,jj,jk,m2) = 0._wp 723 END DO 724 END DO 725 END IF 726 ! Save ssh at last level: 727 tabres(i1:i2,j1:j2,k2,m2) = 0._wp 728 IF (.NOT.ln_linssh) THEN 729 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 730 DO jk=1,jpk 731 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) + e3v(i1:i2,j1:j2,jk,Kbb_a) * vmask(i1:i2,j1:j2,jk) 732 END DO 733 tabres(i1:i2,j1:j2,k2,m2) = tabres(i1:i2,j1:j2,k2,m2) - hv_0(i1:i2,j1:j2) 734 END IF 735 # endif 736 737 ELSE 738 739 # if defined key_vertical 740 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,m2) = 0._wp 741 DO jj=j1,j2 742 DO ji=i1,i2 743 tabres_child(ji,jj,:) = 0._wp 744 N_in = mbkv_parent(ji,jj) 745 zhtot = 0._wp 746 DO jk=1,N_in 747 IF (jk==N_in) THEN 748 h_in(jk) = hv0_parent(ji,jj) + tabres(ji,jj,k2,m2) - zhtot 842 tabres_child(ji,jj,:) = 0._wp 843 N_in = mbkv_parent(ji,jj) 844 zhtot = 0._wp 845 DO jk=1,N_in 846 !IF (jk==N_in) THEN 847 ! h_in(jk) = hv0_parent(ji,jj) + tabres(ji,jj,k2,m2) - zhtot 848 !ELSE 849 ! h_in(jk) = tabres(ji,jj,jk,m2) 850 !ENDIF 851 h_in(jk) = e3v0_parent(ji,jj,jk) 852 zhtot = zhtot + h_in(jk) 853 tabin(jk) = tabres(ji,jj,jk,m1) 854 END DO 855 ! 856 N_out = 0 857 DO jk=1,jpk 858 IF (vmask(ji,jj,jk) == 0) EXIT 859 N_out = N_out + 1 860 h_out(N_out) = e3v(ji,jj,jk,Kbb_a) 861 END DO 862 863 ! Account for small differences in free-surface 864 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN 865 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) ) 749 866 ELSE 750 h_in( jk) = tabres(ji,jj,jk,m2)867 h_in(1) = h_in(1) - ( sum(h_in(1:N_in))-sum(h_out(1:N_out)) ) 751 868 ENDIF 752 zhtot = zhtot + h_in(jk)753 tabin(jk) = tabres(ji,jj,jk,m1)754 END DO755 !756 N_out = 0757 DO jk=1,jpk758 IF (vmask(ji,jj,jk) == 0) EXIT759 N_out = N_out + 1760 h_out(N_out) = e3v(ji,jj,jk,Kbb_a)761 END DO762 763 ! Account for small differences in free-surface764 IF ( sum(h_out(1:N_out)) > sum(h_in(1:N_in) )) THEN765 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in(1:N_in)) )766 ELSE767 h_in(1) = h_in(1) - ( sum(h_in(1:N_in))-sum(h_out(1:N_out)) )768 ENDIF769 869 770 IF (N_in * N_out > 0) THEN 771 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 772 ENDIF 773 END DO 774 END DO 775 776 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:) 777 # else 778 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) 779 # endif 870 IF (N_in * N_out > 0) THEN 871 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 872 ENDIF 873 END DO 874 END DO 875 876 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:) 877 ELSE 878 879 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) 880 881 ENDIF 780 882 ! 781 883 DO jk = 1, jpkm1 ! Horizontal slab … … 840 942 ! 841 943 END SUBROUTINE interpvn_sponge 944 945 SUBROUTINE interpunb_sponge(tabres,i1,i2,j1,j2, before) 946 !!--------------------------------------------- 947 !! *** ROUTINE interpunb_sponge *** 948 !!--------------------------------------------- 949 INTEGER, INTENT(in) :: i1,i2,j1,j2 950 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 951 LOGICAL, INTENT(in) :: before 952 953 INTEGER :: ji, jj, ind1, jmax 954 ! sponge parameters 955 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 956 REAL(wp), DIMENSION(i1:i2,j1:j2) :: ubdiff 957 REAL(wp), DIMENSION(i1:i2,j1:j2) :: rotdiff, hdivdiff 958 !!--------------------------------------------- 959 ! 960 IF( before ) THEN 961 DO jj=j1,j2 962 DO ji=i1,i2 963 tabres(ji,jj) = uu_b(ji,jj,Kmm_a) 964 END DO 965 END DO 966 967 ELSE 968 969 ubdiff(i1:i2,j1:j2) = (uu_b(i1:i2,j1:j2,Kmm_a) - tabres(i1:i2,j1:j2))*umask(i1:i2,j1:j2,1) 970 ! 971 ! ! -------- 972 ! Horizontal divergence ! div 973 ! ! -------- 974 DO jj = j1,j2 975 DO ji = i1+1,i2 ! vector opt. 976 zbtr = rn_sponge_dyn * r1_Dt * fspt_2d(ji,jj) * r1_ht_0(ji,jj) 977 hdivdiff(ji,jj) = ( e2u(ji ,jj)*hu(ji ,jj,Kbb_a) * ubdiff(ji ,jj) & 978 &-e2u(ji-1,jj)*hu(ji-1,jj,Kbb_a) * ubdiff(ji-1,jj) ) * zbtr 979 END DO 980 END DO 981 982 DO jj = j1,j2-1 983 DO ji = i1,i2 ! vector opt. 984 zbtr = rn_sponge_dyn * r1_Dt * fspf_2d(ji,jj) * hf_0(ji,jj) 985 rotdiff(ji,jj) = ( -e1u(ji,jj+1) * ubdiff(ji,jj+1) & 986 & +e1u(ji,jj ) * ubdiff(ji,jj ) ) * fmask(ji,jj,1) * zbtr 987 END DO 988 END DO 989 ! 990 DO jj = j1+1, j2-1 991 DO ji = i1+1, i2-1 ! vector opt. 992 IF (.NOT. tabspongedone_u(ji,jj)) THEN 993 ze2u = rotdiff (ji,jj) 994 ze1v = hdivdiff(ji,jj) 995 ! horizontal diffusive trends 996 zua = - ( ze2u - rotdiff (ji,jj-1) ) * r1_e2u(ji,jj) * r1_hu(ji,jj,Kmm_a) & 997 & + ( hdivdiff(ji+1,jj) - ze1v ) * r1_e1u(ji,jj) & 998 & - rn_trelax_dyn * r1_Dt * fspu_2d(ji,jj) * ubdiff(ji,jj) 999 1000 ! add it to the general momentum trends 1001 uu(ji,jj,:,Krhs_a) = uu(ji,jj,:,Krhs_a) + zua 1002 ENDIF 1003 END DO 1004 END DO 1005 1006 tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE. 1007 1008 jmax = j2-1 1009 ind1 = jpjglo - ( nn_hls + nbghostcells + 2 ) ! North 1010 DO jj = mj0(ind1), mj1(ind1) 1011 jmax = MIN(jmax,jj) 1012 END DO 1013 1014 DO jj = j1+1, jmax 1015 DO ji = i1+1, i2 ! vector opt. 1016 IF (.NOT. tabspongedone_v(ji,jj)) THEN 1017 ze2u = rotdiff (ji,jj) 1018 ze1v = hdivdiff(ji,jj) 1019 zva = + ( ze2u - rotdiff (ji-1,jj) ) * r1_e1v(ji,jj) * r1_hv(ji,jj,Kmm_a) & 1020 + ( hdivdiff(ji,jj+1) - ze1v ) * r1_e2v(ji,jj) 1021 vv(ji,jj,:,Krhs_a) = vv(ji,jj,:,Krhs_a) + zva 1022 ENDIF 1023 END DO 1024 END DO 1025 ! 1026 tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE. 1027 ! 1028 ENDIF 1029 ! 1030 END SUBROUTINE interpunb_sponge 1031 1032 1033 SUBROUTINE interpvnb_sponge(tabres,i1,i2,j1,j2, before) 1034 !!--------------------------------------------- 1035 !! *** ROUTINE interpvnb_sponge *** 1036 !!--------------------------------------------- 1037 INTEGER, INTENT(in) :: i1,i2,j1,j2 1038 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1039 LOGICAL, INTENT(in) :: before 1040 ! 1041 INTEGER :: ji, jj, ind1, imax 1042 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 1043 REAL(wp), DIMENSION(i1:i2,j1:j2) :: vbdiff 1044 REAL(wp), DIMENSION(i1:i2,j1:j2) :: rotdiff, hdivdiff 1045 !!--------------------------------------------- 1046 1047 IF( before ) THEN 1048 DO jj=j1,j2 1049 DO ji=i1,i2 1050 tabres(ji,jj) = vv_b(ji,jj,Kmm_a) 1051 END DO 1052 END DO 1053 ELSE 1054 vbdiff(i1:i2,j1:j2) = (vv_b(i1:i2,j1:j2,Kmm_a) - tabres(i1:i2,j1:j2))*vmask(i1:i2,j1:j2,1) 1055 ! ! -------- 1056 ! Horizontal divergence ! div 1057 ! ! -------- 1058 DO jj = j1+1,j2 1059 DO ji = i1,i2 ! vector opt. 1060 zbtr = rn_sponge_dyn * r1_Dt * fspt_2d(ji,jj) * r1_ht_0(ji,jj) 1061 hdivdiff(ji,jj) = ( e1v(ji,jj ) * hv(ji,jj ,Kbb_a) * vbdiff(ji,jj ) & 1062 & -e1v(ji,jj-1) * hv(ji,jj-1,Kbb_a) * vbdiff(ji,jj-1) ) * zbtr 1063 END DO 1064 END DO 1065 DO jj = j1,j2 1066 DO ji = i1,i2-1 ! vector opt. 1067 zbtr = rn_sponge_dyn * r1_Dt * fspf_2d(ji,jj) * hf_0(ji,jj) 1068 rotdiff(ji,jj) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj) & 1069 & -e2v(ji ,jj) * vbdiff(ji ,jj) ) * fmask(ji,jj,1) * zbtr 1070 END DO 1071 END DO 1072 ! ! =============== 1073 ! 1074 1075 imax = i2 - 1 1076 ind1 = jpiglo - ( nn_hls + nbghostcells + 2 ) ! East 1077 DO ji = mi0(ind1), mi1(ind1) 1078 imax = MIN(imax,ji) 1079 END DO 1080 1081 DO jj = j1+1, j2 1082 DO ji = i1+1, imax ! vector opt. 1083 IF( .NOT. tabspongedone_u(ji,jj) ) THEN 1084 zua = - ( rotdiff (ji ,jj) - rotdiff (ji,jj-1)) * r1_e2u(ji,jj) * r1_hu(ji,jj,Kmm_a) & 1085 & + ( hdivdiff(ji+1,jj) - hdivdiff(ji,jj )) * r1_e1u(ji,jj) 1086 uu(ji,jj,:,Krhs_a) = uu(ji,jj,:,Krhs_a) + zua 1087 ENDIF 1088 END DO 1089 END DO 1090 ! 1091 tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE. 1092 ! 1093 DO jj = j1+1, j2-1 1094 DO ji = i1+1, i2-1 ! vector opt. 1095 IF( .NOT. tabspongedone_v(ji,jj) ) THEN 1096 zva = ( rotdiff (ji,jj ) - rotdiff (ji-1,jj) ) * r1_e1v(ji,jj) *r1_hv(ji,jj,Kmm_a) & 1097 & + ( hdivdiff(ji,jj+1) - hdivdiff(ji ,jj) ) * r1_e2v(ji,jj) & 1098 & - rn_trelax_dyn * r1_Dt * fspv_2d(ji,jj) * vbdiff(ji,jj) 1099 vv(ji,jj,:,Krhs_a) = vv(ji,jj,:,Krhs_a) + zva 1100 ENDIF 1101 END DO 1102 END DO 1103 tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE. 1104 ENDIF 1105 ! 1106 END SUBROUTINE interpvnb_sponge 1107 842 1108 843 1109 #else -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/NST/agrif_oce_update.F90
r14066 r14098 1 #undef DECAL_FEEDBACK 1 #undef DECAL_FEEDBACK /* SEPARATION of INTERFACES */ 2 2 #undef DECAL_FEEDBACK_2D /* SEPARATION of INTERFACES (Barotropic mode) */ 3 3 #undef VOL_REFLUX /* VOLUME REFLUXING*/ … … 21 21 USE zdf_oce ! vertical physics: ocean variables 22 22 USE agrif_oce 23 USE dom_oce 23 24 ! 24 25 USE in_out_manager ! I/O manager … … 34 35 35 36 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn, Agrif_Update_vvl, Agrif_Update_ssh 36 PUBLIC Update_Scales 37 PUBLIC Update_Scales, Agrif_Check_parent_bat 37 38 38 39 !! * Substitutions … … 54 55 IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers from grid Number',Agrif_Fixed() 55 56 56 #if defined key_vertical 57 ! Effect of this has to be carrefully checked 58 ! depending on what the nesting tools ensure for 59 ! volume conservation: 57 l_vremap = ln_vert_remap 58 Agrif_UseSpecialValueInUpdate = .NOT.l_vremap 59 Agrif_SpecialValueFineGrid = 0._wp 60 ! 61 # if ! defined DECAL_FEEDBACK 62 CALL Agrif_Update_Variable(ts_update_id, procname=updateTS) 63 ! near boundary update: 64 ! CALL Agrif_Update_Variable(ts_update_id,locupdate=(/0,2/), procname=updateTS) 65 # else 66 CALL Agrif_Update_Variable(ts_update_id, locupdate=(/1,0/),procname=updateTS) 67 ! near boundary update: 68 ! CALL Agrif_Update_Variable(ts_update_id,locupdate=(/1,2/), procname=updateTS) 69 # endif 70 ! 60 71 Agrif_UseSpecialValueInUpdate = .FALSE. 61 #else 62 Agrif_UseSpecialValueInUpdate = .TRUE. 63 #endif 64 Agrif_SpecialValueFineGrid = 0._wp 65 ! 66 # if ! defined DECAL_FEEDBACK 67 CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 68 ! near boundary update: 69 ! CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 70 # else 71 CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 72 ! near boundary update: 73 ! CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 74 # endif 75 ! 76 Agrif_UseSpecialValueInUpdate = .FALSE. 72 l_vremap = .FALSE. 77 73 ! 78 74 ! … … 90 86 Agrif_UseSpecialValueInUpdate = .FALSE. 91 87 Agrif_SpecialValueFineGrid = 0._wp 92 93 use_sign_north = .TRUE. 94 sign_north = -1._wp 95 96 ! 88 l_vremap = ln_vert_remap 89 use_sign_north = .TRUE. 90 sign_north = -1._wp 91 ! 92 # if ! defined DECAL_FEEDBACK_2D 93 CALL Agrif_Update_Variable(unb_update_id,locupdate1=(/ nn_shift_bar,-2/),locupdate2=(/ nn_shift_bar,-2/),procname = updateU2d) 94 CALL Agrif_Update_Variable(vnb_update_id,locupdate1=(/ nn_shift_bar,-2/),locupdate2=(/ nn_shift_bar,-2/),procname = updateV2d) 95 # else 96 CALL Agrif_Update_Variable(unb_update_id,locupdate1=(/ nn_shift_bar,-2/),locupdate2=(/1+nn_shift_bar,-2/),procname = updateU2d) 97 CALL Agrif_Update_Variable(vnb_update_id,locupdate1=(/1+nn_shift_bar,-2/),locupdate2=(/ nn_shift_bar,-2/),procname = updateV2d) 98 # endif 99 ! 100 IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN 101 ! Update time integrated transports 102 # if ! defined DECAL_FEEDBACK_2D 103 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/ nn_shift_bar,-2/),locupdate2=(/ nn_shift_bar,-2/),procname = updateub2b) 104 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/ nn_shift_bar,-2/),locupdate2=(/ nn_shift_bar,-2/),procname = updatevb2b) 105 # else 106 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/ nn_shift_bar,-2/),locupdate2=(/1+nn_shift_bar,-2/),procname = updateub2b) 107 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1+nn_shift_bar,-2/),locupdate2=(/ nn_shift_bar,-2/),procname = updatevb2b) 108 # endif 109 END IF 110 97 111 # if ! defined DECAL_FEEDBACK 98 112 CALL Agrif_Update_Variable(un_update_id,procname = updateU) … … 108 122 ! CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) 109 123 # endif 110 111 # if ! defined DECAL_FEEDBACK_2D112 CALL Agrif_Update_Variable(e1u_id,procname = updateU2d)113 CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)114 # else115 CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d)116 CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)117 # endif118 !119 # if ! defined DECAL_FEEDBACK_2D120 ! Account for updated thicknesses at boundary edges121 IF (.NOT.ln_linssh) THEN122 ! CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_u_bdy)123 ! CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_v_bdy)124 ENDIF125 # endif126 !127 IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN128 ! Update time integrated transports129 # if ! defined DECAL_FEEDBACK_2D130 CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b)131 CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b)132 # else133 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b)134 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b)135 # endif136 END IF137 124 ! 138 125 use_sign_north = .FALSE. 126 l_vremap = .FALSE. 139 127 ! 140 128 END SUBROUTINE Agrif_Update_Dyn … … 150 138 Agrif_SpecialValueFineGrid = 0._wp 151 139 # if ! defined DECAL_FEEDBACK_2D 152 CALL Agrif_Update_Variable(sshn_id, procname = updateSSH)140 CALL Agrif_Update_Variable(sshn_id,locupdate=(/ nn_shift_bar,-2/), procname = updateSSH) 153 141 # else 154 CALL Agrif_Update_Variable(sshn_id,locupdate=(/1 ,0/),procname = updateSSH)142 CALL Agrif_Update_Variable(sshn_id,locupdate=(/1+nn_shift_bar,-2/),procname = updateSSH) 155 143 # endif 156 144 ! … … 158 146 ! 159 147 # if defined VOL_REFLUX 160 IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN 148 IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN 161 149 use_sign_north = .TRUE. 162 150 sign_north = -1._wp 163 151 ! Refluxing on ssh: 164 152 # if defined DECAL_FEEDBACK_2D 165 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/ 0, 0/),locupdate2=(/1, 1/),procname = reflux_sshu)166 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1 , 1/),locupdate2=(/0, 0/),procname = reflux_sshv)153 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/nn_shift_bar,nn_shift_bar/),locupdate2=(/1+nn_shift_bar,1+nn_shift_bar/),procname = reflux_sshu) 154 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1+nn_shift_bar,1+nn_shift_bar/),locupdate2=(/nn_shift_bar,nn_shift_bar/),procname = reflux_sshv) 167 155 # else 168 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/-1 ,-1/),locupdate2=(/ 0, 0/),procname = reflux_sshu)169 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/ 0, 0/),locupdate2=(/-1,-1/),procname = reflux_sshv)156 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/-1+nn_shift_bar,-1+nn_shift_bar/),locupdate2=(/nn_shift_bar, nn_shift_bar/),procname = reflux_sshu) 157 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/ nn_shift_bar, nn_shift_bar/),locupdate2=(/-1+nn_shift_bar,-1+nn_shift_bar/),procname = reflux_sshv) 170 158 # endif 171 159 use_sign_north = .FALSE. … … 320 308 #endif 321 309 322 #if defined key_vertical323 310 324 311 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 340 327 ! 341 328 IF (before) THEN 342 !jc_alt 343 ! AGRIF_SpecialValue = -999._wp 344 DO jn = n1,n2-1 329 IF ( l_vremap ) THEN 330 DO jn = n1,n2-1 331 DO jk=k1,k2 332 DO jj=j1,j2 333 DO ji=i1,i2 334 tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) 335 END DO 336 END DO 337 END DO 338 END DO 345 339 DO jk=k1,k2 346 340 DO jj=j1,j2 347 341 DO ji=i1,i2 348 !jc_alt 349 ! tabres(ji,jj,jk,jn) = (ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) ) & 350 ! & * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1._wp) * 999._wp 351 tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) 342 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 352 343 END DO 353 344 END DO 354 345 END DO 355 END DO 356 DO jk=k1,k2 346 ELSE 347 DO jn = 1,jpts 348 DO jk=k1,k2 349 DO jj=j1,j2 350 DO ji=i1,i2 351 tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk) 352 END DO 353 END DO 354 END DO 355 END DO 356 357 ENDIF 358 ELSE 359 IF ( l_vremap ) THEN 360 tabres_child(:,:,:,:) = 0._wp 361 AGRIF_SpecialValue = 0._wp 357 362 DO jj=j1,j2 358 363 DO ji=i1,i2 359 !jc_alt 360 ! tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) & 361 ! & + (tmask(ji,jj,jk) - 1._wp) * 999._wp 362 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 363 END DO 364 END DO 365 END DO 366 ELSE 367 tabres_child(:,:,:,:) = 0._wp 368 AGRIF_SpecialValue = 0._wp 369 DO jj=j1,j2 370 DO ji=i1,i2 371 N_in = 0 372 DO jk=k1,k2 !k2 = jpk of child grid 373 ! jc_alt 374 ! IF (tabres(ji,jj,jk,n2) < -900._wp ) EXIT 375 IF (tabres(ji,jj,jk,n2) == 0._wp ) EXIT 376 N_in = N_in + 1 377 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 378 h_in(N_in) = tabres(ji,jj,jk,n2) 364 N_in = 0 365 DO jk=k1,k2 !k2 = jpk of child grid 366 IF (tabres(ji,jj,jk,n2) <= 1.e-6_wp ) EXIT 367 N_in = N_in + 1 368 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 369 h_in(N_in) = tabres(ji,jj,jk,n2) 370 ENDDO 371 N_out = 0 372 DO jk=1,jpk ! jpk of parent grid 373 IF (tmask(ji,jj,jk) == 0 ) EXIT ! TODO: Will not work with ISF 374 N_out = N_out + 1 375 h_out(N_out) = e3t(ji,jj,jk,Kmm_a) 376 ENDDO 377 IF (N_in*N_out > 0) THEN !Remove this? 378 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts) 379 ENDIF 379 380 ENDDO 380 N_out = 0381 DO jk=1,jpk ! jpk of parent grid382 IF (tmask(ji,jj,jk) == 0 ) EXIT ! TODO: Will not work with ISF383 N_out = N_out + 1384 h_out(N_out) = e3t(ji,jj,jk,Kmm_a)385 ENDDO386 IF (N_in*N_out > 0) THEN !Remove this?387 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jpts),h_out(1:N_out),N_in,N_out,jpts)388 ENDIF389 381 ENDDO 390 ENDDO 391 392 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 393 ! Add asselin part 382 383 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 384 ! Add asselin part 385 DO jn = 1,jpts 386 DO jk = 1, jpkm1 387 DO jj = j1, j2 388 DO ji = i1, i2 389 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 390 ztb = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 391 ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a) 392 ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 393 ts(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) & 394 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 395 ENDIF 396 END DO 397 END DO 398 END DO 399 END DO 400 ENDIF 394 401 DO jn = 1,jpts 395 402 DO jk = 1, jpkm1 396 403 DO jj = j1, j2 397 404 DO ji = i1, i2 398 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 399 ztb = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 400 ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a) 401 ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 402 ts(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) & 403 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 404 ENDIF 405 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 406 ts(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn) 407 END IF 405 408 END DO 406 409 END DO 407 410 END DO 408 411 END DO 409 ENDIF 410 DO jn = 1,jpts 411 DO jk = 1, jpkm1 412 DO jj = j1, j2 413 DO ji = i1, i2 414 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 415 ts(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn) 416 END IF 412 ELSE 413 DO jn = 1,jpts 414 tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) & 415 & * tmask(i1:i2,j1:j2,k1:k2) 416 ENDDO 417 418 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 419 ! Add asselin part 420 DO jn = 1,jpts 421 DO jk = k1, k2 422 DO jj = j1, j2 423 DO ji = i1, i2 424 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 425 ztb = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 426 ztnu = tabres(ji,jj,jk,jn) 427 ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 428 ts(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) & 429 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 430 ENDIF 431 END DO 432 END DO 417 433 END DO 418 434 END DO 419 END DO 420 END DO 421 ! 435 ENDIF 436 DO jn = 1,jpts 437 DO jk=k1,k2 438 DO jj=j1,j2 439 DO ji=i1,i2 440 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 441 ts(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a) 442 END IF 443 END DO 444 END DO 445 END DO 446 END DO 447 ! 448 ENDIF 422 449 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN 423 450 ts(i1:i2,j1:j2,1:jpkm1,1:jpts,Kbb_a) = ts(i1:i2,j1:j2,1:jpkm1,1:jpts,Kmm_a) 424 ENDIF 451 ENDIF 425 452 ENDIF 426 453 ! 427 454 END SUBROUTINE updateTS 428 455 429 # else430 431 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )432 !!---------------------------------------------433 !! *** ROUTINE updateT ***434 !!---------------------------------------------435 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2436 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres437 LOGICAL, INTENT(in) :: before438 !!439 INTEGER :: ji,jj,jk,jn440 REAL(wp) :: ztb, ztnu, ztno441 !!---------------------------------------------442 !443 IF (before) THEN444 DO jn = 1,jpts445 DO jk=k1,k2446 DO jj=j1,j2447 DO ji=i1,i2448 !> jc tmp449 tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk)450 ! tabres(ji,jj,jk,jn) = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a)451 !< jc tmp452 END DO453 END DO454 END DO455 END DO456 ELSE457 !> jc tmp458 DO jn = 1,jpts459 tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &460 & * tmask(i1:i2,j1:j2,k1:k2)461 ENDDO462 !< jc tmp463 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN464 ! Add asselin part465 DO jn = 1,jpts466 DO jk = k1, k2467 DO jj = j1, j2468 DO ji = i1, i2469 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN470 ztb = ts(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used471 ztnu = tabres(ji,jj,jk,jn)472 ztno = ts(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a)473 ts(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) &474 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a)475 ENDIF476 END DO477 END DO478 END DO479 END DO480 ENDIF481 DO jn = 1,jpts482 DO jk=k1,k2483 DO jj=j1,j2484 DO ji=i1,i2485 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN486 ts(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a)487 END IF488 END DO489 END DO490 END DO491 END DO492 !493 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN494 ts(i1:i2,j1:j2,k1:k2,1:jpts,Kbb_a) = ts(i1:i2,j1:j2,k1:k2,1:jpts,Kmm_a)495 ENDIF496 !497 ENDIF498 !499 END SUBROUTINE updateTS500 501 # endif502 503 # if defined key_vertical504 456 505 457 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 513 465 INTEGER :: ji, jj, jk 514 466 REAL(wp):: zrhoy, zub, zunu, zuno 467 REAL(wp), DIMENSION(jpi,jpj) :: zpgu ! 2D workspace 515 468 ! VERTICAL REFINEMENT BEGIN 516 469 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child 517 470 REAL(wp) :: h_in(k1:k2) 518 471 REAL(wp) :: h_out(1:jpk) 519 INTEGER :: N_in, N_out 520 REAL(wp) :: h_diff, excess, thick472 INTEGER :: N_in, N_out, N_in_save, N_out_save 473 REAL(wp) :: zhmin, zd 521 474 REAL(wp) :: tabin(k1:k2) 522 475 ! VERTICAL REFINEMENT END … … 525 478 IF( before ) THEN 526 479 zrhoy = Agrif_Rhoy() 527 !jc_alt528 ! AGRIF_SpecialValue = -999._wp529 480 DO jk=k1,k2 481 tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u(i1:i2,j1:j2,jk,Kmm_a) & 482 & * umask(i1:i2,j1:j2,jk) * uu(i1:i2,j1:j2,jk,Kmm_a) 483 END DO 484 485 IF ( l_vremap ) THEN 486 DO jk=k1,k2 487 tabres(i1:i2,j1:j2,jk,2) = zrhoy * umask(i1:i2,j1:j2,jk) * e2u(i1:i2,j1:j2) * e3u(i1:i2,j1:j2,jk,Kmm_a) 488 END DO 489 ENDIF 490 491 ELSE 492 493 tabres_child(:,:,:) = 0._wp 494 495 IF ( l_vremap ) THEN 496 530 497 DO jj=j1,j2 531 498 DO ji=i1,i2 532 !jc_alt 533 ! tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * umask(ji,jj,jk) * uu(ji,jj,jk,Kmm_a) & 534 ! & + (umask(ji,jj,jk)-1._wp)*999._wp 535 tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * umask(ji,jj,jk) * uu(ji,jj,jk,Kmm_a) 536 !jc_alt 537 ! tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) & 538 ! & + (umask(ji,jj,jk)-1._wp)*999._wp 539 tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 540 END DO 541 END DO 542 END DO 543 ELSE 544 tabres_child(:,:,:) = 0. 545 AGRIF_SpecialValue = 0._wp 546 DO jj=j1,j2 547 DO ji=i1,i2 548 N_in = 0 549 h_in(:) = 0._wp 550 tabin(:) = 0._wp 551 DO jk=k1,k2 !k2=jpk of child grid 552 !jc_alt 553 ! IF( tabres(ji,jj,jk,2) < -900._wp) EXIT 554 IF( tabres(ji,jj,jk,2) == 0.) EXIT 555 N_in = N_in + 1 556 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 557 h_in(N_in) = tabres(ji,jj,jk,2)/e2u(ji,jj) 499 N_in = 0 500 h_in(:) = 0._wp 501 tabin(:) = 0._wp 502 DO jk=k1,k2 !k2=jpk of child grid 503 IF( tabres(ji,jj,jk,2)*r1_e2u(ji,jj) <= 1.e-6_wp ) EXIT 504 N_in = N_in + 1 505 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 506 h_in(N_in) = tabres(ji,jj,jk,2) * r1_e2u(ji,jj) 507 ENDDO 508 N_out = 0 509 DO jk=1,jpk 510 IF (umask(ji,jj,jk) == 0._wp) EXIT 511 N_out = N_out + 1 512 h_out(N_out) = e3u(ji,jj,jk,Kmm_a) 513 ENDDO 514 IF (N_in * N_out > 0) THEN 515 ! Deal with potentially different depths at velocity points: 516 N_in_save = N_in 517 N_out_save = N_out 518 IF ( ABS(sum(h_out(1:N_out))-sum(h_in(1:N_in))) > 1.e-6_wp ) THEN 519 zhmin = MIN(sum(h_out(1:N_out)), sum(h_in(1:N_in))) 520 zd = 0._wp 521 DO jk=1, N_in_save 522 IF ( (zd + h_in(jk)) > zhmin-1.e-6) THEN 523 N_in = jk 524 h_in(jk) = zhmin - zd 525 EXIT 526 ENDIF 527 zd = zd + h_in(jk) 528 END DO 529 zd = 0._wp 530 DO jk=1, N_out_save 531 IF ( (zd + h_out(jk)) > zhmin-1.e-6) THEN 532 N_out = jk 533 h_out(jk) = zhmin - zd 534 EXIT 535 ENDIF 536 zd = zd + h_out(jk) 537 END DO 538 END IF 539 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 540 IF (N_out < N_out_save) tabres_child(ji,jj,N_out+1:N_out_save) = tabres_child(ji,jj,N_out) 541 ENDIF 558 542 ENDDO 559 N_out = 0560 DO jk=1,jpk561 IF (umask(ji,jj,jk) == 0) EXIT562 N_out = N_out + 1563 h_out(N_out) = e3u(ji,jj,jk,Kmm_a)564 ENDDO565 IF (N_in * N_out > 0) THEN566 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))567 excess = 0._wp568 IF (h_diff < -1.e-4) THEN569 !Even if bathy at T points match it's possible for the U points to be deeper in the child grid.570 !In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell.571 DO jk=N_in,1,-1572 thick = MIN(-1*h_diff, h_in(jk))573 excess = excess + tabin(jk)*thick*e2u(ji,jj)574 tabin(jk) = tabin(jk)*(1. - thick/h_in(jk))575 h_diff = h_diff + thick576 IF ( h_diff == 0) THEN577 N_in = jk578 h_in(jk) = h_in(jk) - thick579 EXIT580 ENDIF581 ENDDO582 ENDIF583 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1)584 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e2u(ji,jj)*h_out(N_out))585 ENDIF586 543 ENDDO 587 ENDDO 544 545 ELSE 546 DO jk=1,jpk 547 DO jj=j1,j2 548 DO ji=i1,i2 549 tabres_child(ji,jj,jk) = tabres(ji,jj,jk,1) * r1_e2u(ji,jj) / e3u(ji,jj,jk,Kmm_a) 550 END DO 551 END DO 552 END DO 553 ENDIF 588 554 ! 589 555 DO jk=1,jpk … … 603 569 END DO 604 570 ! 571 ! Correct now and before transports: 572 DO jj=j1,j2 573 DO ji=i1,i2 574 zpgu(ji,jj) = 0._wp 575 DO jk=1,jpkm1 576 zpgu(ji,jj) = zpgu(ji,jj) + e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a) 577 END DO 578 ! 579 DO jk=1,jpkm1 580 uu(ji,jj,jk,Kmm_a) = uu(ji,jj,jk,Kmm_a) + & 581 & (uu_b(ji,jj,Kmm_a) - zpgu(ji,jj) * r1_hu(ji,jj,Kmm_a)) * umask(ji,jj,jk) 582 END DO 583 ! 584 zpgu(ji,jj) = 0._wp 585 DO jk=1,jpkm1 586 zpgu(ji,jj) = zpgu(ji,jj) + e3u(ji,jj,jk,Kbb_a) * uu(ji,jj,jk,Kbb_a) 587 END DO 588 ! 589 DO jk=1,jpkm1 590 uu(ji,jj,jk,Kbb_a) = uu(ji,jj,jk,Kbb_a) + & 591 & (uu_b(ji,jj,Kbb_a) - zpgu(ji,jj) * r1_hu(ji,jj,Kbb_a)) * umask(ji,jj,jk) 592 END DO 593 ! 594 END DO 595 END DO 596 ! 605 597 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN 606 598 uu(i1:i2,j1:j2,1:jpkm1,Kbb_a) = uu(i1:i2,j1:j2,1:jpkm1,Kmm_a) … … 611 603 END SUBROUTINE updateu 612 604 613 #else 614 615 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 616 !!--------------------------------------------- 617 !! *** ROUTINE updateu *** 618 !!--------------------------------------------- 619 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 620 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 621 LOGICAL , INTENT(in ) :: before 622 ! 623 INTEGER :: ji, jj, jk 624 REAL(wp) :: zrhoy, zub, zunu, zuno 625 !!--------------------------------------------- 626 ! 627 IF( before ) THEN 628 zrhoy = Agrif_Rhoy() 629 DO jk = k1, k2 630 tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u(i1:i2,j1:j2,jk,Kmm_a) * uu(i1:i2,j1:j2,jk,Kmm_a) 631 END DO 632 ELSE 633 DO jk=k1,k2 634 DO jj=j1,j2 635 DO ji=i1,i2 636 tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e2u(ji,jj) 637 ! 638 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN ! Add asselin part 639 zub = uu(ji,jj,jk,Kbb_a) * e3u(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 640 zuno = uu(ji,jj,jk,Kmm_a) * e3u(ji,jj,jk,Krhs_a) 641 zunu = tabres(ji,jj,jk,1) 642 uu(ji,jj,jk,Kbb_a) = ( zub + rn_atfp * ( zunu - zuno) ) & 643 & * umask(ji,jj,jk) / e3u(ji,jj,jk,Kbb_a) 644 ENDIF 645 ! 646 uu(ji,jj,jk,Kmm_a) = tabres(ji,jj,jk,1) * umask(ji,jj,jk) / e3u(ji,jj,jk,Kmm_a) 647 END DO 648 END DO 649 END DO 650 ! 651 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN 652 uu(i1:i2,j1:j2,k1:k2,Kbb_a) = uu(i1:i2,j1:j2,k1:k2,Kmm_a) 653 ENDIF 654 ! 655 ENDIF 656 ! 657 END SUBROUTINE updateu 658 659 # endif 660 661 SUBROUTINE correct_u_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 662 !!--------------------------------------------- 663 !! *** ROUTINE correct_u_bdy *** 605 606 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 607 !!--------------------------------------------- 608 !! *** ROUTINE updatev *** 664 609 !!--------------------------------------------- 665 610 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 666 611 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 667 612 LOGICAL , INTENT(in ) :: before 668 INTEGER , INTENT(in) :: nb, ndir669 !!670 LOGICAL :: western_side, eastern_side671 !672 INTEGER :: jj, jk673 REAL(wp) :: zcor674 !!---------------------------------------------675 !676 IF( .NOT.before ) THEN677 !678 western_side = (nb == 1).AND.(ndir == 1)679 eastern_side = (nb == 1).AND.(ndir == 2)680 !681 IF (western_side) THEN682 DO jj=j1,j2683 zcor = uu_b(i1-1,jj,Kmm_a) * hu(i1-1,jj,Krhs_a) * r1_hu(i1-1,jj,Kmm_a) - uu_b(i1-1,jj,Kmm_a)684 uu_b(i1-1,jj,Kmm_a) = uu_b(i1-1,jj,Kmm_a) + zcor685 DO jk=1,jpkm1686 uu(i1-1,jj,jk,Kmm_a) = uu(i1-1,jj,jk,Kmm_a) + zcor * umask(i1-1,jj,jk)687 END DO688 END DO689 ENDIF690 !691 IF (eastern_side) THEN692 DO jj=j1,j2693 zcor = uu_b(i2+1,jj,Kmm_a) * hu(i2+1,jj,Krhs_a) * r1_hu(i2+1,jj,Kmm_a) - uu_b(i2+1,jj,Kmm_a)694 uu_b(i2+1,jj,Kmm_a) = uu_b(i2+1,jj,Kmm_a) + zcor695 DO jk=1,jpkm1696 uu(i2+1,jj,jk,Kmm_a) = uu(i2+1,jj,jk,Kmm_a) + zcor * umask(i2+1,jj,jk)697 END DO698 END DO699 ENDIF700 !701 ENDIF702 !703 END SUBROUTINE correct_u_bdy704 705 # if defined key_vertical706 707 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )708 !!---------------------------------------------709 !! *** ROUTINE updatev ***710 !!---------------------------------------------711 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2712 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres713 LOGICAL , INTENT(in ) :: before714 613 ! 715 614 INTEGER :: ji, jj, jk 716 615 REAL(wp) :: zrhox, zvb, zvnu, zvno 616 REAL(wp), DIMENSION(jpi,jpj) :: zpgv ! 2D workspace 717 617 ! VERTICAL REFINEMENT BEGIN 718 618 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child 719 619 REAL(wp) :: h_in(k1:k2) 720 620 REAL(wp) :: h_out(1:jpk) 721 INTEGER :: N_in, N_out722 REAL(wp) :: h_diff, excess, thick621 INTEGER :: N_in, N_out, N_in_save, N_out_save 622 REAL(wp) :: zhmin, zd 723 623 REAL(wp) :: tabin(k1:k2) 724 624 ! VERTICAL REFINEMENT END … … 727 627 IF( before ) THEN 728 628 zrhox = Agrif_Rhox() 729 !jc_alt730 ! AGRIF_SpecialValue = -999._wp731 629 DO jk=k1,k2 630 tabres(i1:i2,j1:j2,jk,1) = zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Kmm_a) & 631 & * vmask(i1:i2,j1:j2,jk) * vv(i1:i2,j1:j2,jk,Kmm_a) 632 END DO 633 634 IF ( l_vremap ) THEN 635 DO jk=k1,k2 636 tabres(i1:i2,j1:j2,jk,2) = zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk) 637 END DO 638 ENDIF 639 640 ELSE 641 642 tabres_child(:,:,:) = 0._wp 643 644 IF ( l_vremap ) THEN 645 732 646 DO jj=j1,j2 733 647 DO ji=i1,i2 734 !jc_alt 735 ! tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) * vv(ji,jj,jk,Kmm_a) & 736 ! & + (vmask(ji,jj,jk)-1._wp) * 999._wp 737 tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) * vv(ji,jj,jk,Kmm_a) 738 !jc_alt 739 ! tabres(ji,jj,jk,2) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) & 740 ! & + (vmask(ji,jj,jk)-1._wp) * 999._wp 741 tabres(ji,jj,jk,2) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) 742 END DO 743 END DO 744 END DO 745 ELSE 746 tabres_child(:,:,:) = 0. 747 AGRIF_SpecialValue = 0._wp 748 DO jj=j1,j2 749 DO ji=i1,i2 750 N_in = 0 751 DO jk=k1,k2 752 !jc_alt 753 ! IF (tabres(ji,jj,jk,2) < -900._wp) EXIT 754 IF (tabres(ji,jj,jk,2) == 0) EXIT 755 N_in = N_in + 1 756 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 757 h_in(N_in) = tabres(ji,jj,jk,2)/e1v(ji,jj) 648 N_in = 0 649 DO jk=k1,k2 650 IF (tabres(ji,jj,jk,2)* r1_e1v(ji,jj) <= 1.e-6_wp) EXIT 651 N_in = N_in + 1 652 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 653 h_in(N_in) = tabres(ji,jj,jk,2) * r1_e1v(ji,jj) 654 ENDDO 655 N_out = 0 656 DO jk=1,jpk 657 IF (vmask(ji,jj,jk) == 0) EXIT 658 N_out = N_out + 1 659 h_out(N_out) = e3v(ji,jj,jk,Kmm_a) 660 ENDDO 661 IF (N_in * N_out > 0) THEN 662 ! Deal with potentially different depths at velocity points: 663 N_in_save = N_in 664 N_out_save = N_out 665 IF ( ABS(sum(h_out(1:N_out))-sum(h_in(1:N_in))) > 1.e-6_wp ) THEN 666 zhmin = MIN(sum(h_out(1:N_out)), sum(h_in(1:N_in))) 667 zd = 0._wp 668 DO jk=1, N_in_save 669 IF ( (zd + h_in(jk)) > zhmin-1.e-6) THEN 670 N_in = jk 671 h_in(jk) = zhmin - zd 672 EXIT 673 ENDIF 674 zd = zd + h_in(jk) 675 END DO 676 zd = 0._wp 677 DO jk=1, N_out_save 678 IF ( (zd + h_out(jk)) > zhmin-1.e-6) THEN 679 N_out = jk 680 h_out(jk) = zhmin - zd 681 EXIT 682 ENDIF 683 zd = zd + h_out(jk) 684 END DO 685 END IF 686 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1) 687 IF (N_out < N_out_save) tabres_child(ji,jj,N_out+1:N_out_save) = tabres_child(ji,jj,N_out) 688 ENDIF 758 689 ENDDO 759 N_out = 0760 DO jk=1,jpk761 IF (vmask(ji,jj,jk) == 0) EXIT762 N_out = N_out + 1763 h_out(N_out) = e3v(ji,jj,jk,Kmm_a)764 ENDDO765 IF (N_in * N_out > 0) THEN766 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))767 excess = 0._wp768 IF (h_diff < -1.e-4) then769 !Even if bathy at T points match it's possible for the V points to be deeper in the child grid.770 !In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell.771 DO jk=N_in,1,-1772 thick = MIN(-1*h_diff, h_in(jk))773 excess = excess + tabin(jk)*thick*e2u(ji,jj)774 tabin(jk) = tabin(jk)*(1. - thick/h_in(jk))775 h_diff = h_diff + thick776 IF ( h_diff == 0) THEN777 N_in = jk778 h_in(jk) = h_in(jk) - thick779 EXIT780 ENDIF781 ENDDO782 ENDIF783 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out,1)784 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out))785 ENDIF786 690 ENDDO 787 ENDDO 691 692 ELSE 693 DO jk=1,jpk 694 DO jj=j1,j2 695 DO ji=i1,i2 696 tabres_child(ji,jj,jk) = tabres(ji,jj,jk,1) * r1_e1v(ji,jj) / e3v(ji,jj,jk,Kmm_a) 697 END DO 698 END DO 699 END DO 700 ENDIF 788 701 ! 789 702 DO jk=1,jpkm1 … … 803 716 END DO 804 717 ! 718 ! Correct now and before transports: 719 DO jj=j1,j2 720 DO ji=i1,i2 721 zpgv(ji,jj) = 0._wp 722 DO jk=1,jpkm1 723 zpgv(ji,jj) = zpgv(ji,jj) + e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a) 724 END DO 725 ! 726 DO jk=1,jpkm1 727 vv(ji,jj,jk,Kmm_a) = vv(ji,jj,jk,Kmm_a) + & 728 & (vv_b(ji,jj,Kmm_a) - zpgv(ji,jj) * r1_hv(ji,jj,Kmm_a)) * vmask(ji,jj,jk) 729 END DO 730 ! 731 zpgv(ji,jj) = 0._wp 732 DO jk=1,jpkm1 733 zpgv(ji,jj) = zpgv(ji,jj) + e3v(ji,jj,jk,Kbb_a) * vv(ji,jj,jk,Kbb_a) 734 END DO 735 ! 736 DO jk=1,jpkm1 737 vv(ji,jj,jk,Kbb_a) = vv(ji,jj,jk,Kbb_a) + & 738 & (vv_b(ji,jj,Kbb_a) - zpgv(ji,jj) * r1_hv(ji,jj,Kbb_a)) * vmask(ji,jj,jk) 739 END DO 740 ! 741 END DO 742 END DO 743 ! 805 744 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN 806 745 vv(i1:i2,j1:j2,1:jpkm1,Kbb_a) = vv(i1:i2,j1:j2,1:jpkm1,Kmm_a) … … 810 749 ! 811 750 END SUBROUTINE updatev 812 813 # else814 815 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before)816 !!---------------------------------------------817 !! *** ROUTINE updatev ***818 !!---------------------------------------------819 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2820 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres821 LOGICAL , INTENT(in ) :: before822 !823 INTEGER :: ji, jj, jk824 REAL(wp) :: zrhox, zvb, zvnu, zvno825 !!---------------------------------------------826 !827 IF (before) THEN828 zrhox = Agrif_Rhox()829 DO jk=k1,k2830 DO jj=j1,j2831 DO ji=i1,i2832 tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)833 END DO834 END DO835 END DO836 ELSE837 DO jk=k1,k2838 DO jj=j1,j2839 DO ji=i1,i2840 tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e1v(ji,jj)841 !842 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN ! Add asselin part843 zvb = vv(ji,jj,jk,Kbb_a) * e3v(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used844 zvno = vv(ji,jj,jk,Kmm_a) * e3v(ji,jj,jk,Krhs_a)845 zvnu = tabres(ji,jj,jk,1)846 vv(ji,jj,jk,Kbb_a) = ( zvb + rn_atfp * ( zvnu - zvno) ) &847 & * vmask(ji,jj,jk) / e3v(ji,jj,jk,Kbb_a)848 ENDIF849 !850 vv(ji,jj,jk,Kmm_a) = tabres(ji,jj,jk,1) * vmask(ji,jj,jk) / e3v(ji,jj,jk,Kmm_a)851 END DO852 END DO853 END DO854 !855 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN856 vv(i1:i2,j1:j2,k1:k2,Kbb_a) = vv(i1:i2,j1:j2,k1:k2,Kmm_a)857 ENDIF858 !859 ENDIF860 !861 END SUBROUTINE updatev862 863 # endif864 865 SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )866 !!---------------------------------------------867 !! *** ROUTINE correct_v_bdy ***868 !!---------------------------------------------869 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2870 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres871 LOGICAL , INTENT(in ) :: before872 INTEGER , INTENT(in) :: nb, ndir873 !!874 LOGICAL :: southern_side, northern_side875 !876 INTEGER :: ji, jk877 REAL(wp) :: zcor878 !!---------------------------------------------879 !880 IF( .NOT.before ) THEN881 !882 southern_side = (nb == 2).AND.(ndir == 1)883 northern_side = (nb == 2).AND.(ndir == 2)884 !885 IF (southern_side) THEN886 DO ji=i1,i2887 zcor = vv_b(ji,j1-1,Kmm_a) * hv(ji,j1-1,Krhs_a) * r1_hv(ji,j1-1,Kmm_a) - vv_b(ji,j1-1,Kmm_a)888 vv_b(ji,j1-1,Kmm_a) = vv_b(ji,j1-1,Kmm_a) + zcor889 DO jk=1,jpkm1890 vv(ji,j1-1,jk,Kmm_a) = vv(ji,j1-1,jk,Kmm_a) + zcor * vmask(ji,j1-1,jk)891 END DO892 END DO893 ENDIF894 !895 IF (northern_side) THEN896 DO ji=i1,i2897 zcor = vv_b(ji,j2+1,Kmm_a) * hv(ji,j2+1,Krhs_a) * r1_hv(ji,j2+1,Kmm_a) - vv_b(ji,j2+1,Kmm_a)898 vv_b(ji,j2+1,Kmm_a) = vv_b(ji,j2+1,Kmm_a) + zcor899 DO jk=1,jpkm1900 vv(ji,j2+1,jk,Kmm_a) = vv(ji,j2+1,jk,Kmm_a) + zcor * vmask(ji,j2+1,jk)901 END DO902 END DO903 ENDIF904 !905 ENDIF906 !907 END SUBROUTINE correct_v_bdy908 751 909 752 … … 935 778 tabres(ji,jj) = tabres(ji,jj) * r1_e2u(ji,jj) 936 779 ! 937 ! Update "now" 3d velocities:938 zpgu(ji,jj) = 0._wp939 DO jk=1,jpkm1940 zpgu(ji,jj) = zpgu(ji,jj) + e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)941 END DO942 !943 zcorr = (tabres(ji,jj) - zpgu(ji,jj)) * r1_hu(ji,jj,Kmm_a)944 DO jk=1,jpkm1945 uu(ji,jj,jk,Kmm_a) = uu(ji,jj,jk,Kmm_a) + zcorr * umask(ji,jj,jk)946 END DO947 !948 780 ! Update barotropic velocities: 949 781 IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN … … 955 787 uu_b(ji,jj,Kmm_a) = tabres(ji,jj) * r1_hu(ji,jj,Kmm_a) * umask(ji,jj,1) 956 788 ! 957 ! Correct "before" velocities to hold correct bt component:958 zpgu(ji,jj) = 0.e0959 DO jk=1,jpkm1960 zpgu(ji,jj) = zpgu(ji,jj) + e3u(ji,jj,jk,Kbb_a) * uu(ji,jj,jk,Kbb_a)961 END DO962 !963 zcorr = uu_b(ji,jj,Kbb_a) - zpgu(ji,jj) * r1_hu(ji,jj,Kbb_a)964 DO jk=1,jpkm1965 uu(ji,jj,jk,Kbb_a) = uu(ji,jj,jk,Kbb_a) + zcorr * umask(ji,jj,jk)966 END DO967 !968 789 END DO 969 790 END DO … … 1002 823 DO ji=i1,i2 1003 824 tabres(ji,jj) = tabres(ji,jj) * r1_e1v(ji,jj) 1004 !1005 ! Update "now" 3d velocities:1006 zpgv(ji,jj) = 0.e01007 DO jk=1,jpkm11008 zpgv(ji,jj) = zpgv(ji,jj) + e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)1009 END DO1010 !1011 zcorr = (tabres(ji,jj) - zpgv(ji,jj)) * r1_hv(ji,jj,Kmm_a)1012 DO jk=1,jpkm11013 vv(ji,jj,jk,Kmm_a) = vv(ji,jj,jk,Kmm_a) + zcorr * vmask(ji,jj,jk)1014 END DO1015 !1016 825 ! Update barotropic velocities: 1017 826 IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN … … 1023 832 vv_b(ji,jj,Kmm_a) = tabres(ji,jj) * r1_hv(ji,jj,Kmm_a) * vmask(ji,jj,1) 1024 833 ! 1025 ! Correct "before" velocities to hold correct bt component:1026 zpgv(ji,jj) = 0.e01027 DO jk=1,jpkm11028 zpgv(ji,jj) = zpgv(ji,jj) + e3v(ji,jj,jk,Kbb_a) * vv(ji,jj,jk,Kbb_a)1029 END DO1030 !1031 zcorr = vv_b(ji,jj,Kbb_a) - zpgv(ji,jj) * r1_hv(ji,jj,Kbb_a)1032 DO jk=1,jpkm11033 vv(ji,jj,jk,Kbb_a) = vv(ji,jj,jk,Kbb_a) + zcorr * vmask(ji,jj,jk)1034 END DO1035 !1036 834 END DO 1037 835 END DO … … 1120 918 ub2_i_b(ji,jj) = ub2_i_b(ji,jj) + za1 * zcor 1121 919 ! Update corrective fluxes: 1122 un_bf(ji,jj) = un_bf(ji,jj) + zcor920 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) un_bf(ji,jj) = un_bf(ji,jj) + zcor 1123 921 ! Update half step back fluxes: 1124 922 ub2_b(ji,jj) = tabres(ji,jj) … … 1208 1006 vb2_i_b(ji,jj) = vb2_i_b(ji,jj) + za1 * zcor 1209 1007 ! Update corrective fluxes: 1210 vn_bf(ji,jj) = vn_bf(ji,jj) + zcor1008 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) vn_bf(ji,jj) = vn_bf(ji,jj) + zcor 1211 1009 ! Update half step back fluxes: 1212 1010 vb2_b(ji,jj) = tabres(ji,jj) … … 1479 1277 #endif 1480 1278 1279 SUBROUTINE Agrif_Check_parent_bat( ) 1280 !!---------------------------------------------------------------------- 1281 !! *** ROUTINE Agrif_Check_parent_bat *** 1282 !!---------------------------------------------------------------------- 1283 ! 1284 IF (( .NOT.ln_agrif_2way ).OR.(.NOT.ln_chk_bathy).OR.(Agrif_Root())) RETURN 1285 ! 1286 Agrif_UseSpecialValueInUpdate = .FALSE. 1287 ! 1288 IF(lwp) WRITE(numout,*) ' ' 1289 IF(lwp) WRITE(numout,*) 'AGRIF: Check parent volume at Level:', Agrif_Level() 1290 ! 1291 # if ! defined DECAL_FEEDBACK 1292 CALL Agrif_Update_Variable(batupd_id,procname = update_bat) 1293 # else 1294 CALL Agrif_Update_Variable(batupd_id,locupdate=(/1,0/),procname = update_bat) 1295 # endif 1296 ! 1297 kindic_agr = Agrif_Parent(kindic_agr) 1298 CALL mpp_sum( 'Agrif_Check_parent_bat', kindic_agr ) 1299 1300 IF( kindic_agr /= 0 ) THEN 1301 CALL ctl_stop('==> Averaged Bathymetry does not match parent volume') 1302 ELSE 1303 IF(lwp) WRITE(numout,*) '==> Averaged Bathymetry matches parent ' 1304 IF(lwp) WRITE(numout,*) '' 1305 ENDIF 1306 ! 1307 END SUBROUTINE Agrif_Check_parent_bat 1308 1309 SUBROUTINE update_bat(ptab, i1, i2, j1, j2, before ) 1310 !!--------------------------------------------- 1311 !! *** ROUTINE update_bat *** 1312 !!--------------------------------------------- 1313 REAL(wp), DIMENSION(i1:i2,j1:j2) :: ptab 1314 INTEGER, INTENT(in) :: i1, i2, j1, j2 1315 LOGICAL, INTENT(in) :: before 1316 INTEGER :: ji, jj 1317 ! 1318 !!--------------------------------------------- 1319 ! 1320 IF( before ) THEN 1321 ptab(i1:i2,j1:j2) = ht_0(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 1322 ELSE 1323 kindic_agr = 0 1324 ! 1325 DO jj=j1,j2 1326 DO ji=i1,i2 1327 IF ( (ssmask(ji,jj).NE.0._wp).AND.& 1328 & (ABS(ptab(ji,jj)-ht_0(ji,jj)).GE.1.e-6) ) THEN 1329 kindic_agr = kindic_agr + 1 1330 ENDIF 1331 END DO 1332 END DO 1333 ! 1334 ENDIF 1335 ! 1336 END SUBROUTINE update_bat 1337 1481 1338 #else 1482 1339 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/NST/agrif_top_interp.F90
r13216 r14098 43 43 Agrif_SpecialValue = 0._wp 44 44 Agrif_UseSpecialValue = .TRUE. 45 l_vremap = ln_vert_remap 45 46 ! 46 47 CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 48 ! 47 49 Agrif_UseSpecialValue = .FALSE. 50 l_vremap = .FALSE. 48 51 ! 49 52 END SUBROUTINE Agrif_trc … … 57 60 LOGICAL , INTENT(in ) :: before 58 61 ! 59 INTEGER :: ji, jj, jk, jn, ibdy, jbdy ! dummy loop indices 60 INTEGER :: imin, imax, jmin, jmax, N_in, N_out 61 REAL(wp) :: zrho, z1, z2, z3, z4, z5, z6, z7 62 62 INTEGER :: ji, jj, jk, jn ! dummy loop indices 63 INTEGER :: N_in, N_out 64 INTEGER :: item 63 65 ! vertical interpolation: 64 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: ptab_child 65 REAL(wp), DIMENSION(k1:k2,1:jptra) :: tabin 66 REAL(wp), DIMENSION(k1:k2) :: h_in 67 REAL(wp), DIMENSION(1:jpk) :: h_out 68 !!---------------------------------------------------------------------- 69 70 IF( before ) THEN 66 REAL(wp) :: zhtot, zwgt 67 REAL(wp), DIMENSION(k1:k2,1:jptra) :: tabin, tabin_i 68 REAL(wp), DIMENSION(k1:k2) :: z_in, h_in_i, z_in_i 69 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 70 !!---------------------------------------------------------------------- 71 72 IF( before ) THEN 73 74 item = Kmm_a 75 IF( l_ini_child ) Kmm_a = Kbb_a 76 71 77 DO jn = 1,jptra 72 78 DO jk=k1,k2 … … 77 83 END DO 78 84 END DO 79 END DO 80 81 # if defined key_vertical 82 DO jk=k1,k2 83 DO jj=j1,j2 84 DO ji=i1,i2 85 ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 86 END DO 87 END DO 88 END DO 89 # endif 85 END DO 86 87 IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN 88 ! Fill cell depths (i.e. gdept) to be interpolated 89 ! Warning: these are masked, hence extrapolated prior interpolation. 90 DO jj=j1,j2 91 DO ji=i1,i2 92 ptab(ji,jj,k1,jptra+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kmm_a) 93 DO jk=k1+1,k2 94 ptab(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * & 95 & ( ptab(ji,jj,jk-1,jptra+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kmm_a)+e3t(ji,jj,jk,Kmm_a)) ) 96 END DO 97 END DO 98 END DO 99 100 ! Save ssh at last level: 101 IF (.NOT.ln_linssh) THEN 102 ptab(i1:i2,j1:j2,k2,jptra+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 103 END IF 104 ENDIF 105 Kmm_a = item 106 90 107 ELSE 91 92 # if defined key_vertical 93 DO jj=j1,j2 94 DO ji=i1,i2 95 ptab_child(ji,jj,:) = 0._wp 96 N_in = 0 97 DO jk=k1,k2 !k2 = jpk of parent grid 98 IF (ptab(ji,jj,jk,n2) == 0) EXIT 99 N_in = N_in + 1 100 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 101 h_in(N_in) = ptab(ji,jj,jk,n2) 108 item = Krhs_a 109 IF( l_ini_child ) Krhs_a = Kbb_a 110 111 IF( l_vremap .OR. l_ini_child ) THEN 112 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 113 114 DO jj=j1,j2 115 DO ji=i1,i2 116 tr(ji,jj,:,:,Krhs_a) = 0. 117 ! 118 ! Build vertical grids: 119 N_in = mbkt_parent(ji,jj) 120 ! Input grid (account for partial cells if any): 121 DO jk=1,N_in 122 z_in(jk) = ptab(ji,jj,jk,n2) - ptab(ji,jj,k2,n2) 123 tabin(jk,1:jptra) = ptab(ji,jj,jk,1:jptra) 124 END DO 125 126 ! Intermediate grid: 127 IF ( l_vremap ) THEN 128 DO jk = 1, N_in 129 h_in_i(jk) = e3t0_parent(ji,jj,jk) * & 130 & (1._wp + ptab(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj))) 131 END DO 132 z_in_i(1) = 0.5_wp * h_in_i(1) 133 DO jk=2,N_in 134 z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) ) 135 END DO 136 z_in_i(1:N_in) = z_in_i(1:N_in) - ptab(ji,jj,k2,n2) 137 ENDIF 138 139 ! Output (Child) grid: 140 N_out = mbkt(ji,jj) 141 DO jk=1,N_out 142 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 143 END DO 144 z_out(1) = 0.5_wp * h_out(1) 145 DO jk=2,N_out 146 z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) ) 147 END DO 148 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a) 149 150 IF (N_in*N_out > 0) THEN 151 IF( l_ini_child ) THEN 152 CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a), & 153 & z_out(1:N_out),N_in,N_out,jptra) 154 ELSE 155 CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tabin_i(1:N_in,1:jptra), & 156 & z_in_i(1:N_in),N_in,N_in,jptra) 157 CALL reconstructandremap(tabin_i(1:N_in,1:jptra),h_in_i(1:N_in),tr(ji,jj,1:N_out,1:jptra,Krhs_a), & 158 & h_out(1:N_out),N_in,N_out,jptra) 159 ENDIF 160 ENDIF 102 161 END DO 103 N_out = 0 104 DO jk=1,jpk ! jpk of child grid 105 IF (tmask(ji,jj,jk) == 0) EXIT 106 N_out = N_out + 1 107 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 108 ENDDO 109 IF (N_in > 0) THEN 110 CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in,ptab_child(ji,jj,1:N_out,1:jptra),h_out,N_in,N_out,jptra) 111 ENDIF 112 ENDDO 113 ENDDO 114 # else 115 ptab_child(i1:i2,j1:j2,1:jpk,1:jptra) = ptab(i1:i2,j1:j2,1:jpk,1:jptra) 116 # endif 117 ! 118 DO jn=1, jptra 119 tr(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab_child(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 120 END DO 162 END DO 163 Krhs_a = item 164 165 ELSE 166 167 IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells 168 ! linear vertical interpolation 169 DO jj=j1,j2 170 DO ji=i1,i2 171 ! 172 N_in = mbkt(ji,jj) 173 N_out = mbkt(ji,jj) 174 z_in(1) = ptab(ji,jj,1,n2) 175 tabin(1,1:jptra) = ptab(ji,jj,1,1:jptra) 176 DO jk=2, N_in 177 z_in(jk) = ptab(ji,jj,jk,n2) 178 tabin(jk,1:jptra) = ptab(ji,jj,jk,1:jptra) 179 END DO 180 IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - ptab(ji,jj,k2,n2) 181 z_out(1) = 0.5_wp * e3t(ji,jj,1,Krhs_a) 182 DO jk=2, N_out 183 z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Krhs_a) + e3t(ji,jj,jk,Krhs_a)) 184 END DO 185 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a) 186 CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),ptab(ji,jj,1:N_out,1:jptra), & 187 & z_out(1:N_out),N_in,N_out,jptra) 188 END DO 189 END DO 190 191 ENDIF 192 193 DO jn=1, jptra 194 tr(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 195 END DO 196 ENDIF 197 121 198 ENDIF 122 199 ! -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/NST/agrif_top_sponge.F90
r12489 r14098 45 45 ! 46 46 #if defined SPONGE_TOP 47 !! Assume persistence 47 !! Assume persistence: 48 48 zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot()) 49 CALL Agrif_sponge 49 50 50 Agrif_SpecialValue = 0._wp 51 51 Agrif_UseSpecialValue = .TRUE. 52 l_vremap = ln_vert_remap 52 53 tabspongedone_trn = .FALSE. 54 ! 53 55 CALL Agrif_Bc_Variable( trn_sponge_id, calledweight=zcoef, procname=interptrn_sponge ) 56 ! 54 57 Agrif_UseSpecialValue = .FALSE. 58 l_vremap = .FALSE. 55 59 #endif 56 60 ! … … 58 62 59 63 60 SUBROUTINE interptrn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )61 !!---------------------------------------------------------------------- 62 !! 64 SUBROUTINE interptrn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before) 65 !!---------------------------------------------------------------------- 66 !! *** ROUTINE interptrn_sponge *** 63 67 !!---------------------------------------------------------------------- 64 68 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 … … 67 71 ! 68 72 INTEGER :: ji, jj, jk, jn ! dummy loop indices 69 REAL(wp) :: zabe1, zabe2, ztrelax 70 REAL(wp), DIMENSION(i1:i2,j1:j2) :: ztu, ztv 71 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,1:jptra) :: trbdiff 73 INTEGER :: iku, ikv 74 REAL(wp) :: ztra, zabe1, zabe2, zbtr, zhtot 75 REAL(wp), DIMENSION(i1-1:i2,j1-1:j2,jpk) :: ztu, ztv 76 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::trbdiff 72 77 ! vertical interpolation: 73 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk, 1:jptra) ::tabres_child74 REAL(wp), DIMENSION(k1:k2, 1:jptra) :: tabin75 REAL(wp), DIMENSION(k1:k2) :: h_in76 REAL(wp), DIMENSION(1:jpk) :: h_out 78 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child 79 REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin, tabin_i 80 REAL(wp), DIMENSION(k1:k2) :: z_in, z_in_i, h_in_i 81 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 77 82 INTEGER :: N_in, N_out 78 REAL(wp) :: h_diff79 83 !!---------------------------------------------------------------------- 80 84 ! … … 90 94 END DO 91 95 92 # if defined key_vertical 93 DO jk=k1,k2 94 DO jj=j1,j2 95 DO ji=i1,i2 96 tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kbb_a) 97 END DO 98 END DO 99 END DO 100 # endif 101 ELSE 102 # if defined key_vertical 103 tabres_child(:,:,:,:) = 0. 104 DO jj=j1,j2 105 DO ji=i1,i2 106 N_in = 0 107 DO jk=k1,k2 !k2 = jpk of parent grid 108 IF (tabres(ji,jj,jk,n2) == 0) EXIT 109 N_in = N_in + 1 110 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1) 111 h_in(N_in) = tabres(ji,jj,jk,n2) 112 END DO 113 N_out = 0 114 DO jk=1,jpk ! jpk of child grid 115 IF (tmask(ji,jj,jk) == 0) EXIT 116 N_out = N_out + 1 117 h_out(jk) = e3t(ji,jj,jk,Kbb_a) !Child grid scale factors. Could multiply by e1e2t here instead of division above 118 ENDDO 119 IF (N_in > 0) THEN 120 CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in,tabres_child(ji,jj,1:N_out,1:jptra),h_out,N_in,N_out,jptra) 96 IF ( l_vremap.OR.ln_zps ) THEN 97 98 ! Fill cell depths (i.e. gdept) to be interpolated 99 ! Warning: these are masked, hence extrapolated prior interpolation. 100 DO jj=j1,j2 101 DO ji=i1,i2 102 tabres(ji,jj,k1,jptra+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kbb_a) 103 DO jk=k1+1,k2 104 tabres(ji,jj,jk,jptra+1) = tmask(ji,jj,jk) * & 105 & ( tabres(ji,jj,jk-1,jptra+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kbb_a)+e3t(ji,jj,jk,Kbb_a)) ) 106 END DO 107 END DO 108 END DO 109 110 ! Save ssh at last level: 111 IF ( .NOT.ln_linssh ) THEN 112 tabres(i1:i2,j1:j2,k2,jptra+1) = ssh(i1:i2,j1:j2,Kbb_a)*tmask(i1:i2,j1:j2,1) 113 END IF 114 115 END IF 116 117 ELSE 118 ! 119 IF ( l_vremap ) THEN 120 121 IF (ln_linssh) tabres(i1:i2,j1:j2,k2,n2) = 0._wp 122 123 DO jj=j1,j2 124 DO ji=i1,i2 125 126 tabres_child(ji,jj,:,:) = 0._wp 127 ! Build vertical grids: 128 N_in = mbkt_parent(ji,jj) 129 ! Input grid (account for partial cells if any): 130 DO jk=1,N_in 131 z_in(jk) = tabres(ji,jj,jk,n2) - tabres(ji,jj,k2,n2) 132 tabin(jk,1:jptra) = tabres(ji,jj,jk,1:jptra) 133 END DO 134 135 ! Intermediate grid: 136 DO jk = 1, N_in 137 h_in_i(jk) = e3t0_parent(ji,jj,jk) * & 138 & (1._wp + tabres(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj))) 139 END DO 140 z_in_i(1) = 0.5_wp * h_in_i(1) 141 DO jk=2,N_in 142 z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) ) 143 END DO 144 z_in_i(1:N_in) = z_in_i(1:N_in) - tabres(ji,jj,k2,n2) 145 146 ! Output (Child) grid: 147 N_out = mbkt(ji,jj) 148 DO jk=1,N_out 149 h_out(jk) = e3t(ji,jj,jk,Kbb_a) 150 END DO 151 z_out(1) = 0.5_wp * h_out(1) 152 DO jk=2,N_out 153 z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) ) 154 END DO 155 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Kbb_a) 156 157 ! Account for small differences in the free-surface 158 IF ( sum(h_out(1:N_out)) > sum(h_in_i(1:N_in) )) THEN 159 h_out(1) = h_out(1) - ( sum(h_out(1:N_out))-sum(h_in_i(1:N_in)) ) 160 ELSE 161 h_in_i(1)= h_in_i(1) - ( sum(h_in_i(1:N_in))-sum(h_out(1:N_out)) ) 162 END IF 163 IF (N_in*N_out > 0) THEN 164 CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tabin_i(1:N_in,1:jptra),z_in_i(1:N_in),N_in,N_in,jptra) 165 CALL reconstructandremap(tabin_i(1:N_in,1:jptra),h_in_i(1:N_in),tabres_child(ji,jj,1:N_out,1:jptra),h_out(1:N_out),N_in,N_out,jptra) 166 ! CALL remap_linear(tabin(1:N_in,1:jptra),z_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jptra),z_out(1:N_in),N_in,N_out,jptra) 167 ENDIF 168 END DO 169 END DO 170 171 DO jj=j1,j2 172 DO ji=i1,i2 173 DO jk=1,jpkm1 174 trbdiff(ji,jj,jk,1:jptra) = (tr(ji,jj,jk,1:jptra,Kbb_a) - tabres_child(ji,jj,jk,1:jptra)) * tmask(ji,jj,jk) 175 END DO 176 END DO 177 END DO 178 179 ELSE 180 181 IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells 182 183 DO jj=j1,j2 184 DO ji=i1,i2 185 ! 186 N_in = mbkt(ji,jj) 187 N_out = mbkt(ji,jj) 188 z_in(1) = tabres(ji,jj,1,n2) 189 tabin(1,1:jptra) = tabres(ji,jj,1,1:jptra) 190 DO jk=2, N_in 191 z_in(jk) = tabres(ji,jj,jk,n2) 192 tabin(jk,1:jptra) = tabres(ji,jj,jk,1:jptra) 193 END DO 194 IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - tabres(ji,jj,k2,n2) 195 196 z_out(1) = 0.5_wp * e3t(ji,jj,1,Kbb_a) 197 DO jk=2, N_out 198 z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Kbb_a) + e3t(ji,jj,jk,Kbb_a)) 199 END DO 200 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Kbb_a) 201 202 CALL remap_linear(tabin(1:N_in,1:jptra), z_in(1:N_in), tabres(ji,jj,1:N_out,1:jptra), & 203 & z_out(1:N_out), N_in, N_out, jptra) 204 END DO 205 END DO 206 ENDIF 207 208 DO jj=j1,j2 209 DO ji=i1,i2 210 DO jk=1,jpkm1 211 trbdiff(ji,jj,jk,1:jptra) = (tr(ji,jj,jk,1:jptra,Kbb_a) - tabres(ji,jj,jk,1:jptra))*tmask(ji,jj,jk) 212 END DO 213 END DO 214 END DO 215 216 END IF 217 218 DO jn = 1, jptra 219 DO jk = 1, jpkm1 220 ztu(i1-1:i2,j1-1:j2,jk) = 0._wp 221 DO jj = j1,j2 222 DO ji = i1,i2-1 223 zabe1 = rn_sponge_tra * r1_Dt * umask(ji,jj,jk) * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 224 ztu(ji,jj,jk) = zabe1 * fspu(ji,jj) * ( trbdiff(ji+1,jj ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 225 END DO 226 END DO 227 ztv(i1-1:i2,j1-1:j2,jk) = 0._wp 228 DO ji = i1,i2 229 DO jj = j1,j2-1 230 zabe2 = rn_sponge_tra * r1_Dt * vmask(ji,jj,jk) * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 231 ztv(ji,jj,jk) = zabe2 * fspv(ji,jj) * ( trbdiff(ji ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 232 END DO 233 END DO 234 ! 235 IF( ln_zps ) THEN ! set gradient at partial step level 236 DO jj = j1,j2 237 DO ji = i1,i2 238 ! last level 239 iku = mbku(ji,jj) 240 ikv = mbkv(ji,jj) 241 IF( iku == jk ) ztu(ji,jj,jk) = 0._wp 242 IF( ikv == jk ) ztv(ji,jj,jk) = 0._wp 243 END DO 244 END DO 121 245 ENDIF 122 ENDDO 123 ENDDO 124 # endif 125 126 DO jj=j1,j2 127 DO ji=i1,i2 128 DO jk=1,jpkm1 129 # if defined key_vertical 130 trbdiff(ji,jj,jk,1:jptra) = tr(ji,jj,jk,1:jptra,Kbb_a) - tabres_child(ji,jj,jk,1:jptra) 131 # else 132 trbdiff(ji,jj,jk,1:jptra) = tr(ji,jj,jk,1:jptra,Kbb_a) - tabres(ji,jj,jk,1:jptra) 133 # endif 134 ENDDO 135 ENDDO 136 ENDDO 137 138 !* set relaxation time scale 139 IF( l_1st_euler .AND. lk_agrif_fstep ) THEN ; ztrelax = rn_trelax_tra / ( rn_Dt ) 140 ELSE ; ztrelax = rn_trelax_tra / (2._wp * rn_Dt ) 141 ENDIF 142 143 DO jn = 1, jptra 246 END DO 247 ! 248 ! JC: there is something wrong with the Laplacian in corners 144 249 DO jk = 1, jpkm1 145 DO jj = j1,j2-1 146 DO ji = i1,i2-1 147 zabe1 = rn_sponge_tra * fspu(ji,jj) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * umask(ji,jj,jk) 148 zabe2 = rn_sponge_tra * fspv(ji,jj) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vmask(ji,jj,jk) 149 ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 150 ztv(ji,jj) = zabe2 * ( trbdiff(ji ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 151 END DO 152 END DO 153 ! 154 DO jj = j1+1,j2-1 155 DO ji = i1+1,i2-1 156 IF( .NOT. tabspongedone_trn(ji,jj) ) THEN 157 tr(ji,jj,jk,jn,Krhs_a) = tr(ji,jj,jk,jn,Krhs_a) + ( ztu(ji,jj) - ztu(ji-1,jj ) & 158 & + ztv(ji,jj) - ztv(ji ,jj-1) ) & 159 & * r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm_a) & 160 & - ztrelax * fspt(ji,jj) * trbdiff(ji,jj,jk,jn) 250 DO jj = j1,j2 251 DO ji = i1,i2 252 IF (.NOT. tabspongedone_trn(ji,jj)) THEN 253 zbtr = r1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kmm_a) 254 ! horizontal diffusive trends 255 ztra = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & 256 & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) & 257 & - rn_trelax_tra * r1_Dt * fspt(ji,jj) * trbdiff(ji,jj,jk,jn) 258 ! add it to the general tracer trends 259 tr(ji,jj,jk,jn,Krhs_a) = tr(ji,jj,jk,jn,Krhs_a) + ztra 161 260 ENDIF 162 261 END DO 163 262 END DO 263 164 264 END DO 165 265 ! 166 266 END DO 167 267 ! 168 tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 268 tabspongedone_trn(i1:i2,j1:j2) = .TRUE. 269 ! 169 270 ENDIF 170 ! 271 ! 171 272 END SUBROUTINE interptrn_sponge 172 273 -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/NST/agrif_top_update.F90
r12489 r14098 40 40 IF (Agrif_Root()) RETURN 41 41 ! 42 Agrif_UseSpecialValueInUpdate = .TRUE. 42 l_vremap = ln_vert_remap 43 Agrif_UseSpecialValueInUpdate = .NOT.l_vremap 43 44 Agrif_SpecialValueFineGrid = 0._wp 45 44 46 ! 45 47 # if ! defined DECAL_FEEDBACK … … 52 54 ! 53 55 Agrif_UseSpecialValueInUpdate = .FALSE. 56 l_vremap = .FALSE. 54 57 ! 55 58 END SUBROUTINE Agrif_Update_Trc 56 59 57 #ifdef key_vertical58 60 SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 59 !!--------------------------------------------- 60 !! *** ROUTINE updateT *** 61 !!--------------------------------------------- 61 62 62 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 63 63 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres … … 72 72 REAL(wp) :: tabin(k1:k2,1:jptra) 73 73 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,1:jptra) :: tabres_child 74 !!--------------------------------------------- 75 ! 74 76 75 IF (before) THEN 77 AGRIF_SpecialValue = -999._wp 78 DO jn = n1,n2-1 76 IF ( l_vremap ) THEN 77 DO jn = n1,n2-1 78 DO jk=k1,k2 79 DO jj=j1,j2 80 DO ji=i1,i2 81 tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) 82 END DO 83 END DO 84 END DO 85 END DO 79 86 DO jk=k1,k2 80 87 DO jj=j1,j2 81 88 DO ji=i1,i2 82 tabres(ji,jj,jk,jn) = (tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) ) & 83 * tmask(ji,jj,jk) + (tmask(ji,jj,jk)-1)*999._wp 84 END DO 85 END DO 86 END DO 87 END DO 88 DO jk=k1,k2 89 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 90 END DO 91 END DO 92 END DO 93 ELSE 94 DO jn = 1,jptra 95 DO jk=k1,k2 96 DO jj=j1,j2 97 DO ji=i1,i2 98 tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk) 99 END DO 100 END DO 101 END DO 102 END DO 103 104 ENDIF 105 ELSE 106 IF ( l_vremap ) THEN 107 tabres_child(:,:,:,:) = 0._wp 108 AGRIF_SpecialValue = 0._wp 89 109 DO jj=j1,j2 90 110 DO ji=i1,i2 91 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) &92 + (tmask(ji,jj,jk)-1)*999._wp93 END DO94 END DO95 END DO96 ELSE97 tabres_child(:,:,:,:) = 0.98 AGRIF_SpecialValue = 0._wp99 DO jj=j1,j2100 DO ji=i1,i2101 N_in = 0102 DO jk=k1,k2 !k2 = jpk of child grid103 IF (tabres(ji,jj,jk,n2) == 0 ) EXIT104 N_in = N_in + 1105 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2)106 h_in(N_in) = tabres(ji,jj,jk,n2)111 N_in = 0 112 DO jk=k1,k2 !k2 = jpk of child grid 113 IF (tabres(ji,jj,jk,n2) <= 1.e-6_wp ) EXIT 114 N_in = N_in + 1 115 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 116 h_in(N_in) = tabres(ji,jj,jk,n2) 117 ENDDO 118 N_out = 0 119 DO jk=1,jpk ! jpk of parent grid 120 IF (tmask(ji,jj,jk) == 0 ) EXIT ! TODO: Will not work with ISF 121 N_out = N_out + 1 122 h_out(N_out) = e3t(ji,jj,jk,Kmm_a) 123 ENDDO 124 IF (N_in*N_out > 0) THEN !Remove this? 125 CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jptra),h_out(1:N_out),N_in,N_out,jptra) 126 ENDIF 107 127 ENDDO 108 N_out = 0109 DO jk=1,jpk ! jpk of parent grid110 IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF111 N_out = N_out + 1112 h_out(N_out) = e3t(ji,jj,jk,Kmm_a) !Parent grid scale factors. Could multiply by e1e2t here instead of division above113 ENDDO114 IF (N_in > 0) THEN !Remove this?115 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))116 IF (h_diff < -1.e-4) THEN117 print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out))118 print *,h_in(1:N_in)119 print *,h_out(1:N_out)120 STOP121 ENDIF122 CALL reconstructandremap(tabin(1:N_in,1:jptra),h_in(1:N_in),tabres_child(ji,jj,1:N_out,1:jptra),h_out(1:N_out),N_in,N_out,jptra)123 ENDIF124 128 ENDDO 125 ENDDO 126 ! 127 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 128 ! Add asselin part 129 DO jn = 1,jptra 130 DO jk=1,jpkm1 129 130 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 131 ! Add asselin part 132 DO jn = 1,jptra 133 DO jk = 1, jpkm1 134 DO jj = j1, j2 135 DO ji = i1, i2 136 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 137 ztb = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 138 ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a) 139 ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 140 tr(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) & 141 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 142 ENDIF 143 END DO 144 END DO 145 END DO 146 END DO 147 ENDIF 148 DO jn = 1,jptra 149 DO jk = 1, jpkm1 150 DO jj = j1, j2 151 DO ji = i1, i2 152 IF( tabres_child(ji,jj,jk,jn) /= 0._wp ) THEN 153 tr(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn) 154 END IF 155 END DO 156 END DO 157 END DO 158 END DO 159 ELSE 160 DO jn = 1,jptra 161 tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) & 162 & * tmask(i1:i2,j1:j2,k1:k2) 163 ENDDO 164 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN 165 ! Add asselin part 166 DO jn = 1,jptra 167 DO jk = k1, k2 168 DO jj = j1, j2 169 DO ji = i1, i2 170 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 171 ztb = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 172 ztnu = tabres(ji,jj,jk,jn) 173 ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 174 tr(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) & 175 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 176 ENDIF 177 END DO 178 END DO 179 END DO 180 END DO 181 ENDIF 182 DO jn = 1,jptra 183 DO jk=k1,k2 131 184 DO jj=j1,j2 132 185 DO ji=i1,i2 133 IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 134 ztb = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used 135 ztnu = tabres_child(ji,jj,jk,jn) * e3t(ji,jj,jk,Kmm_a) 136 ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a) 137 tr(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) & 138 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a) 139 ENDIF 140 ENDDO 141 ENDDO 142 ENDDO 143 ENDDO 186 IF( tabres(ji,jj,jk,jn) /= 0._wp ) THEN 187 tr(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a) 188 END IF 189 END DO 190 END DO 191 END DO 192 END DO 193 ! 144 194 ENDIF 145 DO jn = 1,jptra146 DO jk=1,jpkm1147 DO jj=j1,j2148 DO ji=i1,i2149 IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN150 tr(ji,jj,jk,jn,Kmm_a) = tabres_child(ji,jj,jk,jn)151 END IF152 END DO153 END DO154 END DO155 END DO156 !157 195 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN 158 196 tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kbb_a) = tr(i1:i2,j1:j2,1:jpkm1,1:jptra,Kmm_a) 159 197 ENDIF 160 !161 162 198 ENDIF 163 ! 199 ! 164 200 END SUBROUTINE updateTRC 165 166 167 #else168 SUBROUTINE updateTRC( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )169 !!----------------------------------------------------------------------170 !! *** ROUTINE updateTRC ***171 !!----------------------------------------------------------------------172 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2173 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres174 LOGICAL , INTENT(in ) :: before175 !!176 INTEGER :: ji,jj,jk,jn177 REAL(wp) :: ztb, ztnu, ztno178 !!----------------------------------------------------------------------179 !180 !181 IF (before) THEN182 DO jn = n1,n2183 DO jk=k1,k2184 DO jj=j1,j2185 DO ji=i1,i2186 !> jc tmp187 tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a) / e3t_0(ji,jj,jk)188 ! tabres(ji,jj,jk,jn) = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Kmm_a)189 !< jc tmp190 END DO191 END DO192 END DO193 END DO194 ELSE195 !> jc tmp196 DO jn = n1,n2197 tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) &198 & * tmask(i1:i2,j1:j2,k1:k2)199 ENDDO200 !< jc tmp201 IF (.NOT.(lk_agrif_fstep.AND.(l_1st_euler))) THEN202 ! Add asselin part203 DO jn = n1,n2204 DO jk=k1,k2205 DO jj=j1,j2206 DO ji=i1,i2207 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN208 ztb = tr(ji,jj,jk,jn,Kbb_a) * e3t(ji,jj,jk,Kbb_a) ! fse3t_b prior update should be used209 ztnu = tabres(ji,jj,jk,jn)210 ztno = tr(ji,jj,jk,jn,Kmm_a) * e3t(ji,jj,jk,Krhs_a)211 tr(ji,jj,jk,jn,Kbb_a) = ( ztb + rn_atfp * ( ztnu - ztno) ) &212 & * tmask(ji,jj,jk) / e3t(ji,jj,jk,Kbb_a)213 ENDIF214 ENDDO215 ENDDO216 ENDDO217 ENDDO218 ENDIF219 DO jn = n1,n2220 DO jk=k1,k2221 DO jj=j1,j2222 DO ji=i1,i2223 IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN224 tr(ji,jj,jk,jn,Kmm_a) = tabres(ji,jj,jk,jn) / e3t(ji,jj,jk,Kmm_a)225 END IF226 END DO227 END DO228 END DO229 END DO230 !231 IF ((l_1st_euler).AND.(Agrif_Nb_Step()==0) ) THEN232 tr(i1:i2,j1:j2,k1:k2,n1:n2,Kbb_a) = tr(i1:i2,j1:j2,k1:k2,n1:n2,Kmm_a)233 ENDIF234 !235 ENDIF236 !237 END SUBROUTINE updateTRC238 #endif239 201 240 202 #else -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/NST/agrif_user.F90
r14066 r14098 1 1 #undef UPD_HIGH /* MIX HIGH UPDATE */ 2 #define DIV_CONS /* DIVERGENCE CONS */ 2 3 #if defined key_agrif 3 4 !! * Substitutions … … 42 43 43 44 44 SUBROUTINE Agrif_Istate( Kbb, Kmm, Kaa )45 !!----------------------------------------------------------------------46 !! *** ROUTINE agrif_istate ***47 !!----------------------------------------------------------------------48 USE domvvl49 USE domain50 USE par_oce51 USE agrif_oce52 USE agrif_oce_interp53 USE oce54 USE lib_mpp55 USE lbclnk56 !57 IMPLICIT NONE58 !59 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa60 INTEGER :: jn61 !!----------------------------------------------------------------------62 IF(lwp) WRITE(numout,*) ' '63 IF(lwp) WRITE(numout,*) 'AGRIF: interp child initial state from parent'64 IF(lwp) WRITE(numout,*) ' '65 66 l_ini_child = .TRUE.67 Agrif_SpecialValue = 0.0_wp68 Agrif_UseSpecialValue = .TRUE.69 uu(:,:,:,:) = 0.0_wp ; vv(:,:,:,:) = 0.0_wp ; ts(:,:,:,:,:) = 0.0_wp70 71 Krhs_a = Kbb ; Kmm_a = Kbb72 73 ! Brutal fix to pas 1x1 refinment.74 ! IF(Agrif_Irhox() == 1) THEN75 ! CALL Agrif_Init_Variable(tsini_id, procname=agrif_initts)76 ! ELSE77 CALL Agrif_Init_Variable(tsini_id, procname=interptsn)78 79 ! ENDIF80 ! just for VORTEX because Parent velocities can actually be exactly zero81 ! Agrif_UseSpecialValue = .FALSE.82 Agrif_UseSpecialValue = ln_spc_dyn83 use_sign_north = .TRUE.84 sign_north = -1.85 CALL Agrif_Init_Variable(uini_id , procname=interpun )86 CALL Agrif_Init_Variable(vini_id , procname=interpvn )87 use_sign_north = .FALSE.88 89 Agrif_UseSpecialValue = .FALSE.90 l_ini_child = .FALSE.91 92 Krhs_a = Kaa ; Kmm_a = Kmm93 94 DO jn = 1, jpts95 ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb)*tmask(:,:,:)96 END DO97 uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:)98 vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:)99 100 101 CALL lbc_lnk_multi( 'agrif_istate', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp )102 CALL lbc_lnk( 'agrif_istate', ts(:,:,:,:,Kbb), 'T', 1.0_wp )103 104 END SUBROUTINE Agrif_Istate105 106 107 45 SUBROUTINE agrif_declare_var_ini 108 46 !!---------------------------------------------------------------------- … … 118 56 IMPLICIT NONE 119 57 ! 120 INTEGER :: ind1, ind2, ind3 58 INTEGER :: ind1, ind2, ind3, imaxrho 121 59 INTEGER :: its 122 60 External :: nemo_mapping … … 134 72 ENDIF 135 73 74 IF ( .NOT. lk_north ) THEN 75 CALL Agrif_Set_DistantCommonBorderY(.TRUE.) 76 ENDIF 77 136 78 ! 1. Declaration of the type of variable which have to be interpolated 137 79 !--------------------------------------------------------------------- 138 ind1 = nbghostcells 80 ind1 = nbghostcells 139 81 ind2 = nn_hls + 2 + nbghostcells_x 140 82 ind3 = nn_hls + 2 + nbghostcells_y_s 141 142 CALL agrif_declare_variable((/2,2,0 /),(/ind2 ,ind3,0 /),(/'x','y','N' /),(/1,1,1 /),(/jpi,jpj,jpk /), e3t_id) 143 CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), mbkt_id) 144 CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), ht0_id) 145 146 CALL agrif_declare_variable((/1,2 /),(/ind2-1,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), e1u_id) 147 CALL agrif_declare_variable((/2,1 /),(/ind2 ,ind3-1 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), e2v_id) 83 imaxrho = MAX(Agrif_irhox(), Agrif_irhoy()) 84 85 CALL agrif_declare_variable((/2,2,0 /),(/ind2 ,ind3,0 /),(/'x','y','N' /),(/1,1,1 /),(/jpi,jpj,jpk /), e3t_id) 86 CALL agrif_declare_variable((/2,2,0 /),(/ind2 ,ind3,0 /),(/'x','y','N' /),(/1,1,1 /),(/jpi,jpj,jpk /),e3t0_interp_id) 87 CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), mbkt_id) 88 CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /), ht0_id) 148 89 149 90 ! Initial or restart velues … … 154 95 CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /),sshini_id) 155 96 ! 97 ! Update location 98 CALL agrif_declare_variable((/2,2/),(/ind2 ,ind3 /),(/'x','y'/),(/1,1/),(/jpi,jpj/), batupd_id) 156 99 157 100 ! 2. Type of interpolation 158 101 !------------------------- 159 CALL Agrif_Set_bcinterp( e3t_id,interp =AGRIF_constant) 160 161 CALL Agrif_Set_bcinterp( mbkt_id,interp =AGRIF_constant) 162 CALL Agrif_Set_interp ( mbkt_id,interp =AGRIF_constant) 163 CALL Agrif_Set_bcinterp( ht0_id,interp =AGRIF_constant) 164 CALL Agrif_Set_interp ( ht0_id,interp =AGRIF_constant) 165 166 CALL Agrif_Set_bcinterp( e1u_id,interp1=Agrif_linear, interp2=AGRIF_ppm ) 167 CALL Agrif_Set_bcinterp( e2v_id,interp1=AGRIF_ppm , interp2=Agrif_linear ) 102 CALL Agrif_Set_bcinterp( e3t_id,interp =AGRIF_constant) 103 CALL Agrif_Set_bcinterp(e3t0_interp_id,interp =AGRIF_linear ) 104 CALL Agrif_Set_interp (e3t0_interp_id,interp =AGRIF_linear ) 105 CALL Agrif_Set_bcinterp( mbkt_id,interp =AGRIF_constant) 106 CALL Agrif_Set_interp ( mbkt_id,interp =AGRIF_constant) 107 CALL Agrif_Set_bcinterp( ht0_id,interp =AGRIF_constant) 108 CALL Agrif_Set_interp ( ht0_id,interp =AGRIF_constant) 168 109 169 110 ! Initial fields … … 179 120 ! 3. Location of interpolation 180 121 !----------------------------- 181 ! CALL Agrif_Set_bc( e3t_id, (/-nn_sponge_len* Agrif_irhox(),ind1-1/) )122 ! CALL Agrif_Set_bc( e3t_id, (/-nn_sponge_len*imaxrho,ind1-1/) ) 182 123 ! JC: check near the boundary only until matching in sponge has been sorted out: 183 124 CALL Agrif_Set_bc( e3t_id, (/0,ind1-1/) ) … … 185 126 ! extend the interpolation zone by 1 more point than necessary: 186 127 ! RB check here 187 CALL Agrif_Set_bc( mbkt_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) ) 188 CALL Agrif_Set_bc( ht0_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) ) 189 190 CALL Agrif_Set_bc( e1u_id, (/0,ind1-1/) ) 191 CALL Agrif_Set_bc( e2v_id, (/0,ind1-1/) ) 192 193 CALL Agrif_Set_bc( tsini_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4 194 CALL Agrif_Set_bc( uini_id, (/0,ind1-1/) ) 195 CALL Agrif_Set_bc( vini_id, (/0,ind1-1/) ) 196 CALL Agrif_Set_bc( sshini_id, (/0,ind1-1/) ) 128 CALL Agrif_Set_bc( e3t0_interp_id, (/-nn_sponge_len*imaxrho-2,ind1/) ) 129 CALL Agrif_Set_bc( mbkt_id, (/-nn_sponge_len*imaxrho-2,ind1/) ) 130 CALL Agrif_Set_bc( ht0_id, (/-nn_sponge_len*imaxrho-2,ind1/) ) 131 CALL Agrif_Set_bc( tsini_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4 132 CALL Agrif_Set_bc( uini_id, (/0,ind1-1/) ) 133 CALL Agrif_Set_bc( vini_id, (/0,ind1-1/) ) 134 CALL Agrif_Set_bc( sshini_id, (/0,ind1-1/) ) 197 135 198 136 ! 4. Update type 199 137 !--------------- 200 138 # if defined UPD_HIGH 201 CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Full_Weighting) 202 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average ) 139 CALL Agrif_Set_Updatetype(batupd_id, update = Agrif_Update_Full_Weighting) 203 140 #else 204 CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy , update2=Agrif_Update_Average ) 205 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Copy ) 206 #endif 207 141 CALL Agrif_Set_Updatetype(batupd_id, update = Agrif_Update_Average) 142 #endif 143 208 144 ! CALL Agrif_Set_ExternalMapping(nemo_mapping) 209 145 ! … … 211 147 212 148 213 SUBROUTINE Agrif_Init_Domain ( Kbb, Kmm, Kaa )149 SUBROUTINE Agrif_Init_Domain 214 150 !!---------------------------------------------------------------------- 215 151 !! *** ROUTINE Agrif_Init_Domain *** … … 231 167 IMPLICIT NONE 232 168 ! 233 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa234 169 ! 235 170 LOGICAL :: check_namelist … … 237 172 REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace 238 173 INTEGER :: ji, jj, jk 174 INTEGER :: jpk_parent, ierr 239 175 !!---------------------------------------------------------------------- 240 176 … … 249 185 mbkt_parent(:,:) = 0 250 186 ! 251 !CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 )252 !CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt)187 ! CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 ) 188 ! CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt) 253 189 CALL Agrif_Init_Variable(ht0_id , procname=interpht0 ) 254 190 CALL Agrif_Init_Variable(mbkt_id, procname=interpmbkt) … … 263 199 IF ( ln_sco.AND.Agrif_Parent(ln_sco) ) THEN 264 200 DO_2D( 1, 0, 1, 0 ) 265 hu0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji+1,jj) ) 266 hv0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji,jj+1) ) 201 hu0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji+1,jj) ) * ssumask(ji,jj) 202 hv0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji,jj+1) ) * ssvmask(ji,jj) 267 203 END_2D 268 204 ELSE … … 277 213 zk(ji,jj) = REAL( mbku_parent(ji,jj), wp ) 278 214 END_2D 279 CALL lbc_lnk( 'Agrif_InitValues_ cont', zk, 'U', 1.0_wp )215 CALL lbc_lnk( 'Agrif_InitValues_Domain', zk, 'U', 1.0_wp ) 280 216 mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 281 217 DO_2D( 0, 0, 0, 0 ) 282 218 zk(ji,jj) = REAL( mbkv_parent(ji,jj), wp ) 283 219 END_2D 284 CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1.0_wp ) 285 mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 286 287 IF ( ln_init_chfrpar ) THEN 288 CALL Agrif_Init_Variable(sshini_id, procname=agrif_initssh) 289 CALL lbc_lnk( 'Agrif_Init_Domain', ssh(:,:,Kbb), 'T', 1. ) 290 #if ! defined key_qco 291 DO jk = 1, jpk 292 e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) & 293 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 294 & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 295 END DO 296 #endif 220 CALL lbc_lnk( 'Agrif_InitValues_Domain', zk, 'V', 1.0_wp ) 221 mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 222 ! 223 ! Build "intermediate" parent vertical grid on child domain 224 IF ( ln_vert_remap ) THEN 225 226 jpk_parent = Agrif_parent( jpk ) 227 ALLOCATE(e3t0_parent(jpi,jpj,jpk_parent), & 228 & e3u0_parent(jpi,jpj,jpk_parent), & 229 & e3v0_parent(jpi,jpj,jpk_parent), STAT = ierr) 230 IF( ierr > 0 ) CALL ctl_warn('Agrif_Init_Domain: allocation of arrays failed') 231 232 ! Retrieve expected parent scale factors on child grid: 233 Agrif_UseSpecialValue = .FALSE. 234 e3t0_parent(:,:,:) = 0._wp 235 CALL Agrif_Init_Variable(e3t0_interp_id, procname=interpe3t0_vremap) 236 ! 237 ! Deduce scale factors at U and V points: 238 DO_3D( 0, 0, 0, 0, 1, jpk_parent ) 239 e3u0_parent(ji,jj,jk) = 0.5_wp * (e3t0_parent(ji,jj,jk) + e3t0_parent(ji+1,jj ,jk)) 240 e3v0_parent(ji,jj,jk) = 0.5_wp * (e3t0_parent(ji,jj,jk) + e3t0_parent(ji ,jj+1,jk)) 241 END_3D 242 243 ! Assume a step at the bottom except if (pure) s-coordinates 244 IF ( .NOT.Agrif_Parent(ln_sco) ) THEN 245 DO_2D( 1, 0, 1, 0 ) 246 jk = mbku_parent(ji,jj) 247 e3u0_parent(ji,jj,jk) = MIN(e3t0_parent(ji,jj,jk), e3t0_parent(ji+1,jj ,jk)) 248 jk = mbkv_parent(ji,jj) 249 e3v0_parent(ji,jj,jk) = MIN(e3t0_parent(ji,jj,jk), e3t0_parent(ji ,jj+1,jk)) 250 END_2D 251 ENDIF 252 253 CALL lbc_lnk_multi( 'Agrif_Init_Domain', e3u0_parent, 'U', 1.0_wp, e3v0_parent, 'V', 1.0_wp ) 297 254 ENDIF 298 255 … … 305 262 ! 306 263 kindic_agr = 0 307 IF( .NOT. l _vremap ) THEN264 IF( .NOT. ln_vert_remap ) THEN 308 265 ! 309 266 ! check if tmask and vertical scale factors agree with parent in sponge area: … … 313 270 ! 314 271 ! In case of vertical interpolation, check only that total depths agree between child and parent: 315 DO ji = 1, jpi 316 DO jj = 1, jpj 317 IF ((mbkt_parent(ji,jj)/=0).AND.(ABS(ht0_parent(ji,jj)-ht_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 318 IF ((mbku_parent(ji,jj)/=0).AND.(ABS(hu0_parent(ji,jj)-hu_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 319 IF ((mbkv_parent(ji,jj)/=0).AND.(ABS(hv0_parent(ji,jj)-hv_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 320 END DO 321 END DO 322 323 CALL mpp_sum( 'agrif_user', kindic_agr ) 272 273 CALL Agrif_check_bat( kindic_agr ) 274 275 CALL mpp_sum( 'agrif_InitValues_Domain', kindic_agr ) 324 276 IF( kindic_agr /= 0 ) THEN 325 277 CALL ctl_stop('==> Child Bathymetry is NOT correct near boundaries.') … … 330 282 ENDIF 331 283 ENDIF 332 333 IF( l_vremap ) THEN 334 ! Additional constrain that should be removed someday: 335 IF ( Agrif_Parent(jpk).GT.jpk ) THEN 336 CALL ctl_stop( ' With l_vremap, child grids must have jpk greater or equal to the parent value' ) 337 ENDIF 338 ENDIF 284 ! 285 WHERE (ssumask(:,:) == 0._wp) mbku_parent(:,:) = 0 286 WHERE (ssvmask(:,:) == 0._wp) mbkv_parent(:,:) = 0 287 WHERE (ssmask(:,:) == 0._wp) mbkt_parent(:,:) = 0 339 288 ! 340 289 END SUBROUTINE Agrif_Init_Domain … … 365 314 LOGICAL :: check_namelist 366 315 CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4 367 REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace368 INTEGER :: ji, jj369 316 370 317 ! 1. Declaration of the type of variable which have to be interpolated … … 376 323 Agrif_SpecialValue = 0._wp 377 324 Agrif_UseSpecialValue = .TRUE. 378 CALL Agrif_Bc_variable( tsn_id,calledweight=1.,procname=interptsn) 325 l_vremap = ln_vert_remap 326 327 CALL Agrif_Bc_variable(ts_interp_id,calledweight=1.,procname=interptsn) 379 328 CALL Agrif_Sponge 380 329 tabspongedone_tsn = .FALSE. 381 CALL Agrif_Bc_variable(ts n_sponge_id,calledweight=1.,procname=interptsn_sponge)330 CALL Agrif_Bc_variable(ts_sponge_id,calledweight=1.,procname=interptsn_sponge) 382 331 ! reset tsa to zero 383 332 ts(:,:,:,:,Krhs_a) = 0._wp … … 394 343 tabspongedone_v = .FALSE. 395 344 CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 345 IF (nn_shift_bar>0) THEN 346 CALL Agrif_Sponge_2d 347 tabspongedone_u = .FALSE. 348 tabspongedone_v = .FALSE. 349 CALL Agrif_Bc_variable(unb_sponge_id,calledweight=1.,procname=interpunb_sponge) 350 tabspongedone_u = .FALSE. 351 tabspongedone_v = .FALSE. 352 CALL Agrif_Bc_variable(vnb_sponge_id,calledweight=1.,procname=interpvnb_sponge) 353 ENDIF 396 354 use_sign_north = .FALSE. 397 355 uu(:,:,:,Krhs_a) = 0._wp … … 407 365 use_sign_north = .TRUE. 408 366 sign_north = -1. 367 CALL Agrif_Bc_variable( unb_interp_id,calledweight=1.,procname=interpunb ) 368 CALL Agrif_Bc_variable( vnb_interp_id,calledweight=1.,procname=interpvnb ) 409 369 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) ! must be called before unb_id to define ubdy 410 370 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) ! must be called before vnb_id to define vbdy 411 CALL Agrif_Bc_variable( unb_id,calledweight=1.,procname=interpunb )412 CALL Agrif_Bc_variable( vnb_id,calledweight=1.,procname=interpvnb )413 371 use_sign_north = .FALSE. 414 372 ubdy(:,:) = 0._wp 415 373 vbdy(:,:) = 0._wp 374 ELSE 375 Agrif_UseSpecialValue = ln_spc_dyn 376 use_sign_north = .TRUE. 377 sign_north = -1. 378 CALL Agrif_Bc_variable( unb_interp_id,calledweight=1.,procname=interpunb ) 379 CALL Agrif_Bc_variable( vnb_interp_id,calledweight=1.,procname=interpvnb ) 380 use_sign_north = .FALSE. 381 ubdy(:,:) = 0._wp 382 vbdy(:,:) = 0._wp 416 383 ENDIF 417 384 Agrif_UseSpecialValue = .FALSE. 385 l_vremap = .FALSE. 418 386 419 387 !----------------- … … 464 432 IMPLICIT NONE 465 433 ! 466 INTEGER :: ind1, ind2, ind3 434 INTEGER :: ind1, ind2, ind3, imaxrho 467 435 !!---------------------------------------------------------------------- 468 436 … … 472 440 ind2 = nn_hls + 2 + nbghostcells_x 473 441 ind3 = nn_hls + 2 + nbghostcells_y_s 474 # if defined key_vertical 475 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),tsn_id) 476 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),tsn_sponge_id) 442 imaxrho = MAX(Agrif_irhox(), Agrif_irhoy()) 443 444 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/) ,(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),ts_interp_id) 445 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/) ,(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),ts_update_id) 446 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/) ,(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts+1/),ts_sponge_id) 477 447 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_interp_id) 478 448 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_interp_id) … … 481 451 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),un_sponge_id) 482 452 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),vn_sponge_id) 483 # else 484 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 485 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_sponge_id) 486 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_interp_id) 487 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_interp_id) 488 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_update_id) 489 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_update_id) 490 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),un_sponge_id) 491 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),vn_sponge_id) 492 # endif 493 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 494 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) 453 454 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/) ,sshn_id) 455 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/), unb_interp_id) 456 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/), vnb_interp_id) 495 457 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_interp_id) 496 458 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_interp_id) 459 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/), unb_sponge_id) 460 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/), vnb_sponge_id) 497 461 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_update_id) 498 462 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_update_id) 499 463 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/), unb_update_id) 464 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/), vnb_update_id) 465 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/) ,ub2b_cor_id) 466 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/) ,vb2b_cor_id) 500 467 ! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamt_id) 501 468 ! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphit_id) 502 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id)503 469 504 470 … … 506 472 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 507 473 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 508 # if defined key_vertical509 474 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),avm_id) 510 # else511 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,1/),avm_id)512 # endif513 475 ENDIF 514 476 515 477 ! 2. Type of interpolation 516 478 !------------------------- 517 CALL Agrif_Set_bcinterp( tsn_id,interp =AGRIF_linear) 518 CALL Agrif_Set_bcinterp( un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 519 CALL Agrif_Set_bcinterp( vn_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 520 521 CALL Agrif_Set_bcinterp( tsn_sponge_id,interp =AGRIF_linear) 522 CALL Agrif_Set_bcinterp( un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 523 CALL Agrif_Set_bcinterp( vn_sponge_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 524 525 CALL Agrif_Set_bcinterp( sshn_id,interp =AGRIF_linear) 526 CALL Agrif_Set_bcinterp( unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 527 CALL Agrif_Set_bcinterp( vnb_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 528 CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 529 CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 530 ! 531 ! > Divergence conserving alternative: 532 ! CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_constant) 533 ! CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_constant) 534 ! CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_constant,interp2=Agrif_linear) 535 ! CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_constant) 536 ! CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_constant,interp2=Agrif_linear) 537 !< 479 CALL Agrif_Set_bcinterp( ts_interp_id,interp =AGRIF_linear) 480 CALL Agrif_Set_bcinterp( ts_sponge_id,interp =AGRIF_linear) 481 482 #if defined DIV_CONS 483 lk_tint2d_notinterp = .TRUE. 484 CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_constant) 485 CALL Agrif_Set_bcinterp(ub2b_cor_id,interp=AGRIF_constant) 486 CALL Agrif_Set_bcinterp(vb2b_cor_id,interp=AGRIF_constant) 487 CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_linearconserv) 488 CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_linearconserv,interp2=Agrif_linear) 489 #else 490 lk_tint2d_notinterp = .FALSE. 491 CALL Agrif_Set_bcinterp(sshn_id,interp =AGRIF_linear) 492 CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 493 CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 494 #endif 495 496 CALL Agrif_Set_bcinterp(unb_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 497 CALL Agrif_Set_bcinterp(vnb_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 498 CALL Agrif_Set_bcinterp(unb_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 499 CALL Agrif_Set_bcinterp(vnb_sponge_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 500 501 CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 502 CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 503 504 CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 505 CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 538 506 539 507 IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear ) … … 545 513 ! 3. Location of interpolation 546 514 !----------------------------- 547 CALL Agrif_Set_bc( tsn_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4 548 CALL Agrif_Set_bc( un_interp_id, (/0,ind1-1/) ) 549 CALL Agrif_Set_bc( vn_interp_id, (/0,ind1-1/) ) 550 551 CALL Agrif_Set_bc( tsn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) ! if west, rhox=3, nn_sponge_len=2 552 CALL Agrif_Set_bc( un_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) ! and nbghost=3: 553 CALL Agrif_Set_bc( vn_sponge_id, (/-nn_sponge_len*Agrif_irhox()-1,0/) ) ! columns 4 to 11 554 555 CALL Agrif_Set_bc( sshn_id, (/0,ind1-1/) ) 556 CALL Agrif_Set_bc( unb_id, (/0,ind1-1/) ) 557 CALL Agrif_Set_bc( vnb_id, (/0,ind1-1/) ) 558 CALL Agrif_Set_bc( ub2b_interp_id, (/0,ind1-1/) ) 559 CALL Agrif_Set_bc( vb2b_interp_id, (/0,ind1-1/) ) 560 515 CALL Agrif_Set_bc( ts_interp_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4 516 CALL Agrif_Set_bc( un_interp_id, (/0,ind1-1/) ) 517 CALL Agrif_Set_bc( vn_interp_id, (/0,ind1-1/) ) 518 519 CALL Agrif_Set_bc( ts_sponge_id, (/-nn_sponge_len*imaxrho-1,0/) ) ! if west, rhox=3, nn_sponge_len=2 520 CALL Agrif_Set_bc( un_sponge_id, (/-nn_sponge_len*imaxrho-1,0/) ) ! and nbghost=3: 521 CALL Agrif_Set_bc( vn_sponge_id, (/-nn_sponge_len*imaxrho-1,0/) ) ! columns 4 to 11 522 523 CALL Agrif_Set_bc( sshn_id, (/-imaxrho*nn_shift_bar,ind1-1/) ) 524 CALL Agrif_Set_bc( unb_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) ) 525 CALL Agrif_Set_bc( vnb_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) ) 526 CALL Agrif_Set_bc(ub2b_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) ) 527 CALL Agrif_Set_bc(vb2b_interp_id, (/-imaxrho*nn_shift_bar,ind1-1/) ) 528 CALL Agrif_Set_bc( unb_sponge_id, (/-(nn_sponge_len+nn_shift_bar)*imaxrho,-imaxrho*nn_shift_bar/) ) 529 CALL Agrif_Set_bc( vnb_sponge_id, (/-(nn_sponge_len+nn_shift_bar)*imaxrho,-imaxrho*nn_shift_bar/) ) 530 CALL Agrif_Set_bc( ub2b_cor_id, (/-imaxrho*nn_shift_bar,ind1/) ) 531 CALL Agrif_Set_bc( vb2b_cor_id, (/-imaxrho*nn_shift_bar,ind1/) ) 561 532 IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) ) 562 533 !!$ CALL Agrif_Set_bc(glamt_id, (/0,ind1-1/) ) … … 567 538 568 539 # if defined UPD_HIGH 569 CALL Agrif_Set_Updatetype( tsn_id,update = Agrif_Update_Full_Weighting) 570 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) 571 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) 572 540 CALL Agrif_Set_Updatetype( ts_interp_id,update = Agrif_Update_Full_Weighting) 541 CALL Agrif_Set_Updatetype( un_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) 542 CALL Agrif_Set_Updatetype( vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) 543 544 CALL Agrif_Set_Updatetype( unb_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) 545 CALL Agrif_Set_Updatetype( vnb_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) 573 546 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) 574 547 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) … … 583 556 584 557 #else 585 CALL Agrif_Set_Updatetype( tsn_id, update = AGRIF_Update_Average) 586 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) 587 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) 588 558 CALL Agrif_Set_Updatetype( ts_update_id,update = AGRIF_Update_Average) 559 CALL Agrif_Set_Updatetype( un_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) 560 CALL Agrif_Set_Updatetype( vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) 561 562 CALL Agrif_Set_Updatetype( unb_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) 563 CALL Agrif_Set_Updatetype( vnb_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) 589 564 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) 590 565 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) … … 682 657 CALL Agrif_Set_bcinterp(tra_iceini_id, interp = AGRIF_linear) 683 658 CALL Agrif_Set_interp (tra_iceini_id, interp = AGRIF_linear) 684 CALL Agrif_Set_bcinterp(u_iceini_id , interp = AGRIF_linear 685 CALL Agrif_Set_interp (u_iceini_id , interp = AGRIF_linear 659 CALL Agrif_Set_bcinterp(u_iceini_id , interp = AGRIF_linear) 660 CALL Agrif_Set_interp (u_iceini_id , interp = AGRIF_linear) 686 661 CALL Agrif_Set_bcinterp(v_iceini_id , interp = AGRIF_linear) 687 662 CALL Agrif_Set_interp (v_iceini_id , interp = AGRIF_linear) … … 751 726 CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 752 727 ! reset tsa to zero 753 tr a(:,:,:,:) = 0._wp728 tr(:,:,:,:,Krhs_a) = 0._wp 754 729 755 730 ! 3. Some controls … … 797 772 IMPLICIT NONE 798 773 ! 799 INTEGER :: ind1, ind2, ind3 774 INTEGER :: ind1, ind2, ind3, imaxrho 800 775 !!---------------------------------------------------------------------- 801 776 !RB_CMEMS : declare here init for top … … 805 780 ind2 = nn_hls + 2 + nbghostcells_x 806 781 ind3 = nn_hls + 2 + nbghostcells_y_s 807 # if defined key_vertical 782 imaxrho = MAX(Agrif_irhox(), Agrif_irhoy()) 783 808 784 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra+1/),trn_id) 809 785 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra+1/),trn_sponge_id) 810 # else811 ! LAURENT: STRANGE why (3,3) here ?812 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id)813 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_sponge_id)814 # endif815 786 816 787 ! 2. Type of interpolation … … 822 793 !----------------------------- 823 794 CALL Agrif_Set_bc(trn_id,(/0,ind1-1/)) 824 CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len* Agrif_irhox()-1,0/))795 CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*imaxrho-1,0/)) 825 796 826 797 ! 4. Update type … … 863 834 INTEGER :: ios ! Local integer output status for namelist read 864 835 NAMELIST/namagrif/ ln_agrif_2way, ln_init_chfrpar, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, & 865 & ln_spc_dyn, ln_ chk_bathy836 & ln_spc_dyn, ln_vert_remap, ln_chk_bathy 866 837 !!-------------------------------------------------------------------------------------- 867 838 ! … … 884 855 WRITE(numout,*) ' ad. time relaxation for dynamics rn_trelax_dyn = ', rn_trelax_dyn 885 856 WRITE(numout,*) ' use special values for dynamics ln_spc_dyn = ', ln_spc_dyn 857 WRITE(numout,*) ' vertical remapping ln_vert_remap = ', ln_vert_remap 886 858 WRITE(numout,*) ' check bathymetry ln_chk_bathy = ', ln_chk_bathy 887 859 ENDIF 888 860 861 ! JC => side effects of lines below to be checked: 889 862 lk_west = .NOT. ( Agrif_Ix() == 1 ) 890 lk_east = .NOT. ( Agrif_Ix() + nbcellsx/AGRIF_Irhox() == Agrif_Parent( jpiglo) -1 )863 lk_east = .NOT. ( Agrif_Ix() + nbcellsx/AGRIF_Irhox() == Agrif_Parent(Ni0glo) -1 ) 891 864 lk_south = .NOT. ( Agrif_Iy() == 1 ) 892 lk_north = .NOT. ( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() == Agrif_Parent(jpjglo) -1 ) 893 865 lk_north = .NOT. ( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() == Agrif_Parent(Nj0glo) -1 ) 894 866 ! 895 867 ! Set the number of ghost cells according to periodicity … … 900 872 IF( jperio == 1 ) nbghostcells_x = 0 901 873 IF( .NOT. lk_south ) nbghostcells_y_s = 0 874 IF( .NOT. lk_north ) nbghostcells_y_n = 0 875 ! 902 876 ! Some checks 903 877 IF( jpiglo /= nbcellsx + 2 + 2*nn_hls + nbghostcells_x + nbghostcells_x ) CALL ctl_stop( 'STOP', & … … 906 880 & 'agrif_nemo_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n' ) 907 881 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'agrif_nemo_init:Agrif children requires ln_use_jattr = .false. ' ) 882 ! 908 883 ! 909 884 END SUBROUTINE agrif_nemo_init -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/NST/vremap.F90
r12377 r14098 320 320 ! specify methods 321 321 ! opts%edge_meth = p1e_method ! 1st-order edge interp. 322 ! opts%cell_meth = pcm_method 322 323 ! opts%cell_meth = plm_method ! PLM method in cells 323 324 opts%edge_meth = p3e_method ! 3rd-order edge interp. … … 328 329 ! limiter 329 330 ! opts%cell_lims = null_limit ! no lim. 331 ! opts%cell_lims = weno_limit 330 332 opts%cell_lims = mono_limit ! monotone limiter 331 333 … … 376 378 DO jkout = 1, kjpk_out ! Loop over destination grid 377 379 ! 378 IF ( pzout(jkout) <= pzin( 1 ) ) THEN ; ptout(jkout,1:kn_var) = ptin( 1 ,1:kn_var) 379 ELSEIF ( pzout(jkout) >= pzin(kjpk_in) ) THEN ; ptout(jkout,1:kn_var) = ptin( kjpk_in ,1:kn_var) 380 IF ( pzout(jkout) <= pzin( 1 ) ) THEN ! Surface extrapolation 381 DO jn = 1, kn_var 382 ! linear 383 ! ptout(jkout,jn) = ptin(1 ,jn) + & 384 ! & (pzout(jkout) - pzin(1)) / (pzin(2) - pzin(1)) & 385 ! & * (ptin(2,jn) - ptin(1,jn)) 386 ptout(jkout,jn) = ptin(1,jn) 387 END DO 388 ELSEIF ( pzout(jkout) >= pzin(kjpk_in) ) THEN ! Bottom extrapolation 389 DO jn = 1, kn_var 390 ! linear 391 ! ptout(jkout,jn) = ptin(kjpk_in ,jn) + & 392 ! & (pzout(jkout) - pzin(kjpk_in)) / (pzin(kjpk_in) - pzin(kjpk_in-1)) & 393 ! & * (ptin(kjpk_in,jn) - ptin(kjpk_in-1,jn)) 394 ptout(jkout,jn) = ptin(kjpk_in ,jn) 395 END DO 380 396 ELSEIF ( ( pzout(jkout) > pzin(1) ).AND.( pzout(jkout) < pzin(kjpk_in) )) THEN 381 397 DO jkin = 1, kjpk_in - 1 ! Loop over source grid -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/ASM/asminc.F90
r14085 r14098 26 26 USE par_oce ! Ocean space and time domain variables 27 27 USE dom_oce ! Ocean space and time domain 28 USE dom ain, ONLY : dom_tile28 USE domtile 29 29 USE domvvl ! domain: variable volume level 30 30 USE ldfdyn ! lateral diffusion: eddy viscosity coefficients -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/DIA/diaptr.F90
r14085 r14098 22 22 USE oce ! ocean dynamics and active tracers 23 23 USE dom_oce ! ocean space and time domain 24 USE dom ain, ONLY : dom_tile24 USE domtile 25 25 USE phycst ! physical constants 26 26 ! -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/DIA/diawri.F90
r14066 r14098 141 141 CALL iom_put("e3f_0", e3f_0(:,:,:) ) 142 142 ! 143 IF ( iom_use("tpt_dep") ) THEN 144 DO jk = 1, jpk 145 z3d(:,:,jk) = gdept(:,:,jk,Kmm) 146 END DO 147 CALL iom_put( "tpt_dep", z3d(:,:,:) ) 148 ENDIF 149 143 150 IF ( iom_use("e3t") .OR. iom_use("e3tdef") ) THEN ! time-varying e3t 144 151 DO jk = 1, jpk -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/DOM/domain.F90
r14085 r14098 39 39 USE domhgr ! domain: set the horizontal mesh 40 40 USE domzgr ! domain: set the vertical mesh 41 USE domtile 41 42 USE dommsk ! domain: set the mask system 42 43 USE domwri ! domain: write the meshmask file … … 46 47 USE closea , ONLY : dom_clo ! closed seas routine 47 48 ! 48 USE prtctl ! Print control (prt_ctl_info routine)49 49 USE in_out_manager ! I/O manager 50 50 USE iom ! I/O library … … 58 58 PUBLIC dom_init ! called by nemogcm.F90 59 59 PUBLIC domain_cfg ! called by nemogcm.F90 60 PUBLIC dom_tile ! called by step.F9061 60 62 61 !! * Substitutions … … 301 300 302 301 303 SUBROUTINE dom_tile( ktsi, ktsj, ktei, ktej, ktile )304 !!----------------------------------------------------------------------305 !! *** ROUTINE dom_tile ***306 !!307 !! ** Purpose : Set tile domain variables308 !!309 !! ** Action : - ktsi, ktsj : start of internal part of domain310 !! - ktei, ktej : end of internal part of domain311 !! - ntile : current tile number312 !! - nijtile : total number of tiles313 !!----------------------------------------------------------------------314 INTEGER, INTENT(out) :: ktsi, ktsj, ktei, ktej ! Tile domain indices315 INTEGER, INTENT(in), OPTIONAL :: ktile ! Tile number316 INTEGER :: jt ! dummy loop argument317 INTEGER :: iitile, ijtile ! Local integers318 CHARACTER (len=11) :: charout319 !!----------------------------------------------------------------------320 IF( PRESENT(ktile) .AND. ln_tile ) THEN321 ntile = ktile ! Set domain indices for tile322 ktsi = ntsi_a(ktile)323 ktsj = ntsj_a(ktile)324 ktei = ntei_a(ktile)325 ktej = ntej_a(ktile)326 327 IF(sn_cfctl%l_prtctl) THEN328 WRITE(charout, FMT="('ntile =', I4)") ktile329 CALL prt_ctl_info( charout )330 ENDIF331 ELSE332 ntile = 0 ! Initialise to full domain333 nijtile = 1334 ktsi = Nis0335 ktsj = Njs0336 ktei = Nie0337 ktej = Nje0338 339 IF( ln_tile ) THEN ! Calculate tile domain indices340 iitile = Ni_0 / nn_ltile_i ! Number of tiles341 ijtile = Nj_0 / nn_ltile_j342 IF( MOD( Ni_0, nn_ltile_i ) /= 0 ) iitile = iitile + 1343 IF( MOD( Nj_0, nn_ltile_j ) /= 0 ) ijtile = ijtile + 1344 345 nijtile = iitile * ijtile346 ALLOCATE( ntsi_a(0:nijtile), ntsj_a(0:nijtile), ntei_a(0:nijtile), ntej_a(0:nijtile) )347 348 ntsi_a(0) = ktsi ! Full domain349 ntsj_a(0) = ktsj350 ntei_a(0) = ktei351 ntej_a(0) = ktej352 353 DO jt = 1, nijtile ! Tile domains354 ntsi_a(jt) = Nis0 + nn_ltile_i * MOD(jt - 1, iitile)355 ntsj_a(jt) = Njs0 + nn_ltile_j * ((jt - 1) / iitile)356 ntei_a(jt) = MIN(ntsi_a(jt) + nn_ltile_i - 1, Nie0)357 ntej_a(jt) = MIN(ntsj_a(jt) + nn_ltile_j - 1, Nje0)358 ENDDO359 ENDIF360 361 IF(lwp) THEN ! control print362 WRITE(numout,*)363 WRITE(numout,*) 'dom_tile : Domain tiling decomposition'364 WRITE(numout,*) '~~~~~~~~'365 IF( ln_tile ) THEN366 WRITE(numout,*) iitile, 'tiles in i'367 WRITE(numout,*) ' Starting indices'368 WRITE(numout,*) ' ', (ntsi_a(jt), jt=1, iitile)369 WRITE(numout,*) ' Ending indices'370 WRITE(numout,*) ' ', (ntei_a(jt), jt=1, iitile)371 WRITE(numout,*) ijtile, 'tiles in j'372 WRITE(numout,*) ' Starting indices'373 WRITE(numout,*) ' ', (ntsj_a(jt), jt=1, nijtile, iitile)374 WRITE(numout,*) ' Ending indices'375 WRITE(numout,*) ' ', (ntej_a(jt), jt=1, nijtile, iitile)376 ELSE377 WRITE(numout,*) 'No domain tiling'378 WRITE(numout,*) ' i indices =', ktsi, ':', ktei379 WRITE(numout,*) ' j indices =', ktsj, ':', ktej380 ENDIF381 ENDIF382 ENDIF383 END SUBROUTINE dom_tile384 385 386 302 SUBROUTINE dom_nam 387 303 !!---------------------------------------------------------------------- -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/DOM/domvvl.F90
r14085 r14098 2 2 !!====================================================================== 3 3 !! *** MODULE domvvl *** 4 !! Ocean : 4 !! Ocean : 5 5 !!====================================================================== 6 6 !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code … … 26 26 USE timing ! Timing 27 27 28 #if defined key_agrif 29 USE agrif_oce ! initial state interpolation 30 USE agrif_oce_interp 31 #endif 32 28 33 IMPLICIT NONE 29 34 PRIVATE … … 58 63 !! Default key Old management of time varying vertical coordinate 59 64 !!---------------------------------------------------------------------- 60 65 61 66 !!---------------------------------------------------------------------- 62 67 !! dom_vvl_init : define initial vertical scale factors, depths and column thickness … … 73 78 PUBLIC dom_vvl_sf_update ! called by step.F90 74 79 PUBLIC dom_vvl_interpol ! called by dynnxt.F90 75 80 76 81 !! * Substitutions 77 82 # include "do_loop_substitute.h90" … … 109 114 !!---------------------------------------------------------------------- 110 115 !! *** ROUTINE dom_vvl_init *** 111 !! 116 !! 112 117 !! ** Purpose : Initialization of all scale factors, depths 113 118 !! and water column heights … … 118 123 !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) 119 124 !! - Regrid: e3[u/v](:,:,:,Kmm) 120 !! e3[u/v](:,:,:,Kmm) 121 !! e3w(:,:,:,Kmm) 125 !! e3[u/v](:,:,:,Kmm) 126 !! e3w(:,:,:,Kmm) 122 127 !! e3[u/v]w_b 123 !! e3[u/v]w_n 128 !! e3[u/v]w_n 124 129 !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 125 130 !! - h(t/u/v)_0 … … 151 156 !!---------------------------------------------------------------------- 152 157 !! *** ROUTINE dom_vvl_init *** 153 !! 154 !! ** Purpose : Interpolation of all scale factors, 158 !! 159 !! ** Purpose : Interpolation of all scale factors, 155 160 !! depths and water column heights 156 161 !! … … 159 164 !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) 160 165 !! - Regrid: e3(u/v)_n 161 !! e3(u/v)_b 162 !! e3w_n 163 !! e3(u/v)w_b 164 !! e3(u/v)w_n 166 !! e3(u/v)_b 167 !! e3w_n 168 !! e3(u/v)w_b 169 !! e3(u/v)w_n 165 170 !! gdept_n, gdepw_n and gde3w_n 166 171 !! - h(t/u/v)_0 … … 180 185 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U 181 186 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 182 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V 187 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V 183 188 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 184 189 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) ! from U to F 185 ! ! Vertical interpolation of e3t,u,v 190 ! ! Vertical interpolation of e3t,u,v 186 191 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W 187 192 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w (:,:,:,Kbb), 'W' ) … … 205 210 ! zcoef = tmask - wmask ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt 206 211 ! ! 1 everywhere from mbkt to mikt + 1 or 1 (if no isf) 207 ! ! 0.5 where jk = mikt 212 ! ! 0.5 where jk = mikt 208 213 !!gm ??????? BUG ? gdept(:,:,:,Kmm) as well as gde3w does not include the thickness of ISF ?? 209 214 zcoef = ( tmask(ji,jj,jk) - wmask(ji,jj,jk) ) 210 215 gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 211 216 gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm)) & 212 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm)) 217 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm)) 213 218 gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 214 219 gdepw(ji,jj,jk,Kbb) = gdepw(ji,jj,jk-1,Kbb) + e3t(ji,jj,jk-1,Kbb) 215 220 gdept(ji,jj,jk,Kbb) = zcoef * ( gdepw(ji,jj,jk ,Kbb) + 0.5 * e3w(ji,jj,jk,Kbb)) & 216 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) + e3w(ji,jj,jk,Kbb)) 221 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kbb) + e3w(ji,jj,jk,Kbb)) 217 222 END_3D 218 223 ! … … 273 278 IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN 274 279 IF( nn_cfg == 3 ) THEN ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 275 ii0 = 103 + nn_hls - 1 ; ii1 = 111 + nn_hls - 1 280 ii0 = 103 + nn_hls - 1 ; ii1 = 111 + nn_hls - 1 276 281 ij0 = 128 + nn_hls ; ij1 = 135 + nn_hls 277 282 frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.0_wp … … 285 290 286 291 287 SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) 292 SUBROUTINE dom_vvl_sf_nxt( kt, Kbb, Kmm, Kaa, kcall ) 288 293 !!---------------------------------------------------------------------- 289 294 !! *** ROUTINE dom_vvl_sf_nxt *** 290 !! 295 !! 291 296 !! ** Purpose : - compute the after scale factors used in tra_zdf, dynnxt, 292 297 !! tranxt and dynspg routines 293 298 !! 294 299 !! ** Method : - z_star case: Repartition of ssh INCREMENT proportionnaly to the level thickness. 295 !! - z_tilde_case: after scale factor increment = 300 !! - z_tilde_case: after scale factor increment = 296 301 !! high frequency part of horizontal divergence 297 302 !! + retsoring towards the background grid … … 301 306 !! 302 307 !! ** Action : - hdiv_lf : restoring towards full baroclinic divergence in z_tilde case 303 !! - tilde_e3t_a: after increment of vertical scale factor 308 !! - tilde_e3t_a: after increment of vertical scale factor 304 309 !! in z_tilde case 305 310 !! - e3(t/u/v)_a … … 405 410 un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj) & 406 411 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj ,jk) ) 407 vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj) & 412 vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj) & 408 413 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji ,jj+1,jk) ) 409 414 zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) … … 450 455 WRITE(numout, *) 'at i, j, k=', ijk_max 451 456 WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin 452 WRITE(numout, *) 'at i, j, k=', ijk_min 457 WRITE(numout, *) 'at i, j, k=', ijk_min 453 458 CALL ctl_stop( 'STOP', 'MAX( ABS( tilde_e3t_a(:,:,: ) ) / e3t_0(:,:,:) ) too high') 454 459 ENDIF … … 566 571 !!---------------------------------------------------------------------- 567 572 !! *** ROUTINE dom_vvl_sf_update *** 568 !! 569 !! ** Purpose : for z tilde case: compute time filter and swap of scale factors 573 !! 574 !! ** Purpose : for z tilde case: compute time filter and swap of scale factors 570 575 !! compute all depths and related variables for next time step 571 576 !! write outputs and restart file … … 577 582 !! ** Action : - tilde_e3t_(b/n) ready for next time step 578 583 !! - Recompute: 579 !! e3(u/v)_b 580 !! e3w(:,:,:,Kmm) 581 !! e3(u/v)w_b 582 !! e3(u/v)w_n 584 !! e3(u/v)_b 585 !! e3w(:,:,:,Kmm) 586 !! e3(u/v)w_b 587 !! e3(u/v)w_n 583 588 !! gdept(:,:,:,Kmm), gdepw(:,:,:,Kmm) and gde3w 584 589 !! h(u/v) and h(u/v)r … … 611 616 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 612 617 ELSE 613 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 618 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 614 619 & + rn_atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) 615 620 ENDIF … … 623 628 ! - ML - e3u(:,:,:,Kbb) and e3v(:,:,:,Kbb) are already computed in dynnxt 624 629 ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also 625 630 626 631 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) 627 632 628 633 ! Vertical scale factor interpolations 629 634 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w(:,:,:,Kmm), 'W' ) … … 644 649 gdepw(ji,jj,jk,Kmm) = gdepw(ji,jj,jk-1,Kmm) + e3t(ji,jj,jk-1,Kmm) 645 650 gdept(ji,jj,jk,Kmm) = zcoef * ( gdepw(ji,jj,jk ,Kmm) + 0.5 * e3w(ji,jj,jk,Kmm) ) & 646 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm) ) 651 & + (1-zcoef) * ( gdept(ji,jj,jk-1,Kmm) + e3w(ji,jj,jk,Kmm) ) 647 652 gde3w(ji,jj,jk) = gdept(ji,jj,jk,Kmm) - ssh(ji,jj,Kmm) 648 653 END_3D … … 763 768 !!--------------------------------------------------------------------- 764 769 !! *** ROUTINE dom_vvl_rst *** 765 !! 770 !! 766 771 !! ** Purpose : Read or write VVL file in restart file 767 772 !! … … 795 800 IF( ln_rstart ) THEN !== Read the restart file ==! 796 801 ! 802 #if defined key_agrif 803 IF ( (.NOT.Agrif_root()).AND.(ln_init_chfrpar) ) THEN 804 ! skip reading restart if initialized from parent: 805 id3 = -1 ; id4 = -1 ; id5 = -1 806 ELSE 807 #endif 797 808 CALL rst_read_open !* open the restart file if necessary 798 809 ! ! --------- ! … … 804 815 id5 = iom_varid( numror, 'hdiv_lf' , ldstop = .FALSE. ) 805 816 ! 817 #if defined key_agrif 818 ENDIF 819 #endif 806 820 ! !* scale factors 807 821 IF(lwp) WRITE(numout,*) ' Kmm scale factor read in the restart file' 808 822 CALL iom_get( numror, jpdom_auto, 'e3t_n', e3t(:,:,:,Kmm) ) 809 WHERE ( tmask(:,:,:) == 0.0_wp ) 823 WHERE ( tmask(:,:,:) == 0.0_wp ) 810 824 e3t(:,:,:,Kmm) = e3t_0(:,:,:) 811 825 END WHERE … … 816 830 IF(lwp) WRITE(numout,*) ' Kbb scale factor read in the restart file' 817 831 CALL iom_get( numror, jpdom_auto, 'e3t_b', e3t(:,:,:,Kbb) ) 818 WHERE ( tmask(:,:,:) == 0.0_wp ) 832 WHERE ( tmask(:,:,:) == 0.0_wp ) 819 833 e3t(:,:,:,Kbb) = e3t_0(:,:,:) 820 834 END WHERE … … 840 854 CALL iom_get( numror, jpdom_auto, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 841 855 ENDIF 842 ELSE 843 844 856 ELSE 857 tilde_e3t_b(:,:,:) = 0.0_wp 858 tilde_e3t_n(:,:,:) = 0.0_wp 845 859 ENDIF 846 860 ! ! ------------ ! … … 850 864 CALL iom_get( numror, jpdom_auto, 'hdiv_lf', hdiv_lf(:,:,:) ) 851 865 ELSE ! array is missing 852 hdiv_lf(:,:,:) = 0.0_wp 866 hdiv_lf(:,:,:) = 0.0_wp 853 867 ENDIF 854 868 ENDIF … … 871 885 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file ! 872 886 ! !=======================! 887 #if defined key_agrif 888 IF ( .NOT.Agrif_root().AND.(ln_init_chfrpar) ) THEN 889 ! Interpolate initial ssh from parent: 890 CALL Agrif_istate_ssh( Kbb, Kmm ) 891 ! 892 DO jk = 1, jpk 893 e3t(:,:,jk,Kmm) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kmm) ) & 894 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 895 & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 896 END DO 897 e3t(:,:,:,Kbb) = e3t(:,:,:,Kmm) 898 ENDIF 899 #endif 873 900 ! 874 901 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' … … 884 911 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:)) 885 912 END IF 886 ! ! -------------! 913 ! ! -------------! 887 914 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 888 915 ! ! ------------ ! … … 898 925 !!--------------------------------------------------------------------- 899 926 !! *** ROUTINE dom_vvl_ctl *** 900 !! 927 !! 901 928 !! ** Purpose : Control the consistency between namelist options 902 929 !! for vertical coordinate … … 907 934 & ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , & 908 935 & rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg ! not yet implemented: ln_vvl_kepe 909 !!---------------------------------------------------------------------- 936 !!---------------------------------------------------------------------- 910 937 ! 911 938 READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/DOM/dtatsd.F90
r14085 r14098 18 18 USE phycst ! physical constants 19 19 USE dom_oce ! ocean space and time domain 20 USE dom ain, ONLY : dom_tile20 USE domtile 21 21 USE fldread ! read input fields 22 22 ! -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/DOM/istate.F90
r14066 r14098 34 34 USE lib_mpp ! MPP library 35 35 USE restart ! restart 36 36 37 #if defined key_agrif 38 USE agrif_oce ! initial state interpolation 37 39 USE agrif_oce_interp 38 USE agrif_oce39 40 #endif 40 41 … … 93 94 ln_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward) 94 95 CALL day_init 95 CALL agrif_istate ( Kbb, Kmm, Kaa ) ! Interp from parent96 CALL agrif_istate_oce( Kbb, Kmm, Kaa ) ! Interp from parent 96 97 ! 97 98 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) … … 104 105 ELSE 105 106 #endif 106 IF( ln_rstart ) THEN ! Restart from a file 107 ! ! ------------------- 108 CALL rst_read( Kbb, Kmm ) ! Read the restart file 109 CALL day_init ! model calendar (using both namelist and restart infos) 110 ! 111 ELSE ! Start from rest 112 ! ! --------------- 113 numror = 0 ! define numror = 0 -> no restart file to read 114 l_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward) 115 CALL day_init ! model calendar (using both namelist and restart infos) 116 ! ! Initialization of ocean to zero 117 ! 118 IF( ln_tsd_init ) THEN 119 CALL dta_tsd( nit000, ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000 107 IF( ln_rstart ) THEN ! Restart from a file 108 ! ! ------------------- 109 CALL rst_read( Kbb, Kmm ) ! Read the restart file 110 CALL day_init ! model calendar (using both namelist and restart infos) 120 111 ! 121 uu (:,:,:,Kbb) = 0._wp 122 vv (:,:,:,Kbb) = 0._wp 123 ! 124 ELSE ! user defined initial T and S 125 DO jk = 1, jpk 126 zgdept(:,:,jk) = gdept(:,:,jk,Kbb) 127 END DO 128 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) 129 ENDIF 130 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 131 uu (:,:,: ,Kmm) = uu (:,:,: ,Kbb) 132 vv (:,:,: ,Kmm) = vv (:,:,: ,Kbb) 112 ELSE ! Start from rest 113 ! ! --------------- 114 numror = 0 ! define numror = 0 -> no restart file to read 115 l_1st_euler = .true. ! Set time-step indicator at nit000 (euler forward) 116 CALL day_init ! model calendar (using both namelist and restart infos) 117 ! ! Initialization of ocean to zero 118 IF( ln_tsd_init ) THEN 119 CALL dta_tsd( nit000, ts(:,:,:,:,Kbb) ) ! read 3D T and S data at nit000 120 ! 121 ssh(:,:,Kbb) = 0._wp ! set the ocean at rest 122 uu (:,:,:,Kbb) = 0._wp 123 vv (:,:,:,Kbb) = 0._wp 124 ! 125 IF( ll_wd ) THEN 126 ssh(:,:,Kbb) = -ssh_ref ! Added in 30 here for bathy that adds 30 as Iterative test CEOD 127 ! 128 ! Apply minimum wetdepth criterion 129 ! 130 DO_2D( 1, 1, 1, 1 ) 131 IF( ht_0(ji,jj) + ssh(ji,jj,Kbb) < rn_wdmin1 ) THEN 132 ssh(ji,jj,Kbb) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) ) 133 ENDIF 134 END_2D 135 ENDIF 136 ! 137 ELSE ! user defined initial T and S 138 DO jk = 1, jpk 139 zgdept(:,:,jk) = gdept(:,:,jk,Kbb) 140 END DO 141 CALL usr_def_istate( zgdept, tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb) ) 142 ENDIF 143 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 144 ssh (:,:,Kmm) = ssh(:,:,Kbb) 145 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) 146 vv (:,:,:,Kmm) = vv (:,:,:,Kbb) 133 147 134 148 ! … … 143 157 ! 144 158 ! 145 ENDIF159 ENDIF 146 160 #if defined key_agrif 147 161 ENDIF -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/TRA/traadv.F90
r14085 r14098 19 19 USE dom_oce ! ocean space and time domain 20 20 ! TEMP: [tiling] This change not necessary after extended haloes development 21 USE dom ain, ONLY : dom_tile21 USE domtile 22 22 USE domvvl ! variable vertical scale factors 23 23 USE sbcwave ! wave module -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/TRA/traldf.F90
r14085 r14098 18 18 USE dom_oce ! ocean space and time domain 19 19 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed from tra_ldf_blp, zps_hde*) 20 USE dom ain, ONLY : dom_tile20 USE domtile 21 21 USE phycst ! physical constants 22 22 USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/TRA/traldf_triad.F90
r14085 r14098 14 14 USE dom_oce ! ocean space and time domain 15 15 ! TEMP: [tiling] This change not necessary if XIOS has subdomain support 16 USE dom ain, ONLY : dom_tile16 USE domtile 17 17 USE domutl, ONLY : is_tile 18 18 USE phycst ! physical constants -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/TRA/tranpc.F90
r14085 r14098 18 18 USE dom_oce ! ocean space and time domain 19 19 ! TEMP: [tiling] This change not necessary after extra haloes development (lbc_lnk removed) 20 USE dom ain, ONLY : dom_tile20 USE domtile 21 21 USE phycst ! physical constants 22 22 USE zdf_oce ! ocean vertical physics -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/TRA/traqsr.F90
r14085 r14098 22 22 USE phycst ! physical constants 23 23 USE dom_oce ! ocean space and time domain 24 USE dom ain, ONLY : dom_tile24 USE domtile 25 25 USE sbc_oce ! surface boundary condition: ocean 26 26 USE trc_oce ! share SMS/Ocean variables -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/TRD/trdini.F90
r14085 r14098 11 11 !!---------------------------------------------------------------------- 12 12 USE dom_oce ! ocean domain 13 USE dom ain, ONLY : dom_tile13 USE domtile 14 14 USE trd_oce ! trends: ocean variables 15 15 USE trdken ! trends: 3D kinetic energy -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/nemogcm.F90
r14085 r14098 51 51 USE istate ! initial state setting (istate_init routine) 52 52 USE trdini ! dyn/tra trends initialization (trd_init routine) 53 USE asminc ! assimilation increments 54 USE asmbkg ! writing out state trajectory 55 USE diadct ! sections transports (dia_dct_init routine) 56 USE diaobs ! Observation diagnostics (dia_obs_init routine) 57 USE diacfl ! CFL diagnostics (dia_cfl_init routine) 58 USE diamlr ! IOM context management for multiple-linear-regression analysis 59 #if defined key_qco 60 USE stepMLF ! NEMO time-stepping (stp_MLF routine) 61 #else 62 USE step ! NEMO time-stepping (stp routine) 63 #endif 64 USE isfstp ! ice shelf (isf_stp_init routine) 53 65 USE icbini ! handle bergs, initialisation 54 66 USE icbstp , ONLY : icb_end ! handle bergs, close iceberg files … … 76 88 USE lbcnfd , ONLY : isendto, nsndto ! Setup of north fold exchanges 77 89 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 78 USE halo_mng ! Halo manager 90 #if defined key_iomput 91 USE xios ! xIOserver 92 #endif 93 #if defined key_agrif 94 USE agrif_all_update ! Master Agrif update 95 USE agrif_oce_update 96 #endif 97 USE halo_mng 79 98 80 99 IMPLICIT NONE … … 158 177 Kbb_a = Nbb; Kmm_a = Nnn; Krhs_a = Nrhs ! agrif_oce module copies of time level indices 159 178 CALL Agrif_step_child_adj(Agrif_Update_All) 179 CALL Agrif_step_child_adj(Agrif_Check_parent_bat) 160 180 ! 161 181 DO WHILE( istp <= nitend .AND. nstop == 0 ) -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/OCE/step_oce.F90
r14085 r14098 6 6 !!====================================================================== 7 7 !! History : 3.3 ! 2010-08 (C. Ethe) Original code - reorganisation of the initial phase 8 !! 3.7 ! 2014-01 (G. Madec) LDF simplication 8 !! 3.7 ! 2014-01 (G. Madec) LDF simplication 9 9 !!---------------------------------------------------------------------- 10 10 USE oce ! ocean dynamics and tracers variables 11 11 USE dom_oce ! ocean space and time domain variables 12 USE dom ain , ONLY : dom_tile12 USE domtile 13 13 14 14 USE daymod ! calendar (day routine) … … 35 35 USE domvvl ! variable vertical scale factors (dom_vvl_sf_nxt routine) 36 36 ! (dom_vvl_sf_swp routine) 37 37 38 38 USE divhor ! horizontal divergence (div_hor routine) 39 39 USE dynadv ! advection (dyn_adv routine) … … 60 60 61 61 USE stopar ! Stochastic parametrization (sto_par routine) 62 USE stopts 62 USE stopts 63 63 64 64 USE ldfslp ! iso-neutral slopes (ldf_slp routine) … … 73 73 74 74 USE diu_layers ! diurnal SST bulk and coolskin routines 75 USE sbc_oce ! surface fluxes 76 75 USE sbc_oce ! surface fluxes 76 77 77 USE zpshde ! partial step: hor. derivative (zps_hde routine) 78 78 -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/P4Z/p4zche.F90
r13295 r14098 188 188 ! CHEMICAL CONSTANTS - SURFACE LAYER 189 189 ! ---------------------------------- 190 !CDIR NOVERRCHK 191 DO jj = 1, jpj 192 !CDIR NOVERRCHK 193 DO ji = 1, jpi 194 ! ! SET ABSOLUTE TEMPERATURE 195 ztkel = tempis(ji,jj,1) + 273.15 196 zt = ztkel * 0.01 197 zsal = salinprac(ji,jj,1) + ( 1.- tmask(ji,jj,1) ) * 35. 198 ! ! LN(K0) OF SOLUBILITY OF CO2 (EQ. 12, WEISS, 1980) 199 ! ! AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 200 zcek1 = 9345.17/ztkel - 60.2409 + 23.3585 * LOG(zt) + zsal*(0.023517 - 0.00023656*ztkel & 201 & + 0.0047036e-4*ztkel**2) 202 chemc(ji,jj,1) = EXP( zcek1 ) * 1E-6 * rhop(ji,jj,1) / 1000. ! mol/(L atm) 203 chemc(ji,jj,2) = -1636.75 + 12.0408*ztkel - 0.0327957*ztkel**2 + 0.0000316528*ztkel**3 204 chemc(ji,jj,3) = 57.7 - 0.118*ztkel 205 ! 206 END DO 207 END DO 190 DO_2D( 1, 1, 1, 1 ) 191 ! ! SET ABSOLUTE TEMPERATURE 192 ztkel = tempis(ji,jj,1) + 273.15 193 zt = ztkel * 0.01 194 zsal = salinprac(ji,jj,1) + ( 1.- tmask(ji,jj,1) ) * 35. 195 ! ! LN(K0) OF SOLUBILITY OF CO2 (EQ. 12, WEISS, 1980) 196 ! ! AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 197 zcek1 = 9345.17/ztkel - 60.2409 + 23.3585 * LOG(zt) + zsal*(0.023517 - 0.00023656*ztkel & 198 & + 0.0047036e-4*ztkel**2) 199 chemc(ji,jj,1) = EXP( zcek1 ) * 1E-6 * rhop(ji,jj,1) / 1000. ! mol/(L atm) 200 chemc(ji,jj,2) = -1636.75 + 12.0408*ztkel - 0.0327957*ztkel**2 + 0.0000316528*ztkel**3 201 chemc(ji,jj,3) = 57.7 - 0.118*ztkel 202 END_2D 208 203 209 204 ! OXYGEN SOLUBILITY - DEEP OCEAN 210 205 ! ------------------------------- 211 !CDIR NOVERRCHK 212 DO jk = 1, jpk 213 !CDIR NOVERRCHK 214 DO jj = 1, jpj 215 !CDIR NOVERRCHK 216 DO ji = 1, jpi 217 ztkel = tempis(ji,jj,jk) + 273.15 218 zsal = salinprac(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 35. 219 zsal2 = zsal * zsal 220 ztgg = LOG( ( 298.15 - tempis(ji,jj,jk) ) / ztkel ) ! Set the GORDON & GARCIA scaled temperature 221 ztgg2 = ztgg * ztgg 222 ztgg3 = ztgg2 * ztgg 223 ztgg4 = ztgg3 * ztgg 224 ztgg5 = ztgg4 * ztgg 225 226 zoxy = 2.00856 + 3.22400 * ztgg + 3.99063 * ztgg2 + 4.80299 * ztgg3 & 227 & + 9.78188e-1 * ztgg4 + 1.71069 * ztgg5 + zsal * ( -6.24097e-3 & 228 & - 6.93498e-3 * ztgg - 6.90358e-3 * ztgg2 - 4.29155e-3 * ztgg3 ) & 229 & - 3.11680e-7 * zsal2 230 chemo2(ji,jj,jk) = ( EXP( zoxy ) * o2atm ) * oxyco * atcox ! mol/(L atm) 231 END DO 232 END DO 233 END DO 206 DO_3D( 1, 1, 1, 1, 1, jpk ) 207 ztkel = tempis(ji,jj,jk) + 273.15 208 zsal = salinprac(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 35. 209 zsal2 = zsal * zsal 210 ztgg = LOG( ( 298.15 - tempis(ji,jj,jk) ) / ztkel ) ! Set the GORDON & GARCIA scaled temperature 211 ztgg2 = ztgg * ztgg 212 ztgg3 = ztgg2 * ztgg 213 ztgg4 = ztgg3 * ztgg 214 ztgg5 = ztgg4 * ztgg 215 216 zoxy = 2.00856 + 3.22400 * ztgg + 3.99063 * ztgg2 + 4.80299 * ztgg3 & 217 & + 9.78188e-1 * ztgg4 + 1.71069 * ztgg5 + zsal * ( -6.24097e-3 & 218 & - 6.93498e-3 * ztgg - 6.90358e-3 * ztgg2 - 4.29155e-3 * ztgg3 ) & 219 & - 3.11680e-7 * zsal2 220 chemo2(ji,jj,jk) = ( EXP( zoxy ) * o2atm ) * oxyco * atcox ! mol/(L atm) 221 END_3D 234 222 235 223 ! CHEMICAL CONSTANTS - DEEP OCEAN 236 224 ! ------------------------------- 237 !CDIR NOVERRCHK 238 DO jk = 1, jpk 239 !CDIR NOVERRCHK 240 DO jj = 1, jpj 241 !CDIR NOVERRCHK 242 DO ji = 1, jpi 243 244 ! SET PRESSION ACCORDING TO SAUNDER (1980) 245 zplat = SIN ( ABS(gphit(ji,jj)*3.141592654/180.) ) 246 zc1 = 5.92E-3 + zplat**2 * 5.25E-3 247 zpres = ((1-zc1)-SQRT(((1-zc1)**2)-(8.84E-6*gdept(ji,jj,jk,Kmm)))) / 4.42E-6 248 zpres = zpres / 10.0 249 250 ! SET ABSOLUTE TEMPERATURE 251 ztkel = tempis(ji,jj,jk) + 273.15 252 zsal = salinprac(ji,jj,jk) + ( 1.-tmask(ji,jj,jk) ) * 35. 253 zsqrt = SQRT( zsal ) 254 zsal15 = zsqrt * zsal 255 zlogt = LOG( ztkel ) 256 ztr = 1. / ztkel 257 zis = 19.924 * zsal / ( 1000.- 1.005 * zsal ) 258 zis2 = zis * zis 259 zisqrt = SQRT( zis ) 260 ztc = tempis(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 20. 261 262 ! CHLORINITY (WOOSTER ET AL., 1969) 263 zcl = zsal / 1.80655 264 265 ! TOTAL SULFATE CONCENTR. [MOLES/kg soln] 266 zst = 0.14 * zcl /96.062 267 268 ! TOTAL FLUORIDE CONCENTR. [MOLES/kg soln] 269 zft = 0.000067 * zcl /18.9984 270 271 ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) 272 zcks = EXP(-4276.1 * ztr + 141.328 - 23.093 * zlogt & 273 & + (-13856. * ztr + 324.57 - 47.986 * zlogt) * zisqrt & 274 & + (35474. * ztr - 771.54 + 114.723 * zlogt) * zis & 275 & - 2698. * ztr * zis**1.5 + 1776.* ztr * zis2 & 276 & + LOG(1.0 - 0.001005 * zsal)) 277 278 ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) 279 zckf = EXP( 1590.2*ztr - 12.641 + 1.525*zisqrt & 280 & + LOG(1.0d0 - 0.001005d0*zsal) & 281 & + LOG(1.0d0 + zst/zcks)) 282 283 ! DISSOCIATION CONSTANT FOR CARBONATE AND BORATE 284 zckb= (-8966.90 - 2890.53*zsqrt - 77.942*zsal & 285 & + 1.728*zsal15 - 0.0996*zsal*zsal)*ztr & 286 & + (148.0248 + 137.1942*zsqrt + 1.62142*zsal) & 287 & + (-24.4344 - 25.085*zsqrt - 0.2474*zsal) & 288 & * zlogt + 0.053105*zsqrt*ztkel 289 290 ! DISSOCIATION COEFFICIENT FOR CARBONATE ACCORDING TO 291 ! MEHRBACH (1973) REFIT BY MILLERO (1995), seawater scale 292 zck1 = -1.0*(3633.86*ztr - 61.2172 + 9.6777*zlogt & 293 - 0.011555*zsal + 0.0001152*zsal*zsal) 294 zck2 = -1.0*(471.78*ztr + 25.9290 - 3.16967*zlogt & 295 - 0.01781*zsal + 0.0001122*zsal*zsal) 296 297 ! PKW (H2O) (MILLERO, 1995) from composite data 298 zckw = -13847.26 * ztr + 148.9652 - 23.6521 * zlogt + ( 118.67 * ztr & 299 - 5.977 + 1.0495 * zlogt ) * zsqrt - 0.01615 * zsal 300 301 ! CONSTANTS FOR PHOSPHATE (MILLERO, 1995) 302 zck1p = -4576.752*ztr + 115.540 - 18.453*zlogt & 303 & + (-106.736*ztr + 0.69171) * zsqrt & 304 & + (-0.65643*ztr - 0.01844) * zsal 305 306 zck2p = -8814.715*ztr + 172.1033 - 27.927*zlogt & 307 & + (-160.340*ztr + 1.3566)*zsqrt & 308 & + (0.37335*ztr - 0.05778)*zsal 309 310 zck3p = -3070.75*ztr - 18.126 & 311 & + (17.27039*ztr + 2.81197) * zsqrt & 312 & + (-44.99486*ztr - 0.09984) * zsal 313 314 ! CONSTANT FOR SILICATE, MILLERO (1995) 315 zcksi = -8904.2*ztr + 117.400 - 19.334*zlogt & 316 & + (-458.79*ztr + 3.5913) * zisqrt & 317 & + (188.74*ztr - 1.5998) * zis & 318 & + (-12.1652*ztr + 0.07871) * zis2 & 319 & + LOG(1.0 - 0.001005*zsal) 320 321 ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER 322 ! (S=27-43, T=2-25 DEG C) at pres =0 (atmos. pressure) (MUCCI 1983) 323 zaksp0 = -171.9065 -0.077993*ztkel + 2839.319*ztr + 71.595*LOG10( ztkel ) & 324 & + (-0.77712 + 0.00284263*ztkel + 178.34*ztr) * zsqrt & 325 & - 0.07711*zsal + 0.0041249*zsal15 326 327 ! CONVERT FROM DIFFERENT PH SCALES 328 total2free = 1.0/(1.0 + zst/zcks) 329 free2SWS = 1. + zst/zcks + zft/(zckf*total2free) 330 total2SWS = total2free * free2SWS 331 SWS2total = 1.0 / total2SWS 332 333 ! K1, K2 OF CARBONIC ACID, KB OF BORIC ACID, KW (H2O) (LIT.?) 334 zak1 = 10**(zck1) * total2SWS 335 zak2 = 10**(zck2) * total2SWS 336 zakb = EXP( zckb ) * total2SWS 337 zakw = EXP( zckw ) 338 zaksp1 = 10**(zaksp0) 339 zak1p = exp( zck1p ) 340 zak2p = exp( zck2p ) 341 zak3p = exp( zck3p ) 342 zaksi = exp( zcksi ) 343 zckf = zckf * total2SWS 344 345 ! FORMULA FOR CPEXP AFTER EDMOND & GIESKES (1970) 346 ! (REFERENCE TO CULBERSON & PYTKOQICZ (1968) AS MADE 347 ! IN BROECKER ET AL. (1982) IS INCORRECT; HERE RGAS IS 348 ! TAKEN TENFOLD TO CORRECT FOR THE NOTATION OF pres IN 349 ! DBAR INSTEAD OF BAR AND THE EXPRESSION FOR CPEXP IS 350 ! MULTIPLIED BY LN(10.) TO ALLOW USE OF EXP-FUNCTION 351 ! WITH BASIS E IN THE FORMULA FOR AKSPP (CF. EDMOND 352 ! & GIESKES (1970), P. 1285-1286 (THE SMALL 353 ! FORMULA ON P. 1286 IS RIGHT AND CONSISTENT WITH THE 354 ! SIGN IN PARTIAL MOLAR VOLUME CHANGE AS SHOWN ON P. 1285)) 355 zcpexp = zpres / (rgas*ztkel) 356 zcpexp2 = zpres * zcpexp 357 358 ! KB OF BORIC ACID, K1,K2 OF CARBONIC ACID PRESSURE 359 ! CORRECTION AFTER CULBERSON AND PYTKOWICZ (1968) 360 ! (CF. BROECKER ET AL., 1982) 361 362 zbuf1 = - ( devk10 + devk20 * ztc + devk30 * ztc * ztc ) 363 zbuf2 = 0.5 * ( devk40 + devk50 * ztc ) 364 ak13(ji,jj,jk) = zak1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 365 366 zbuf1 = - ( devk11 + devk21 * ztc + devk31 * ztc * ztc ) 367 zbuf2 = 0.5 * ( devk41 + devk51 * ztc ) 368 ak23(ji,jj,jk) = zak2 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 369 370 zbuf1 = - ( devk12 + devk22 * ztc + devk32 * ztc * ztc ) 371 zbuf2 = 0.5 * ( devk42 + devk52 * ztc ) 372 akb3(ji,jj,jk) = zakb * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 373 374 zbuf1 = - ( devk13 + devk23 * ztc + devk33 * ztc * ztc ) 375 zbuf2 = 0.5 * ( devk43 + devk53 * ztc ) 376 akw3(ji,jj,jk) = zakw * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 377 378 zbuf1 = - ( devk14 + devk24 * ztc + devk34 * ztc * ztc ) 379 zbuf2 = 0.5 * ( devk44 + devk54 * ztc ) 380 aks3(ji,jj,jk) = zcks * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 381 382 zbuf1 = - ( devk15 + devk25 * ztc + devk35 * ztc * ztc ) 383 zbuf2 = 0.5 * ( devk45 + devk55 * ztc ) 384 akf3(ji,jj,jk) = zckf * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 385 386 zbuf1 = - ( devk17 + devk27 * ztc + devk37 * ztc * ztc ) 387 zbuf2 = 0.5 * ( devk47 + devk57 * ztc ) 388 ak1p3(ji,jj,jk) = zak1p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 389 390 zbuf1 = - ( devk18 + devk28 * ztc + devk38 * ztc * ztc ) 391 zbuf2 = 0.5 * ( devk48 + devk58 * ztc ) 392 ak2p3(ji,jj,jk) = zak2p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 393 394 zbuf1 = - ( devk19 + devk29 * ztc + devk39 * ztc * ztc ) 395 zbuf2 = 0.5 * ( devk49 + devk59 * ztc ) 396 ak3p3(ji,jj,jk) = zak3p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 397 398 zbuf1 = - ( devk110 + devk210 * ztc + devk310 * ztc * ztc ) 399 zbuf2 = 0.5 * ( devk410 + devk510 * ztc ) 400 aksi3(ji,jj,jk) = zaksi * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 401 402 ! CONVERT FROM DIFFERENT PH SCALES 403 total2free = 1.0/(1.0 + zst/aks3(ji,jj,jk)) 404 free2SWS = 1. + zst/aks3(ji,jj,jk) + zft/akf3(ji,jj,jk) 405 total2SWS = total2free * free2SWS 406 SWS2total = 1.0 / total2SWS 407 408 ! Convert to total scale 409 ak13(ji,jj,jk) = ak13(ji,jj,jk) * SWS2total 410 ak23(ji,jj,jk) = ak23(ji,jj,jk) * SWS2total 411 akb3(ji,jj,jk) = akb3(ji,jj,jk) * SWS2total 412 akw3(ji,jj,jk) = akw3(ji,jj,jk) * SWS2total 413 ak1p3(ji,jj,jk) = ak1p3(ji,jj,jk) * SWS2total 414 ak2p3(ji,jj,jk) = ak2p3(ji,jj,jk) * SWS2total 415 ak3p3(ji,jj,jk) = ak3p3(ji,jj,jk) * SWS2total 416 aksi3(ji,jj,jk) = aksi3(ji,jj,jk) * SWS2total 417 akf3(ji,jj,jk) = akf3(ji,jj,jk) / total2free 418 419 ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE 420 ! AS FUNCTION OF PRESSURE FOLLOWING MILLERO 421 ! (P. 1285) AND BERNER (1976) 422 zbuf1 = - ( devk16 + devk26 * ztc + devk36 * ztc * ztc ) 423 zbuf2 = 0.5 * ( devk46 + devk56 * ztc ) 424 aksp(ji,jj,jk) = zaksp1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 425 426 ! TOTAL F, S, and BORATE CONCENTR. [MOLES/L] 427 borat(ji,jj,jk) = 0.0002414 * zcl / 10.811 428 sulfat(ji,jj,jk) = zst 429 fluorid(ji,jj,jk) = zft 430 431 ! Iron and SIO3 saturation concentration from ... 432 sio3eq(ji,jj,jk) = EXP( LOG( 10.) * ( 6.44 - 968. / ztkel ) ) * 1.e-6 433 fekeq (ji,jj,jk) = 10**( 17.27 - 1565.7 / ztkel ) 434 435 ! Liu and Millero (1999) only valid 5 - 50 degC 436 ztkel1 = MAX( 5. , tempis(ji,jj,jk) ) + 273.16 437 fesol(ji,jj,jk,1) = 10**(-13.486 - 0.1856* zis**0.5 + 0.3073*zis + 5254.0/ztkel1) 438 fesol(ji,jj,jk,2) = 10**(2.517 - 0.8885*zis**0.5 + 0.2139 * zis - 1320.0/ztkel1 ) 439 fesol(ji,jj,jk,3) = 10**(0.4511 - 0.3305*zis**0.5 - 1996.0/ztkel1 ) 440 fesol(ji,jj,jk,4) = 10**(-0.2965 - 0.7881*zis**0.5 - 4086.0/ztkel1 ) 441 fesol(ji,jj,jk,5) = 10**(4.4466 - 0.8505*zis**0.5 - 7980.0/ztkel1 ) 442 END DO 443 END DO 444 END DO 225 DO_3D( 1, 1, 1, 1, 1, jpk ) 226 ! SET PRESSION ACCORDING TO SAUNDER (1980) 227 zplat = SIN ( ABS(gphit(ji,jj)*3.141592654/180.) ) 228 zc1 = 5.92E-3 + zplat**2 * 5.25E-3 229 zpres = ((1-zc1)-SQRT(((1-zc1)**2)-(8.84E-6*gdept(ji,jj,jk,Kmm)))) / 4.42E-6 230 zpres = zpres / 10.0 231 232 ! SET ABSOLUTE TEMPERATURE 233 ztkel = tempis(ji,jj,jk) + 273.15 234 zsal = salinprac(ji,jj,jk) + ( 1.-tmask(ji,jj,jk) ) * 35. 235 zsqrt = SQRT( zsal ) 236 zsal15 = zsqrt * zsal 237 zlogt = LOG( ztkel ) 238 ztr = 1. / ztkel 239 zis = 19.924 * zsal / ( 1000.- 1.005 * zsal ) 240 zis2 = zis * zis 241 zisqrt = SQRT( zis ) 242 ztc = tempis(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 20. 243 244 ! CHLORINITY (WOOSTER ET AL., 1969) 245 zcl = zsal / 1.80655 246 247 ! TOTAL SULFATE CONCENTR. [MOLES/kg soln] 248 zst = 0.14 * zcl /96.062 249 250 ! TOTAL FLUORIDE CONCENTR. [MOLES/kg soln] 251 zft = 0.000067 * zcl /18.9984 252 253 ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) 254 zcks = EXP(-4276.1 * ztr + 141.328 - 23.093 * zlogt & 255 & + (-13856. * ztr + 324.57 - 47.986 * zlogt) * zisqrt & 256 & + (35474. * ztr - 771.54 + 114.723 * zlogt) * zis & 257 & - 2698. * ztr * zis**1.5 + 1776.* ztr * zis2 & 258 & + LOG(1.0 - 0.001005 * zsal)) 259 260 ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) 261 zckf = EXP( 1590.2*ztr - 12.641 + 1.525*zisqrt & 262 & + LOG(1.0d0 - 0.001005d0*zsal) & 263 & + LOG(1.0d0 + zst/zcks)) 264 265 ! DISSOCIATION CONSTANT FOR CARBONATE AND BORATE 266 zckb= (-8966.90 - 2890.53*zsqrt - 77.942*zsal & 267 & + 1.728*zsal15 - 0.0996*zsal*zsal)*ztr & 268 & + (148.0248 + 137.1942*zsqrt + 1.62142*zsal) & 269 & + (-24.4344 - 25.085*zsqrt - 0.2474*zsal) & 270 & * zlogt + 0.053105*zsqrt*ztkel 271 272 ! DISSOCIATION COEFFICIENT FOR CARBONATE ACCORDING TO 273 ! MEHRBACH (1973) REFIT BY MILLERO (1995), seawater scale 274 zck1 = -1.0*(3633.86*ztr - 61.2172 + 9.6777*zlogt & 275 - 0.011555*zsal + 0.0001152*zsal*zsal) 276 zck2 = -1.0*(471.78*ztr + 25.9290 - 3.16967*zlogt & 277 - 0.01781*zsal + 0.0001122*zsal*zsal) 278 279 ! PKW (H2O) (MILLERO, 1995) from composite data 280 zckw = -13847.26 * ztr + 148.9652 - 23.6521 * zlogt + ( 118.67 * ztr & 281 - 5.977 + 1.0495 * zlogt ) * zsqrt - 0.01615 * zsal 282 283 ! CONSTANTS FOR PHOSPHATE (MILLERO, 1995) 284 zck1p = -4576.752*ztr + 115.540 - 18.453*zlogt & 285 & + (-106.736*ztr + 0.69171) * zsqrt & 286 & + (-0.65643*ztr - 0.01844) * zsal 287 288 zck2p = -8814.715*ztr + 172.1033 - 27.927*zlogt & 289 & + (-160.340*ztr + 1.3566)*zsqrt & 290 & + (0.37335*ztr - 0.05778)*zsal 291 292 zck3p = -3070.75*ztr - 18.126 & 293 & + (17.27039*ztr + 2.81197) * zsqrt & 294 & + (-44.99486*ztr - 0.09984) * zsal 295 296 ! CONSTANT FOR SILICATE, MILLERO (1995) 297 zcksi = -8904.2*ztr + 117.400 - 19.334*zlogt & 298 & + (-458.79*ztr + 3.5913) * zisqrt & 299 & + (188.74*ztr - 1.5998) * zis & 300 & + (-12.1652*ztr + 0.07871) * zis2 & 301 & + LOG(1.0 - 0.001005*zsal) 302 303 ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER 304 ! (S=27-43, T=2-25 DEG C) at pres =0 (atmos. pressure) (MUCCI 1983) 305 zaksp0 = -171.9065 -0.077993*ztkel + 2839.319*ztr + 71.595*LOG10( ztkel ) & 306 & + (-0.77712 + 0.00284263*ztkel + 178.34*ztr) * zsqrt & 307 & - 0.07711*zsal + 0.0041249*zsal15 308 309 ! CONVERT FROM DIFFERENT PH SCALES 310 total2free = 1.0/(1.0 + zst/zcks) 311 free2SWS = 1. + zst/zcks + zft/(zckf*total2free) 312 total2SWS = total2free * free2SWS 313 SWS2total = 1.0 / total2SWS 314 315 ! K1, K2 OF CARBONIC ACID, KB OF BORIC ACID, KW (H2O) (LIT.?) 316 zak1 = 10**(zck1) * total2SWS 317 zak2 = 10**(zck2) * total2SWS 318 zakb = EXP( zckb ) * total2SWS 319 zakw = EXP( zckw ) 320 zaksp1 = 10**(zaksp0) 321 zak1p = exp( zck1p ) 322 zak2p = exp( zck2p ) 323 zak3p = exp( zck3p ) 324 zaksi = exp( zcksi ) 325 zckf = zckf * total2SWS 326 327 ! FORMULA FOR CPEXP AFTER EDMOND & GIESKES (1970) 328 ! (REFERENCE TO CULBERSON & PYTKOQICZ (1968) AS MADE 329 ! IN BROECKER ET AL. (1982) IS INCORRECT; HERE RGAS IS 330 ! TAKEN TENFOLD TO CORRECT FOR THE NOTATION OF pres IN 331 ! DBAR INSTEAD OF BAR AND THE EXPRESSION FOR CPEXP IS 332 ! MULTIPLIED BY LN(10.) TO ALLOW USE OF EXP-FUNCTION 333 ! WITH BASIS E IN THE FORMULA FOR AKSPP (CF. EDMOND 334 ! & GIESKES (1970), P. 1285-1286 (THE SMALL 335 ! FORMULA ON P. 1286 IS RIGHT AND CONSISTENT WITH THE 336 ! SIGN IN PARTIAL MOLAR VOLUME CHANGE AS SHOWN ON P. 1285)) 337 zcpexp = zpres / (rgas*ztkel) 338 zcpexp2 = zpres * zcpexp 339 340 ! KB OF BORIC ACID, K1,K2 OF CARBONIC ACID PRESSURE 341 ! CORRECTION AFTER CULBERSON AND PYTKOWICZ (1968) 342 ! (CF. BROECKER ET AL., 1982) 343 344 zbuf1 = - ( devk10 + devk20 * ztc + devk30 * ztc * ztc ) 345 zbuf2 = 0.5 * ( devk40 + devk50 * ztc ) 346 ak13(ji,jj,jk) = zak1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 347 348 zbuf1 = - ( devk11 + devk21 * ztc + devk31 * ztc * ztc ) 349 zbuf2 = 0.5 * ( devk41 + devk51 * ztc ) 350 ak23(ji,jj,jk) = zak2 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 351 352 zbuf1 = - ( devk12 + devk22 * ztc + devk32 * ztc * ztc ) 353 zbuf2 = 0.5 * ( devk42 + devk52 * ztc ) 354 akb3(ji,jj,jk) = zakb * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 355 356 zbuf1 = - ( devk13 + devk23 * ztc + devk33 * ztc * ztc ) 357 zbuf2 = 0.5 * ( devk43 + devk53 * ztc ) 358 akw3(ji,jj,jk) = zakw * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 359 360 zbuf1 = - ( devk14 + devk24 * ztc + devk34 * ztc * ztc ) 361 zbuf2 = 0.5 * ( devk44 + devk54 * ztc ) 362 aks3(ji,jj,jk) = zcks * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 363 364 zbuf1 = - ( devk15 + devk25 * ztc + devk35 * ztc * ztc ) 365 zbuf2 = 0.5 * ( devk45 + devk55 * ztc ) 366 akf3(ji,jj,jk) = zckf * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 367 368 zbuf1 = - ( devk17 + devk27 * ztc + devk37 * ztc * ztc ) 369 zbuf2 = 0.5 * ( devk47 + devk57 * ztc ) 370 ak1p3(ji,jj,jk) = zak1p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 371 372 zbuf1 = - ( devk18 + devk28 * ztc + devk38 * ztc * ztc ) 373 zbuf2 = 0.5 * ( devk48 + devk58 * ztc ) 374 ak2p3(ji,jj,jk) = zak2p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 375 376 zbuf1 = - ( devk19 + devk29 * ztc + devk39 * ztc * ztc ) 377 zbuf2 = 0.5 * ( devk49 + devk59 * ztc ) 378 ak3p3(ji,jj,jk) = zak3p * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 379 380 zbuf1 = - ( devk110 + devk210 * ztc + devk310 * ztc * ztc ) 381 zbuf2 = 0.5 * ( devk410 + devk510 * ztc ) 382 aksi3(ji,jj,jk) = zaksi * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 383 384 ! CONVERT FROM DIFFERENT PH SCALES 385 total2free = 1.0/(1.0 + zst/aks3(ji,jj,jk)) 386 free2SWS = 1. + zst/aks3(ji,jj,jk) + zft/akf3(ji,jj,jk) 387 total2SWS = total2free * free2SWS 388 SWS2total = 1.0 / total2SWS 389 390 ! Convert to total scale 391 ak13(ji,jj,jk) = ak13(ji,jj,jk) * SWS2total 392 ak23(ji,jj,jk) = ak23(ji,jj,jk) * SWS2total 393 akb3(ji,jj,jk) = akb3(ji,jj,jk) * SWS2total 394 akw3(ji,jj,jk) = akw3(ji,jj,jk) * SWS2total 395 ak1p3(ji,jj,jk) = ak1p3(ji,jj,jk) * SWS2total 396 ak2p3(ji,jj,jk) = ak2p3(ji,jj,jk) * SWS2total 397 ak3p3(ji,jj,jk) = ak3p3(ji,jj,jk) * SWS2total 398 aksi3(ji,jj,jk) = aksi3(ji,jj,jk) * SWS2total 399 akf3(ji,jj,jk) = akf3(ji,jj,jk) / total2free 400 401 ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE 402 ! AS FUNCTION OF PRESSURE FOLLOWING MILLERO 403 ! (P. 1285) AND BERNER (1976) 404 zbuf1 = - ( devk16 + devk26 * ztc + devk36 * ztc * ztc ) 405 zbuf2 = 0.5 * ( devk46 + devk56 * ztc ) 406 aksp(ji,jj,jk) = zaksp1 * EXP( zbuf1 * zcpexp + zbuf2 * zcpexp2 ) 407 408 ! TOTAL F, S, and BORATE CONCENTR. [MOLES/L] 409 borat(ji,jj,jk) = 0.0002414 * zcl / 10.811 410 sulfat(ji,jj,jk) = zst 411 fluorid(ji,jj,jk) = zft 412 413 ! Iron and SIO3 saturation concentration from ... 414 sio3eq(ji,jj,jk) = EXP( LOG( 10.) * ( 6.44 - 968. / ztkel ) ) * 1.e-6 415 fekeq (ji,jj,jk) = 10**( 17.27 - 1565.7 / ztkel ) 416 ! Liu and Millero (1999) only valid 5 - 50 degC 417 ztkel1 = MAX( 5. , tempis(ji,jj,jk) ) + 273.16 418 fesol(ji,jj,jk,1) = 10**(-13.486 - 0.1856* zis**0.5 + 0.3073*zis + 5254.0/ztkel1) 419 fesol(ji,jj,jk,2) = 10**(2.517 - 0.8885*zis**0.5 + 0.2139 * zis - 1320.0/ztkel1 ) 420 fesol(ji,jj,jk,3) = 10**(0.4511 - 0.3305*zis**0.5 - 1996.0/ztkel1 ) 421 fesol(ji,jj,jk,4) = 10**(-0.2965 - 0.7881*zis**0.5 - 4086.0/ztkel1 ) 422 fesol(ji,jj,jk,5) = 10**(4.4466 - 0.8505*zis**0.5 - 7980.0/ztkel1 ) 423 END_3D 445 424 ! 446 425 IF( ln_timing ) CALL timing_stop('p4z_che') -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/P4Z/p4zint.F90
r12377 r14098 19 19 REAL(wp) :: xksilim = 16.5e-6_wp ! Half-saturation constant for the Si half-saturation constant computation 20 20 21 # include "do_loop_substitute.h90" 21 22 !!---------------------------------------------------------------------- 22 23 !! NEMO/TOP 4.0 , NEMO Consortium (2018) … … 49 50 ! Computation of the silicon dependant half saturation constant for silica uptake 50 51 ! --------------------------------------------------- 51 DO ji = 1, jpi 52 DO jj = 1, jpj 53 zvar = tr(ji,jj,1,jpsil,Kbb) * tr(ji,jj,1,jpsil,Kbb) 54 xksimax(ji,jj) = MAX( xksimax(ji,jj), ( 1.+ 7.* zvar / ( xksilim * xksilim + zvar ) ) * 1e-6 ) 55 END DO 56 END DO 52 DO_2D( 1, 1, 1, 1 ) 53 zvar = tr(ji,jj,1,jpsil,Kbb) * tr(ji,jj,1,jpsil,Kbb) 54 xksimax(ji,jj) = MAX( xksimax(ji,jj), ( 1.+ 7.* zvar / ( xksilim * xksilim + zvar ) ) * 1e-6 ) 55 END_2D 57 56 ! 58 57 IF( nday_year == nyear_len(1) ) THEN -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/P4Z/p4zsms.F90
r14066 r14098 11 11 USE oce_trc ! shared variables between ocean and passive tracers 12 12 USE trc ! passive tracers common variables 13 USE trcdta !14 13 USE sms_pisces ! PISCES Source Minus Sink variables 15 14 USE p4zbio ! Biological model -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/SED/oce_sed.F90
r14066 r14098 8 8 !!---------------------------------------------------------------------- 9 9 USE par_sed 10 USE par_trc , ONLY : rtrn => rtrn 11 USE par_pisces 10 12 USE timing 11 USE par_trc12 13 13 14 USE dom_oce , ONLY : glamt => glamt !: longitude of t-point (degre) -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/SED/par_sed.F90
r10222 r14098 20 20 jp_sal => jp_sal !: indice of salintity 21 21 22 INTEGER, P ARAMETER :: jpdta = 1722 INTEGER, PUBLIC, PARAMETER :: jpdta = 17 23 23 24 24 ! Vertical sediment geometry 25 INTEGER, PUBLIC :: & 26 jpksed = 11 , & 27 jpksedm1 = 10 25 INTEGER, PUBLIC :: jpksed = 11 26 INTEGER, PUBLIC :: jpksedm1 28 27 29 28 ! sediment tracer species 30 INTEGER, P ARAMETER :: &29 INTEGER, PUBLIC, PARAMETER :: & 31 30 jpsol = 8, & !: number of solid component 32 31 jpwat = 10, & !: number of pore water component … … 36 35 37 36 ! pore water components 38 INTEGER, P ARAMETER :: &37 INTEGER, PUBLIC, PARAMETER :: & 39 38 jwsil = 1, & !: silic acid 40 39 jwoxy = 2, & !: oxygen … … 49 48 50 49 ! solid components 51 INTEGER, P ARAMETER :: &50 INTEGER, PUBLIC, PARAMETER :: & 52 51 jsopal = 1, & !: opal sediment 53 52 jsclay = 2, & !: clay … … 59 58 jsfes = 8 !: FeS 60 59 61 INTEGER, P ARAMETER :: &60 INTEGER, PUBLIC, PARAMETER :: & 62 61 jptrased = jpsol + jpwat , & 63 62 jpdia3dsed = 2 , & -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/SED/sed.F90
r14066 r14098 7 7 !! ! 06-12 (C. Ethe) Orignal 8 8 !!---------------------------------------------------------------------- 9 USE par_sed10 9 USE oce_sed 11 10 USE in_out_manager … … 62 61 REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: solcp !: solid sediment data at given time-step 63 62 REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: solcp0 !: solid sediment data at initial time 64 REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: trc_dta65 63 REAL(wp), PUBLIC, DIMENSION(:,:,:), ALLOCATABLE :: diff 66 64 -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/SED/sedarr.F90
r10222 r14098 10 10 !!---------------------------------------------------------------------- 11 11 !! * Modules used 12 USE par_oce 12 13 USE par_sed 13 USE dom_oce14 USE sed14 USE in_out_manager, ONLY : ln_timing 15 USE timing 15 16 16 17 IMPLICIT NONE -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/SED/sedchem.F90
r13295 r14098 6 6 !!====================================================================== 7 7 !! modules used 8 USE par_sed 8 9 USE sed ! sediment global variable 9 10 USE sedarr -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/SED/sedini.F90
r13295 r14098 9 9 !!---------------------------------------------------------------------- 10 10 !! * Modules used 11 USE par_trc ! need jptra, number of passive tracers 12 USE par_sed 11 13 USE sed ! sediment global variable 12 14 USE sed_oce -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/SED/sedwri.F90
r12489 r14098 4 4 !! Sediment diagnostics : write sediment output files 5 5 !!====================================================================== 6 USE par_sed 6 7 USE sed 7 8 USE sedarr -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/SED/trcdmp_sed.F90
r13295 r14098 91 91 ! 92 92 jl = n_trc_index(jn) 93 CALL trc_dta( kt, Kmm, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit00093 CALL trc_dta( kt, jl, ztrcdta ) ! read tracer data at nit000 94 94 ! 95 95 DO_2D( 1, 1, 1, 1 ) … … 108 108 WRITE(charout, FMT="('dmp ')") 109 109 CALL prt_ctl_info( charout, cdcomp = 'top' ) 110 CALL prt_ctl( tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm, 110 CALL prt_ctl( tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm,clinfo3='trd' ) 111 111 ENDIF 112 112 ! -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/PISCES/trcini_pisces.F90
r12377 r14098 79 79 ! 80 80 INTEGER, INTENT(in) :: Kmm ! time level indices 81 REAL(wp), SAVE :: sco2 = 2.312e-3_wp82 REAL(wp), SAVE :: alka0 = 2.426e-3_wp83 REAL(wp), SAVE :: oxyg0 = 177.6e-6_wp84 REAL(wp), SAVE :: po4 = 2.165e-6_wp85 REAL(wp), SAVE :: bioma0 = 1.000e-8_wp86 REAL(wp), SAVE :: silic1 = 91.51e-6_wp87 REAL(wp), SAVE :: no3 = 30.9e-6_wp * 7.625_wp88 81 ! 89 82 INTEGER :: ji, jj, jk, jn, ierr 90 83 REAL(wp) :: zcaralk, zbicarb, zco3 91 84 REAL(wp) :: ztmas, ztmas1 85 REAL(wp) :: sco2, alka0, oxyg0, po4, bioma0, silic1, no3 92 86 CHARACTER(len = 20) :: cltra 93 87 !!---------------------------------------------------------------------- … … 103 97 ENDIF 104 98 ENDIF 99 ! 100 sco2 = 2.312e-3_wp 101 alka0 = 2.426e-3_wp 102 oxyg0 = 177.6e-6_wp 103 po4 = 2.165e-6_wp 104 bioma0 = 1.000e-8_wp 105 silic1 = 91.51e-6_wp 106 no3 = 30.9e-6_wp * 7.625_wp 105 107 ! 106 108 ! Allocate PISCES arrays -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/TRP/trcadv.F90
r14066 r14098 16 16 !! trc_adv_ini : control the different options of advection scheme 17 17 !!---------------------------------------------------------------------- 18 USE par_trc ! need jptra, number of passive tracers 18 19 USE oce_trc ! ocean dynamics and active tracers 19 20 USE trc ! ocean passive tracers variables -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/TRP/trcatf.F90
r14066 r14098 27 27 !! trc_atf : time stepping on passive tracers 28 28 !!---------------------------------------------------------------------- 29 USE par_trc ! need jptra, number of passive tracers 29 30 USE oce_trc ! ocean dynamics and tracers variables 30 31 USE trc ! ocean passive tracers variables -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/TRP/trcbbl.F90
r13286 r14098 20 20 !! trc_bbl : update the tracer trends due to the bottom boundary layer (advective and/or diffusive) 21 21 !!---------------------------------------------------------------------- 22 USE par_trc ! need jptra, number of passive tracers 22 23 USE oce_trc ! ocean dynamics and passive tracers variables 23 24 USE trc ! ocean passive tracers variables -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/TRP/trcdmp.F90
r13295 r14098 16 16 !! trc_dmp_init : initialization, namlist read, parameters control 17 17 !!---------------------------------------------------------------------- 18 USE par_trc ! need jptra, number of passive tracers 18 19 USE oce_trc ! ocean dynamics and tracers variables 19 20 USE trc ! ocean passive tracers variables … … 108 109 ! 109 110 jl = n_trc_index(jn) 110 CALL trc_dta( kt, Kmm, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000111 CALL trc_dta( kt, jl, ztrcdta ) ! read tracer data at nit000 111 112 ! 112 113 SELECT CASE ( nn_zdmp_tr ) … … 350 351 IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file 351 352 jl = n_trc_index(jn) 352 CALL trc_dta( kt, Kmm, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000353 CALL trc_dta( kt, jl, ztrcdta ) ! read tracer data at nit000 353 354 DO jc = 1, npncts 354 355 DO jk = 1, jpkm1 -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/TRP/trcldf.F90
r14066 r14098 15 15 !! trc_ldf_ini : initialization, namelist read, and parameters control 16 16 !!---------------------------------------------------------------------- 17 USE par_trc ! need jptra, number of passive tracers 17 18 USE trc ! ocean passive tracers variables 18 19 USE oce_trc ! ocean dynamics and active tracers -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/TRP/trcsbc.F90
r13295 r14098 16 16 !! trc_sbc : update the tracer trend at ocean surface 17 17 !!---------------------------------------------------------------------- 18 USE par_trc ! need jptra, number of passive tracers 18 19 USE oce_trc ! ocean dynamics and active tracers variables 19 20 USE trc ! ocean passive tracers variables -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/TRP/trctrp.F90
r14066 r14098 13 13 !! trc_trp : passive tracer transport 14 14 !!---------------------------------------------------------------------- 15 USE par_trc ! need jptra, number of passive tracers 15 16 USE oce_trc ! ocean dynamics and active tracers variables 16 17 USE trc ! ocean passive tracers variables … … 28 29 USE bdy_oce , ONLY: ln_bdy 29 30 USE trcbdy ! BDY open boundaries 31 USE in_out_manager 30 32 31 33 #if defined key_agrif … … 63 65 IF( .NOT. lk_c1d ) THEN 64 66 ! 67 ! ! Partial top/bottom cell: GRADh( trb ) 68 IF( ln_zps ) THEN 69 IF( ln_isfcav ) THEN ; CALL zps_hde_isf( kt, Kmm, jptra, tr(:,:,:,:,Kbb), pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi ) ! both top & bottom 70 ELSE ; CALL zps_hde ( kt, Kmm, jptra, tr(:,:,:,:,Kbb), gtru, gtrv ) ! only bottom 71 ENDIF 72 ENDIF 73 ! 65 74 CALL trc_sbc ( kt, Kmm, tr, Krhs ) ! surface boundary condition 66 75 IF( ln_trcbc .AND. lltrcbc .AND. kt /= nit000 ) & … … 70 79 IF( ln_trcdmp ) CALL trc_dmp ( kt, Kbb, Kmm, tr, Krhs ) ! internal damping trends 71 80 IF( ln_bdy ) CALL trc_bdy_dmp( kt, Kbb, Krhs ) ! BDY damping trends 72 CALL trc_adv ( kt, Kbb, Kmm, tr, Krhs ) ! horizontal & vertical advection73 ! ! Partial top/bottom cell: GRADh( trb )74 IF( ln_zps ) THEN75 IF( ln_isfcav ) THEN ; CALL zps_hde_isf( kt, Kmm, jptra, tr(:,:,:,:,Kbb), pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi ) ! both top & bottom76 ELSE ; CALL zps_hde ( kt, Kmm, jptra, tr(:,:,:,:,Kbb), gtru, gtrv ) ! only bottom77 ENDIF78 ENDIF79 !80 CALL trc_ldf ( kt, Kbb, Kmm, tr, Krhs ) ! lateral mixing81 81 #if defined key_agrif 82 82 IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_trc ! tracers sponge 83 83 #endif 84 CALL trc_adv ( kt, Kbb, Kmm, tr, Krhs ) ! horizontal & vertical advection 85 CALL trc_ldf ( kt, Kbb, Kmm, tr, Krhs ) ! lateral mixing 84 86 CALL trc_zdf ( kt, Kbb, Kmm, Krhs, tr, Kaa ) ! vert. mixing & after tracer ==> after 85 87 CALL trc_atf ( kt, Kbb, Kmm, Kaa , tr ) ! time filtering of "now" tracer fields -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/TRP/trczdf.F90
r13286 r14098 14 14 !! trc_zdf : update the tracer trend with the vertical diffusion 15 15 !!---------------------------------------------------------------------- 16 USE par_trc ! need jptra, number of passive tracers 16 17 USE trc ! ocean passive tracers variables 17 18 USE oce_trc ! ocean dynamics and active tracers 18 19 USE trd_oce ! trends: ocean variables 19 20 USE trazdf ! tracer: vertical diffusion 20 !!gm do we really need this ?21 USE trcldf ! passive tracers: lateral diffusion22 !!gm23 21 USE trdtra ! trends manager: tracers 24 22 USE prtctl ! Print control -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/trcdta.F90
r13497 r14098 31 31 PUBLIC trc_dta_ini ! called in trcini.F90 32 32 33 INTEGER , SAVE, PUBLIC :: nb_trcdta ! number of tracers to be initialised with data 34 INTEGER , SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: n_trc_index ! indice of tracer which is initialised with data 35 INTEGER , SAVE, PUBLIC :: ntra ! MAX( 1, nb_trcdta ) to avoid compilation error with bounds checking 36 REAL(wp) , SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: rf_trfac ! multiplicative factor for tracer values 37 !$AGRIF_DO_NOT_TREAT 38 TYPE(FLD), SAVE, PUBLIC, ALLOCATABLE, DIMENSION(:) :: sf_trcdta ! structure of input SST (file informations, fields read) 39 !$AGRIF_END_DO_NOT_TREAT 33 INTEGER , PUBLIC :: nb_trcdta ! number of tracers to be initialised with data 34 INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: n_trc_index ! indice of tracer which is initialised with data 35 INTEGER , PUBLIC :: ntra ! MAX( 1, nb_trcdta ) to avoid compilation error with bounds checking 36 REAL(wp) , ALLOCATABLE, DIMENSION(:) :: rf_trfac ! multiplicative factor for tracer values 37 TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_trcdta ! structure of input SST (file informations, fields read) 40 38 41 39 !! Substitutions … … 155 153 156 154 157 SUBROUTINE trc_dta( kt, Kmm, sf_trcdta, ptrcfac, ptrcdta)155 SUBROUTINE trc_dta( kt, kjl, ptrcdta) 158 156 !!---------------------------------------------------------------------- 159 157 !! *** ROUTINE trc_dta *** … … 168 166 !!---------------------------------------------------------------------- 169 167 INTEGER , INTENT(in ) :: kt ! ocean time-step 170 INTEGER , INTENT(in ) :: Kmm ! time level index 171 TYPE(FLD), DIMENSION(1) , INTENT(inout) :: sf_trcdta ! array of information on the field to read 172 REAL(wp) , INTENT(in ) :: ptrcfac ! multiplication factor 168 INTEGER , INTENT(in ) :: kjl ! tracer index 173 169 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout ) :: ptrcdta ! 3D data array 174 170 ! … … 191 187 ! read data at kt time step 192 188 CALL fld_read( kt, 1, sf_trcdta ) 193 ptrcdta(:,:,:) = sf_trcdta( 1)%fnow(:,:,:) * tmask(:,:,:)189 ptrcdta(:,:,:) = sf_trcdta(kjl)%fnow(:,:,:) * tmask(:,:,:) 194 190 ! 195 191 IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! … … 201 197 DO_2D( 1, 1, 1, 1 ) ! vertical interpolation of T & S 202 198 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 203 zl = gdept (ji,jj,jk,Kmm)199 zl = gdept_0(ji,jj,jk) 204 200 IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data 205 201 ztp(jk) = ptrcdta(ji,jj,1) … … 223 219 ELSE !== z- or zps- coordinate ==! 224 220 ! zps-coordinate (partial steps) interpolation at the last ocean level 225 ! IF( ln_zps ) THEN 226 ! DO jj = 1, jpj 227 ! DO ji = 1, jpi 228 ! ik = mbkt(ji,jj) 229 ! IF( ik > 1 ) THEN 230 ! zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 231 ! ptrcdta(ji,jj,ik) = (1.-zl) * ptrcdta(ji,jj,ik) + zl * ptrcdta(ji,jj,ik-1) 232 ! ENDIF 233 ! ik = mikt(ji,jj) 234 ! IF( ik > 1 ) THEN 235 ! zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 236 ! ptrcdta(ji,jj,ik) = (1.-zl) * ptrcdta(ji,jj,ik) + zl * ptrcdta(ji,jj,ik+1) 237 ! ENDIF 238 ! END DO 239 ! END DO 240 ! ENDIF 221 IF( ln_zps ) THEN 222 DO_2D( 1, 1, 1, 1 ) 223 ik = mbkt(ji,jj) 224 IF( ik > 1 ) THEN 225 zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 226 ptrcdta(ji,jj,ik) = (1.-zl) * ptrcdta(ji,jj,ik) + zl * ptrcdta(ji,jj,ik-1) 227 ENDIF 228 ik = mikt(ji,jj) 229 IF( ik > 1 ) THEN 230 zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 231 ptrcdta(ji,jj,ik) = (1.-zl) * ptrcdta(ji,jj,ik) + zl * ptrcdta(ji,jj,ik+1) 232 ENDIF 233 END_2D 234 ENDIF 241 235 ! 242 236 ENDIF 243 !244 237 ! Scale by multiplicative factor 245 ptrcdta(:,:,:) = ptrcdta(:,:,:) * ptrcfac238 ptrcdta(:,:,:) = ptrcdta(:,:,:) * rf_trfac(kjl) 246 239 ! 247 240 ENDIF … … 256 249 !!---------------------------------------------------------------------- 257 250 CONTAINS 258 SUBROUTINE trc_dta( kt, sf_trcdta, ptrcfac, ptrcdta) ! Empty routine251 SUBROUTINE trc_dta( kt, kjl, ptrcdta) ! Empty routine 259 252 WRITE(*,*) 'trc_dta: You should not have seen this print! error?', kt 260 253 END SUBROUTINE trc_dta -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/trcice.F90
r12377 r14098 12 12 !! trc_ice : Call the appropriate sea ice tracer subroutine 13 13 !!---------------------------------------------------------------------- 14 USE par_trc ! need jptra, number of passive tracers 14 15 USE oce_trc ! shared variables between ocean and passive tracers 15 16 USE trc ! passive tracers common variables -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/trcini.F90
r14066 r14098 16 16 !! top_alloc : allocate the TOP arrays 17 17 !!---------------------------------------------------------------------- 18 USE par_trc ! need jptra, number of passive tracers 18 19 USE oce_trc ! shared variables between ocean and passive tracers 19 20 USE trc ! passive tracers common variables … … 96 97 CHARACTER (len=25) :: charout 97 98 REAL(wp), DIMENSION(jpi,jpj,jpk,jptra) :: zzmsk 98 CHARACTER (len=25), DIMENSION(jptra) :: clseb99 99 !!---------------------------------------------------------------------- 100 100 ! … … 132 132 CALL prt_ctl_info( charout, cdcomp = 'top' ) 133 133 CALL prt_ctl( tab4d_1=tr(:,:,:,:,Kmm), mask1=tmask, clinfo=ctrcnm ) 134 DO jn = 1, jptra135 zzmsk(:,:,:,jn) = tmask(:,:,:)136 WRITE(clseb(jn),'(a,i2.2)') 'seb ', jn137 END DO138 CALL prt_ctl( tab4d_1=zzmsk, mask1=tmask, clinfo=clseb )139 134 ENDIF 140 135 9000 FORMAT(' tracer nb : ',i2,' name :',a10,' initial content :',e18.10) … … 262 257 ! 263 258 ELSE ! Initialisation of tracer from a file that may also be used for damping 264 !!gm BUG ? if damping and restart, what's happening ?265 259 IF( ln_trcdta .AND. nb_trcdta > 0 ) THEN 266 260 ! update passive tracers arrays with input data read from file … … 268 262 IF( ln_trc_ini(jn) ) THEN 269 263 jl = n_trc_index(jn) 270 CALL trc_dta( nit000, Kmm, sf_trcdta(jl), rf_trfac(jl), tr(:,:,:,jn,Kmm) ) 271 ! 272 ! deallocate data structure if data are not used for damping 273 IF( .NOT.ln_trcdmp .AND. .NOT.ln_trcdmp_clo ) THEN 274 IF(lwp) WRITE(numout,*) 'trc_ini_state: deallocate data arrays as they are only used to initialize the run' 275 DEALLOCATE( sf_trcdta(jl)%fnow ) 276 IF( sf_trcdta(jl)%ln_tint ) DEALLOCATE( sf_trcdta(jl)%fdta ) 277 ! 278 ENDIF 264 CALL trc_dta( nit000, jl, tr(:,:,:,jn,Kmm) ) 279 265 ENDIF 280 266 END DO -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/trcnam.F90
r14066 r14098 18 18 !! trc_nam : Read and print options for the passive tracer run (namelist) 19 19 !!---------------------------------------------------------------------- 20 USE par_trc ! need jptra, number of passive tracers 20 21 USE oce_trc ! shared variables between ocean and passive tracers 21 22 USE trc ! passive tracers common variables -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/trcrst.F90
r14066 r14098 19 19 !! trc_rst_wri : write restart file 20 20 !!---------------------------------------------------------------------- 21 USE par_trc ! need jptra, number of passive tracers 21 22 USE oce_trc 22 23 USE trc -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/src/TOP/trcstp.F90
r14066 r14098 11 11 !! trc_stp : passive tracer system time-stepping 12 12 !!---------------------------------------------------------------------- 13 USE par_trc ! need jptra, number of passive tracers 13 14 USE oce_trc ! ocean dynamics and active tracers variables 14 15 USE sbc_oce -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/tests/ISOMIP+/MY_SRC/dtatsd.F90
r14066 r14098 18 18 USE phycst ! physical constants 19 19 USE dom_oce ! ocean space and time domain 20 USE dom ain, ONLY : dom_tile20 USE domtile 21 21 USE fldread ! read input fields 22 22 ! -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/tests/VORTEX/MY_SRC/usrdef_istate.F90
r14066 r14098 90 90 ! 91 91 ! salinity: 92 pts(:,:,:,jp_sal) = 35._wp 92 pts(:,:,:,jp_sal) = 35._wp * ptmask(:,:,:) 93 93 ! 94 94 ! velocities: -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/tests/VORTEX/MY_SRC/usrdef_nam.F90
r13286 r14098 71 71 rn_dx = Agrif_Parent(rn_dx)/Agrif_Rhox() 72 72 rn_dy = Agrif_Parent(rn_dy)/Agrif_Rhoy() 73 rn_dz = Agrif_Parent(rn_dz)73 ! rn_dz = Agrif_Parent(rn_dz) 74 74 rn_ppgphi0 = Agrif_Parent(rn_ppgphi0) 75 75 ENDIF -
NEMO/branches/2020/dev_r13787_doc_latex_recovery/tests/demo_cfgs.txt
r14085 r14098 3 3 ISOMIP+ OCE 4 4 LOCK_EXCHANGE OCE 5 OVERFLOW OCE 5 OVERFLOW OCE NST 6 6 ICE_AGRIF OCE NST SAS ICE 7 7 ICE_ADV1D OCE SAS ICE … … 15 15 C1D_ASICS OCE 16 16 ICE_RHEO OCE SAS ICE 17 DOME OCE NST
Note: See TracChangeset
for help on using the changeset viewer.