Changeset 13540 for NEMO/branches/2020/r12377_ticket2386/src/NST
- Timestamp:
- 2020-09-29T12:41:06+02:00 (4 years ago)
- Location:
- NEMO/branches/2020/r12377_ticket2386
- Files:
-
- 10 edited
-
. (modified) (1 prop)
-
src/NST/agrif_ice.F90 (modified) (1 diff)
-
src/NST/agrif_ice_interp.F90 (modified) (12 diffs)
-
src/NST/agrif_ice_update.F90 (modified) (4 diffs)
-
src/NST/agrif_oce.F90 (modified) (6 diffs)
-
src/NST/agrif_oce_interp.F90 (modified) (22 diffs)
-
src/NST/agrif_oce_sponge.F90 (modified) (38 diffs)
-
src/NST/agrif_oce_update.F90 (modified) (7 diffs)
-
src/NST/agrif_top_interp.F90 (modified) (1 diff)
-
src/NST/agrif_user.F90 (modified) (29 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/r12377_ticket2386
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev @HEADext/AGRIF5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 8 9 9 # SETTE 10 ^/utils/CI/sette@ HEADsette10 ^/utils/CI/sette@13507 sette
-
- Property svn:externals
-
NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice.F90
r10068 r13540 16 16 17 17 INTEGER, PUBLIC :: u_ice_id, v_ice_id, tra_ice_id 18 INTEGER, PUBLIC :: u_iceini_id, v_iceini_id, tra_iceini_id 18 19 INTEGER, PUBLIC :: nbstep_ice = 0 ! child time position in sea-ice model 19 20 -
NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice_interp.F90
r10069 r13540 14 14 !!---------------------------------------------------------------------- 15 15 !! agrif_interp_ice : interpolation of ice at "after" sea-ice time step 16 !! agrif_interp_u_ice : atomic routine to interpolate u_ice17 !! agrif_interp_v_ice : atomic routine to interpolate v_ice18 !! agrif_interp_tra_ice : atomic routine to interpolate ice properties16 !! interp_u_ice : atomic routine to interpolate u_ice 17 !! interp_v_ice : atomic routine to interpolate v_ice 18 !! interp_tra_ice : atomic routine to interpolate ice properties 19 19 !!---------------------------------------------------------------------- 20 20 USE par_oce … … 23 23 USE ice 24 24 USE agrif_ice 25 USE agrif_oce 25 26 USE phycst , ONLY: rt0 26 27 … … 29 30 30 31 PUBLIC agrif_interp_ice ! called by agrif_user.F90 32 PUBLIC interp_tra_ice, interp_u_ice, interp_v_ice ! called by iceistate.F90 31 33 32 34 !!---------------------------------------------------------------------- … … 68 70 Agrif_SpecialValue = -9999. 69 71 Agrif_UseSpecialValue = .TRUE. 72 73 use_sign_north = .TRUE. 74 sign_north = -1. 75 if (cd_type == 'T') use_sign_north = .FALSE. 76 70 77 SELECT CASE( cd_type ) 71 78 CASE('U') ; CALL Agrif_Bc_variable( u_ice_id , procname=interp_u_ice , calledweight=zbeta ) … … 75 82 Agrif_SpecialValue = 0._wp 76 83 Agrif_UseSpecialValue = .FALSE. 84 85 use_sign_north = .FALSE. 77 86 ! 78 87 END SUBROUTINE agrif_interp_ice … … 156 165 ! and it is ok since we conserve tracers (same as in the ocean). 157 166 ALLOCATE( ztab(SIZE(a_i,1),SIZE(a_i,2),SIZE(ptab,3)) ) 158 167 159 168 IF( before ) THEN ! parent grid 160 169 jm = 1 … … 167 176 ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl) 168 177 ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl) 169 ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl) 170 jm = jm + 8 178 ptab(i1:i2,j1:j2,jm+7) = v_il(i1:i2,j1:j2,jl) 179 ptab(i1:i2,j1:j2,jm+8) = t_su(i1:i2,j1:j2,jl) 180 jm = jm + 9 171 181 DO jk = 1, nlay_s 172 182 ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 … … 197 207 a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1) 198 208 v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1) 199 t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 209 v_il(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 210 t_su(ji,jj,jl) = ptab(ji,jj,jm+8) * tmask(ji,jj,1) 200 211 END DO 201 212 END DO 202 jm = jm + 8213 jm = jm + 9 203 214 ! 204 215 DO jk = 1, nlay_s … … 230 241 ! ztab(:,:,jm+5) = a_ip(:,:,jl) 231 242 ! ztab(:,:,jm+6) = v_ip(:,:,jl) 232 ! ztab(:,:,jm+7) = t_su(:,:,jl) 233 ! jm = jm + 8 243 ! ztab(:,:,jm+7) = v_il(:,:,jl) 244 ! ztab(:,:,jm+8) = t_su(:,:,jl) 245 ! jm = jm + 9 234 246 ! DO jk = 1, nlay_s 235 247 ! ztab(:,:,jm) = e_s(:,:,jk,jl) … … 260 272 ! imin = i1 ; imax = i2 ; jmin = j1 ; jmax = j2 261 273 ! IF( (nbondj == -1) .OR. (nbondj == 2) ) jmin = 3 262 ! IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = nlcj-2274 ! IF( (nbondj == +1) .OR. (nbondj == 2) ) jmax = jpj-2 263 275 ! IF( (nbondi == -1) .OR. (nbondi == 2) ) imin = 3 264 ! IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = nlci-2276 ! IF( (nbondi == +1) .OR. (nbondi == 2) ) imax = jpi-2 265 277 ! 266 278 ! ! smoothed fields 267 279 ! IF( eastern_side ) THEN 268 ! ztab( nlci,j1:j2,:) = z1 * ptab(nlci,j1:j2,:) + z2 * ptab(nlci-1,j1:j2,:)280 ! ztab(jpi,j1:j2,:) = z1 * ptab(jpi,j1:j2,:) + z2 * ptab(jpi-1,j1:j2,:) 269 281 ! DO jj = jmin, jmax 270 282 ! rswitch = 0. 271 ! IF( u_ice( nlci-2,jj) > 0._wp ) rswitch = 1.272 ! ztab( nlci-1,jj,:) = ( 1. - umask(nlci-2,jj,1) ) * ztab(nlci,jj,:) &273 ! & + umask(nlci-2,jj,1) * &274 ! & ( ( 1. - rswitch ) * ( z4 * ztab(nlci,jj,:) + z3 * ztab(nlci-2,jj,:) ) &275 ! & + rswitch * ( z6 * ztab(nlci-2,jj,:) + z5 * ztab(nlci,jj,:) + z7 * ztab(nlci-3,jj,:) ) )276 ! ztab( nlci-1,jj,:) = ztab(nlci-1,jj,:) * tmask(nlci-1,jj,1)283 ! IF( u_ice(jpi-2,jj) > 0._wp ) rswitch = 1. 284 ! ztab(jpi-1,jj,:) = ( 1. - umask(jpi-2,jj,1) ) * ztab(jpi,jj,:) & 285 ! & + umask(jpi-2,jj,1) * & 286 ! & ( (1. - rswitch) * ( z4 * ztab(jpi ,jj,:) + z3 * ztab(jpi-2,jj,:) ) & 287 ! & + rswitch * ( z6 * ztab(jpi-2,jj,:) + z5 * ztab(jpi ,jj,:) + z7 * ztab(jpi-3,jj,:) ) ) 288 ! ztab(jpi-1,jj,:) = ztab(jpi-1,jj,:) * tmask(jpi-1,jj,1) 277 289 ! END DO 278 290 ! ENDIF 279 291 ! ! 280 292 ! IF( northern_side ) THEN 281 ! ztab(i1:i2, nlcj,:) = z1 * ptab(i1:i2,nlcj,:) + z2 * ptab(i1:i2,nlcj-1,:)293 ! ztab(i1:i2,jpj,:) = z1 * ptab(i1:i2,jpj,:) + z2 * ptab(i1:i2,jpj-1,:) 282 294 ! DO ji = imin, imax 283 295 ! rswitch = 0. 284 ! IF( v_ice(ji, nlcj-2) > 0._wp ) rswitch = 1.285 ! ztab(ji, nlcj-1,:) = ( 1. - vmask(ji,nlcj-2,1) ) * ztab(ji,nlcj,:) &286 ! & + vmask(ji,nlcj-2,1) * &287 ! & ( ( 1. - rswitch ) * ( z4 * ztab(ji,nlcj,:) + z3 * ztab(ji,nlcj-2,:) ) &288 ! & + rswitch * ( z6 * ztab(ji,nlcj-2,:) + z5 * ztab(ji,nlcj,:) + z7 * ztab(ji,nlcj-3,:) ) )289 ! ztab(ji, nlcj-1,:) = ztab(ji,nlcj-1,:) * tmask(ji,nlcj-1,1)296 ! IF( v_ice(ji,jpj-2) > 0._wp ) rswitch = 1. 297 ! ztab(ji,jpj-1,:) = ( 1. - vmask(ji,jpj-2,1) ) * ztab(ji,jpj,:) & 298 ! & + vmask(ji,jpj-2,1) * & 299 ! & ( (1. - rswitch) * ( z4 * ztab(ji,jpj ,:) + z3 * ztab(ji,jpj-2,:) ) & 300 ! & + rswitch * ( z6 * ztab(ji,jpj-2,:) + z5 * ztab(ji,jpj ,:) + z7 * ztab(ji,jpj-3,:) ) ) 301 ! ztab(ji,jpj-1,:) = ztab(ji,jpj-1,:) * tmask(ji,jpj-1,1) 290 302 ! END DO 291 303 ! END IF … … 318 330 ! ! 319 331 ! ! Treatment of corners 320 ! IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab( nlci-1,2,:) = ptab(nlci-1,2,:)! East south321 ! IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab( nlci-1,nlcj-1,:) = ptab(nlci-1,nlcj-1,:)! East north322 ! IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab( 2,2,:) = ptab(2,2,:)! West south323 ! IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab( 2,nlcj-1,:) = ptab(2,nlcj-1,:)! West north332 ! IF( (eastern_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab(jpi-1,2 ,:) = ptab(jpi-1, 2,:) ! East south 333 ! IF( (eastern_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab(jpi-1,jpj-1,:) = ptab(jpi-1,jpj-1,:) ! East north 334 ! IF( (western_side) .AND. ((nbondj == -1).OR.(nbondj == 2)) ) ztab( 2, 2,:) = ptab( 2, 2,:) ! West south 335 ! IF( (western_side) .AND. ((nbondj == 1).OR.(nbondj == 2)) ) ztab( 2,jpj-1,:) = ptab( 2,jpj-1,:) ! West north 324 336 ! 325 337 ! ! retrieve ice tracers … … 336 348 ! a_ip(ji,jj,jl) = ztab(ji,jj,jm+5) * tmask(ji,jj,1) 337 349 ! v_ip(ji,jj,jl) = ztab(ji,jj,jm+6) * tmask(ji,jj,1) 338 ! t_su(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1) 350 ! v_il(ji,jj,jl) = ztab(ji,jj,jm+7) * tmask(ji,jj,1) 351 ! t_su(ji,jj,jl) = ztab(ji,jj,jm+8) * tmask(ji,jj,1) 339 352 ! END DO 340 353 ! END DO 341 ! jm = jm + 8354 ! jm = jm + 9 342 355 ! ! 343 356 ! DO jk = 1, nlay_s -
NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_ice_update.F90
r12377 r13540 66 66 CALL Agrif_Update_Variable( tra_ice_id , locupdate=(/1,0/), procname = update_tra_ice ) 67 67 #endif 68 use_sign_north = .TRUE. 69 sign_north = -1. 70 68 71 # if ! defined DECAL_FEEDBACK 69 72 CALL Agrif_Update_Variable( u_ice_id , procname = update_u_ice ) … … 73 76 CALL Agrif_Update_Variable( v_ice_id , locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname=update_v_ice) 74 77 #endif 78 use_sign_north = .FALSE. 75 79 ! CALL Agrif_Update_Variable( tra_ice_id , locupdate=(/0,2/), procname = update_tra_ice ) 76 80 ! CALL Agrif_Update_Variable( u_ice_id , locupdate=(/0,1/), procname = update_u_ice ) … … 105 109 ptab(i1:i2,j1:j2,jm+5) = a_ip(i1:i2,j1:j2,jl) 106 110 ptab(i1:i2,j1:j2,jm+6) = v_ip(i1:i2,j1:j2,jl) 107 ptab(i1:i2,j1:j2,jm+7) = t_su(i1:i2,j1:j2,jl) 108 jm = jm + 8 111 ptab(i1:i2,j1:j2,jm+7) = v_il(i1:i2,j1:j2,jl) 112 ptab(i1:i2,j1:j2,jm+8) = t_su(i1:i2,j1:j2,jl) 113 jm = jm + 9 109 114 DO jk = 1, nlay_s 110 115 ptab(i1:i2,j1:j2,jm) = e_s(i1:i2,j1:j2,jk,jl) ; jm = jm + 1 … … 134 139 a_ip(ji,jj,jl) = ptab(ji,jj,jm+5) * tmask(ji,jj,1) 135 140 v_ip(ji,jj,jl) = ptab(ji,jj,jm+6) * tmask(ji,jj,1) 136 t_su(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 141 v_il(ji,jj,jl) = ptab(ji,jj,jm+7) * tmask(ji,jj,1) 142 t_su(ji,jj,jl) = ptab(ji,jj,jm+8) * tmask(ji,jj,1) 137 143 ENDIF 138 144 END DO 139 145 END DO 140 jm = jm + 8146 jm = jm + 9 141 147 ! 142 148 DO jk = 1, nlay_s -
NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce.F90
r12377 r13540 19 19 20 20 ! !!* Namelist namagrif: AGRIF parameters 21 LOGICAL , PUBLIC :: ln_init_chfrpar = .FALSE. !: set child grids initial state from parent 21 22 LOGICAL , PUBLIC :: ln_agrif_2way = .TRUE. !: activate two way nesting 22 23 LOGICAL , PUBLIC :: ln_spc_dyn = .FALSE. !: use zeros (.false.) or not (.true.) in … … 29 30 ! 30 31 INTEGER , PUBLIC, PARAMETER :: nn_sponge_len = 2 !: Sponge width (in number of parent grid points) 32 31 33 LOGICAL , PUBLIC :: spongedoneT = .FALSE. !: tracer sponge layer indicator 32 34 LOGICAL , PUBLIC :: spongedoneU = .FALSE. !: dynamics sponge layer indicator … … 49 51 INTEGER , PUBLIC, SAVE :: Kbb_a, Kmm_a, Krhs_a !: AGRIF module-specific copies of time-level indices 50 52 51 # if defined key_vertical52 53 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht0_parent, hu0_parent, hv0_parent 53 54 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt_parent, mbku_parent, mbkv_parent 54 # endif55 55 56 56 INTEGER, PUBLIC :: tsn_id ! AGRIF profile for tracers interpolation and update … … 58 58 INTEGER, PUBLIC :: un_update_id, vn_update_id ! AGRIF profiles for udpates 59 59 INTEGER, PUBLIC :: tsn_sponge_id, un_sponge_id, vn_sponge_id ! AGRIF profiles for sponge layers 60 INTEGER, PUBLIC :: tsini_id, uini_id, vini_id, sshini_id ! AGRIF profile for initialization 60 61 # if defined key_top 61 62 INTEGER, PUBLIC :: trn_id, trn_sponge_id … … 67 68 INTEGER, PUBLIC :: avt_id, avm_id, en_id ! TKE related identificators 68 69 INTEGER, PUBLIC :: mbkt_id, ht0_id 70 INTEGER, PUBLIC :: glamt_id, gphit_id 69 71 INTEGER, PUBLIC :: kindic_agr 72 73 ! North fold 74 !$AGRIF_DO_NOT_TREAT 75 LOGICAL, PUBLIC :: use_sign_north 76 REAL, PUBLIC :: sign_north 77 LOGICAL, PUBLIC :: l_ini_child = .FALSE. 78 # if defined key_vertical 79 LOGICAL, PUBLIC :: l_vremap = .TRUE. 80 # else 81 LOGICAL, PUBLIC :: l_vremap = .FALSE. 82 # endif 83 !$AGRIF_END_DO_NOT_TREAT 70 84 71 85 !!---------------------------------------------------------------------- … … 91 105 & tabspongedone_trn(jpi,jpj), & 92 106 # endif 93 # if defined key_vertical94 107 & ht0_parent(jpi,jpj), mbkt_parent(jpi,jpj), & 95 108 & hu0_parent(jpi,jpj), mbku_parent(jpi,jpj), & 96 109 & hv0_parent(jpi,jpj), mbkv_parent(jpi,jpj), & 97 # endif98 110 & tabspongedone_u (jpi,jpj), & 99 111 & tabspongedone_v (jpi,jpj), STAT = ierr(1) ) -
NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_interp.F90
r12377 r13540 34 34 USE lib_mpp 35 35 USE vremap 36 USE lbclnk 36 37 37 38 IMPLICIT NONE … … 43 44 PUBLIC interptsn, interpsshn, interpavm 44 45 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b 45 PUBLIC interpe3t 46 #if defined key_vertical 46 PUBLIC interpe3t, interpglamt, interpgphit 47 47 PUBLIC interpht0, interpmbkt 48 # endif 48 PUBLIC agrif_initts, agrif_initssh 49 49 50 INTEGER :: bdy_tinterp = 0 50 51 … … 86 87 IF( Agrif_Root() ) RETURN 87 88 ! 88 Agrif_SpecialValue = 0. _wp89 Agrif_SpecialValue = 0.0_wp 89 90 Agrif_UseSpecialValue = ln_spc_dyn 90 91 ! 92 use_sign_north = .TRUE. 93 sign_north = -1.0_wp 91 94 CALL Agrif_Bc_variable( un_interp_id, procname=interpun ) 92 95 CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn ) 96 use_sign_north = .FALSE. 93 97 ! 94 98 Agrif_UseSpecialValue = .FALSE. 95 99 ! 96 100 ! --- West --- ! 97 ibdy1 = 2 98 ibdy2 = 1+nbghostcells 99 ! 100 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 101 IF( lk_west ) THEN 102 ibdy1 = nn_hls + 2 ! halo + land + 1 103 ibdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 104 ! 105 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 106 DO ji = mi0(ibdy1), mi1(ibdy2) 107 uu_b(ji,:,Krhs_a) = 0._wp 108 DO jk = 1, jpkm1 109 DO jj = 1, jpj 110 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) 111 END DO 112 END DO 113 DO jj = 1, jpj 114 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 115 END DO 116 END DO 117 ENDIF 118 ! 101 119 DO ji = mi0(ibdy1), mi1(ibdy2) 102 uu_b(ji,:,Krhs_a) = 0._wp 103 120 zub(ji,:) = 0._wp ! Correct transport 104 121 DO jk = 1, jpkm1 105 122 DO jj = 1, jpj 106 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) 107 END DO 108 END DO 109 110 DO jj = 1, jpj 111 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 112 END DO 113 END DO 114 ENDIF 115 ! 116 DO ji = mi0(ibdy1), mi1(ibdy2) 117 zub(ji,:) = 0._wp ! Correct transport 118 DO jk = 1, jpkm1 119 DO jj = 1, jpj 120 zub(ji,jj) = zub(ji,jj) & 121 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a)*umask(ji,jj,jk) 122 END DO 123 END DO 124 DO jj=1,jpj 125 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 126 END DO 127 128 DO jk = 1, jpkm1 129 DO jj = 1, jpj 130 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) 131 END DO 132 END DO 133 END DO 134 135 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 136 DO ji = mi0(ibdy1), mi1(ibdy2) 137 zvb(ji,:) = 0._wp 123 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 124 END DO 125 END DO 126 DO jj=1,jpj 127 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 128 END DO 138 129 DO jk = 1, jpkm1 139 130 DO jj = 1, jpj 140 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 141 END DO 142 END DO 143 DO jj = 1, jpj 144 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 145 END DO 131 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) 132 END DO 133 END DO 134 END DO 135 ! 136 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 137 DO ji = mi0(ibdy1), mi1(ibdy2) 138 zvb(ji,:) = 0._wp 139 DO jk = 1, jpkm1 140 DO jj = 1, jpj 141 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 142 END DO 143 END DO 144 DO jj = 1, jpj 145 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 146 END DO 147 DO jk = 1, jpkm1 148 DO jj = 1, jpj 149 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) 150 END DO 151 END DO 152 END DO 153 ENDIF 154 ! 155 ENDIF 156 157 ! --- East --- ! 158 IF( lk_east) THEN 159 ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 160 ibdy2 = jpiglo - ( nn_hls + 2 ) ! halo + land + 1 161 ! 162 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 163 DO ji = mi0(ibdy1), mi1(ibdy2) 164 uu_b(ji,:,Krhs_a) = 0._wp 165 DO jk = 1, jpkm1 166 DO jj = 1, jpj 167 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) 168 END DO 169 END DO 170 DO jj = 1, jpj 171 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 172 END DO 173 END DO 174 ENDIF 175 ! 176 DO ji = mi0(ibdy1), mi1(ibdy2) 177 zub(ji,:) = 0._wp ! Correct transport 146 178 DO jk = 1, jpkm1 147 179 DO jj = 1, jpj 148 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) 149 END DO 150 END DO 151 END DO 152 ENDIF 153 154 ! --- East --- ! 155 ibdy1 = jpiglo-1-nbghostcells 156 ibdy2 = jpiglo-2 157 ! 158 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 159 DO ji = mi0(ibdy1), mi1(ibdy2) 160 uu_b(ji,:,Krhs_a) = 0._wp 180 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 181 END DO 182 END DO 183 DO jj=1,jpj 184 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 185 END DO 161 186 DO jk = 1, jpkm1 162 187 DO jj = 1, jpj 163 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) & 164 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 165 END DO 166 END DO 167 DO jj = 1, jpj 168 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 169 END DO 170 END DO 171 ENDIF 172 ! 173 DO ji = mi0(ibdy1), mi1(ibdy2) 174 zub(ji,:) = 0._wp ! Correct transport 175 DO jk = 1, jpkm1 176 DO jj = 1, jpj 177 zub(ji,jj) = zub(ji,jj) & 178 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 179 END DO 180 END DO 181 DO jj=1,jpj 182 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 183 END DO 184 185 DO jk = 1, jpkm1 186 DO jj = 1, jpj 187 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 188 & + uu_b(ji,jj,Krhs_a)-zub(ji,jj))*umask(ji,jj,jk) 189 END DO 190 END DO 191 END DO 192 193 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 194 ibdy1 = jpiglo-nbghostcells 195 ibdy2 = jpiglo-1 196 DO ji = mi0(ibdy1), mi1(ibdy2) 197 zvb(ji,:) = 0._wp 198 DO jk = 1, jpkm1 188 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) 189 END DO 190 END DO 191 END DO 192 ! 193 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 194 ibdy1 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 195 ibdy2 = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 196 DO ji = mi0(ibdy1), mi1(ibdy2) 197 zvb(ji,:) = 0._wp 198 DO jk = 1, jpkm1 199 DO jj = 1, jpj 200 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 201 END DO 202 END DO 199 203 DO jj = 1, jpj 200 zvb(ji,jj) = zvb(ji,jj) & 201 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 202 END DO 203 END DO 204 DO jj = 1, jpj 204 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 205 END DO 206 DO jk = 1, jpkm1 207 DO jj = 1, jpj 208 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) 209 END DO 210 END DO 211 END DO 212 ENDIF 213 ! 214 ENDIF 215 216 ! --- South --- ! 217 IF( lk_south ) THEN 218 jbdy1 = nn_hls + 2 ! halo + land + 1 219 jbdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 220 ! 221 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 222 DO jj = mj0(jbdy1), mj1(jbdy2) 223 vv_b(:,jj,Krhs_a) = 0._wp 224 DO jk = 1, jpkm1 225 DO ji = 1, jpi 226 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) 227 END DO 228 END DO 229 DO ji=1,jpi 230 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 231 END DO 232 END DO 233 ENDIF 234 ! 235 DO jj = mj0(jbdy1), mj1(jbdy2) 236 zvb(:,jj) = 0._wp ! Correct transport 237 DO jk=1,jpkm1 238 DO ji=1,jpi 239 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 240 END DO 241 END DO 242 DO ji = 1, jpi 205 243 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 206 244 END DO 207 DO jk = 1, jpkm1208 DO jj = 1, jpj209 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) &210 & + vv_b(ji,jj,Krhs_a)-zvb(ji,jj)) * vmask(ji,jj,jk)211 END DO212 END DO213 END DO214 ENDIF215 216 ! --- South --- !217 jbdy1 = 2218 jbdy2 = 1+nbghostcells219 !220 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport221 DO jj = mj0(jbdy1), mj1(jbdy2)222 vv_b(:,jj,Krhs_a) = 0._wp223 245 DO jk = 1, jpkm1 224 246 DO ji = 1, jpi 225 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) & 226 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 227 END DO 228 END DO 229 DO ji=1,jpi 230 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 231 END DO 232 END DO 233 ENDIF 234 ! 235 DO jj = mj0(jbdy1), mj1(jbdy2) 236 zvb(:,jj) = 0._wp ! Correct transport 237 DO jk=1,jpkm1 238 DO ji=1,jpi 239 zvb(ji,jj) = zvb(ji,jj) & 240 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 241 END DO 242 END DO 243 DO ji = 1, jpi 244 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 245 END DO 246 247 DO jk = 1, jpkm1 247 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) 248 END DO 249 END DO 250 END DO 251 ! 252 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 253 DO jj = mj0(jbdy1), mj1(jbdy2) 254 zub(:,jj) = 0._wp 255 DO jk = 1, jpkm1 256 DO ji = 1, jpi 257 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 258 END DO 259 END DO 260 DO ji = 1, jpi 261 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 262 END DO 263 DO jk = 1, jpkm1 264 DO ji = 1, jpi 265 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) 266 END DO 267 END DO 268 END DO 269 ENDIF 270 ! 271 ENDIF 272 273 ! --- North --- ! 274 IF( lk_north ) THEN 275 jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 276 jbdy2 = jpjglo - ( nn_hls + 2 ) ! halo + land + 1 277 ! 278 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 279 DO jj = mj0(jbdy1), mj1(jbdy2) 280 vv_b(:,jj,Krhs_a) = 0._wp 281 DO jk = 1, jpkm1 282 DO ji = 1, jpi 283 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) 284 END DO 285 END DO 286 DO ji=1,jpi 287 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 288 END DO 289 END DO 290 ENDIF 291 ! 292 DO jj = mj0(jbdy1), mj1(jbdy2) 293 zvb(:,jj) = 0._wp ! Correct transport 294 DO jk=1,jpkm1 295 DO ji=1,jpi 296 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 297 END DO 298 END DO 248 299 DO ji = 1, jpi 249 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 250 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 251 END DO 252 END DO 253 END DO 254 255 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 256 DO jj = mj0(jbdy1), mj1(jbdy2) 257 zub(:,jj) = 0._wp 300 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 301 END DO 258 302 DO jk = 1, jpkm1 259 303 DO ji = 1, jpi 260 zub(ji,jj) = zub(ji,jj) & 261 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 262 END DO 263 END DO 264 DO ji = 1, jpi 265 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 266 END DO 267 268 DO jk = 1, jpkm1 304 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) 305 END DO 306 END DO 307 END DO 308 ! 309 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 310 jbdy1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 311 jbdy2 = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 312 DO jj = mj0(jbdy1), mj1(jbdy2) 313 zub(:,jj) = 0._wp 314 DO jk = 1, jpkm1 315 DO ji = 1, jpi 316 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 317 END DO 318 END DO 269 319 DO ji = 1, jpi 270 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 271 & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 272 END DO 273 END DO 274 END DO 275 ENDIF 276 277 ! --- North --- ! 278 jbdy1 = jpjglo-1-nbghostcells 279 jbdy2 = jpjglo-2 280 ! 281 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 282 DO jj = mj0(jbdy1), mj1(jbdy2) 283 vv_b(:,jj,Krhs_a) = 0._wp 284 DO jk = 1, jpkm1 285 DO ji = 1, jpi 286 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) & 287 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 288 END DO 289 END DO 290 DO ji=1,jpi 291 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 292 END DO 293 END DO 294 ENDIF 295 ! 296 DO jj = mj0(jbdy1), mj1(jbdy2) 297 zvb(:,jj) = 0._wp ! Correct transport 298 DO jk=1,jpkm1 299 DO ji=1,jpi 300 zvb(ji,jj) = zvb(ji,jj) & 301 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 302 END DO 303 END DO 304 DO ji = 1, jpi 305 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 306 END DO 307 308 DO jk = 1, jpkm1 309 DO ji = 1, jpi 310 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 311 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 312 END DO 313 END DO 314 END DO 315 316 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 317 jbdy1 = jpjglo-nbghostcells 318 jbdy2 = jpjglo-1 319 DO jj = mj0(jbdy1), mj1(jbdy2) 320 zub(:,jj) = 0._wp 321 DO jk = 1, jpkm1 322 DO ji = 1, jpi 323 zub(ji,jj) = zub(ji,jj) & 324 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 325 END DO 326 END DO 327 DO ji = 1, jpi 328 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 329 END DO 330 331 DO jk = 1, jpkm1 332 DO ji = 1, jpi 333 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 334 & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 335 END DO 336 END DO 337 END DO 320 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 321 END DO 322 DO jk = 1, jpkm1 323 DO ji = 1, jpi 324 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) 325 END DO 326 END DO 327 END DO 328 ENDIF 329 ! 338 330 ENDIF 339 331 ! … … 354 346 ! 355 347 !--- West ---! 356 istart = 2 357 iend = nbghostcells+1 358 DO ji = mi0(istart), mi1(iend) 359 DO jj=1,jpj 360 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 361 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 362 END DO 363 END DO 348 IF( lk_west ) THEN 349 istart = nn_hls + 2 ! halo + land + 1 350 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 351 DO ji = mi0(istart), mi1(iend) 352 DO jj=1,jpj 353 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 354 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 355 END DO 356 END DO 357 ENDIF 364 358 ! 365 359 !--- East ---! 366 istart = jpiglo-nbghostcells 367 iend = jpiglo-1 368 DO ji = mi0(istart), mi1(iend) 369 DO jj=1,jpj 370 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 371 END DO 372 END DO 373 istart = jpiglo-nbghostcells-1 374 iend = jpiglo-2 375 DO ji = mi0(istart), mi1(iend) 376 DO jj=1,jpj 377 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 378 END DO 379 END DO 360 IF( lk_east ) THEN 361 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 362 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 363 DO ji = mi0(istart), mi1(iend) 364 365 DO jj=1,jpj 366 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 367 END DO 368 END DO 369 istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 370 iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1 371 DO ji = mi0(istart), mi1(iend) 372 DO jj=1,jpj 373 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 374 END DO 375 END DO 376 ENDIF 380 377 ! 381 378 !--- South ---! 382 jstart = 2 383 jend = nbghostcells+1 384 DO jj = mj0(jstart), mj1(jend) 385 DO ji=1,jpi 386 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 387 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 388 END DO 389 END DO 379 IF( lk_south ) THEN 380 jstart = nn_hls + 2 ! halo + land + 1 381 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 382 DO jj = mj0(jstart), mj1(jend) 383 384 DO ji=1,jpi 385 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 386 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 387 END DO 388 END DO 389 ENDIF 390 390 ! 391 391 !--- North ---! 392 jstart = jpjglo-nbghostcells 393 jend = jpjglo-1 394 DO jj = mj0(jstart), mj1(jend) 395 DO ji=1,jpi 396 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 397 END DO 398 END DO 399 jstart = jpjglo-nbghostcells-1 400 jend = jpjglo-2 401 DO jj = mj0(jstart), mj1(jend) 402 DO ji=1,jpi 403 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 404 END DO 405 END DO 392 IF( lk_north ) THEN 393 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 394 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 395 DO jj = mj0(jstart), mj1(jend) 396 DO ji=1,jpi 397 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 398 END DO 399 END DO 400 jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 401 jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1 402 DO jj = mj0(jstart), mj1(jend) 403 DO ji=1,jpi 404 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 405 END DO 406 END DO 407 ENDIF 406 408 ! 407 409 END SUBROUTINE Agrif_dyn_ts 408 410 411 409 412 SUBROUTINE Agrif_dyn_ts_flux( jn, zu, zv ) 410 413 !!---------------------------------------------------------------------- … … 421 424 ! 422 425 !--- West ---! 423 istart = 2 424 iend = nbghostcells+1 425 DO ji = mi0(istart), mi1(iend) 426 DO jj=1,jpj 427 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 428 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 429 END DO 430 END DO 426 IF( lk_west ) THEN 427 istart = nn_hls + 2 ! halo + land + 1 428 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 429 DO ji = mi0(istart), mi1(iend) 430 DO jj=1,jpj 431 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 432 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 433 END DO 434 END DO 435 ENDIF 431 436 ! 432 437 !--- East ---! 433 istart = jpiglo-nbghostcells 434 iend = jpiglo-1 435 DO ji = mi0(istart), mi1(iend) 436 DO jj=1,jpj 437 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 438 END DO 439 END DO 440 istart = jpiglo-nbghostcells-1 441 iend = jpiglo-2 442 DO ji = mi0(istart), mi1(iend) 443 DO jj=1,jpj 444 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 445 END DO 446 END DO 438 IF( lk_east ) THEN 439 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 440 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 441 DO ji = mi0(istart), mi1(iend) 442 DO jj=1,jpj 443 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 444 END DO 445 END DO 446 istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 447 iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1 448 DO ji = mi0(istart), mi1(iend) 449 DO jj=1,jpj 450 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 451 END DO 452 END DO 453 ENDIF 447 454 ! 448 455 !--- South ---! 449 jstart = 2 450 jend = nbghostcells+1 451 DO jj = mj0(jstart), mj1(jend) 452 DO ji=1,jpi 453 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 454 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 455 END DO 456 END DO 456 IF( lk_south ) THEN 457 jstart = nn_hls + 2 ! halo + land + 1 458 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 459 DO jj = mj0(jstart), mj1(jend) 460 DO ji=1,jpi 461 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 462 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 463 END DO 464 END DO 465 ENDIF 457 466 ! 458 467 !--- North ---! 459 jstart = jpjglo-nbghostcells 460 jend = jpjglo-1 461 DO jj = mj0(jstart), mj1(jend) 462 DO ji=1,jpi 463 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 464 END DO 465 END DO 466 jstart = jpjglo-nbghostcells-1 467 jend = jpjglo-2 468 DO jj = mj0(jstart), mj1(jend) 469 DO ji=1,jpi 470 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 471 END DO 472 END DO 468 IF( lk_north ) THEN 469 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 470 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 471 DO jj = mj0(jstart), mj1(jend) 472 DO ji=1,jpi 473 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 474 END DO 475 END DO 476 jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 477 jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1 478 DO jj = mj0(jstart), mj1(jend) 479 DO ji=1,jpi 480 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 481 END DO 482 END DO 483 ENDIF 473 484 ! 474 485 END SUBROUTINE Agrif_dyn_ts_flux 475 486 487 476 488 SUBROUTINE Agrif_dta_ts( kt ) 477 489 !!---------------------------------------------------------------------- … … 494 506 Agrif_SpecialValue = 0._wp 495 507 Agrif_UseSpecialValue = ln_spc_dyn 508 509 use_sign_north = .TRUE. 510 sign_north = -1. 511 496 512 ! 497 513 ! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners) … … 518 534 ENDIF 519 535 Agrif_UseSpecialValue = .FALSE. 536 use_sign_north = .FALSE. 520 537 ! 521 538 END SUBROUTINE Agrif_dta_ts … … 542 559 ! 543 560 ! --- West --- ! 544 istart = 2 545 iend = 1 + nbghostcells 546 DO ji = mi0(istart), mi1(iend) 547 DO jj = 1, jpj 548 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 549 ENDDO 550 ENDDO 561 IF(lk_west) THEN 562 istart = nn_hls + 2 ! halo + land + 1 563 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 564 DO ji = mi0(istart), mi1(iend) 565 DO jj = 1, jpj 566 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 567 END DO 568 END DO 569 ENDIF 551 570 ! 552 571 ! --- East --- ! 553 istart = jpiglo - nbghostcells 554 iend = jpiglo - 1 555 DO ji = mi0(istart), mi1(iend) 556 DO jj = 1, jpj 557 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 558 ENDDO 559 ENDDO 572 IF(lk_east) THEN 573 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 574 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 575 DO ji = mi0(istart), mi1(iend) 576 DO jj = 1, jpj 577 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 578 END DO 579 END DO 580 ENDIF 560 581 ! 561 582 ! --- South --- ! 562 jstart = 2 563 jend = 1 + nbghostcells 564 DO jj = mj0(jstart), mj1(jend) 565 DO ji = 1, jpi 566 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 567 ENDDO 568 ENDDO 583 IF(lk_south) THEN 584 jstart = nn_hls + 2 ! halo + land + 1 585 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 586 DO jj = mj0(jstart), mj1(jend) 587 DO ji = 1, jpi 588 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 589 END DO 590 END DO 591 ENDIF 569 592 ! 570 593 ! --- North --- ! 571 jstart = jpjglo - nbghostcells 572 jend = jpjglo - 1 573 DO jj = mj0(jstart), mj1(jend) 574 DO ji = 1, jpi 575 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 576 ENDDO 577 ENDDO 594 IF(lk_north) THEN 595 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 596 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 597 DO jj = mj0(jstart), mj1(jend) 598 DO ji = 1, jpi 599 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 600 END DO 601 END DO 602 ENDIF 578 603 ! 579 604 END SUBROUTINE Agrif_ssh … … 593 618 ! 594 619 ! --- West --- ! 595 istart = 2 596 iend = 1+nbghostcells 597 DO ji = mi0(istart), mi1(iend) 598 DO jj = 1, jpj 599 ssha_e(ji,jj) = hbdy(ji,jj) 600 ENDDO 601 ENDDO 620 IF(lk_west) THEN 621 istart = nn_hls + 2 ! halo + land + 1 622 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 623 DO ji = mi0(istart), mi1(iend) 624 DO jj = 1, jpj 625 ssha_e(ji,jj) = hbdy(ji,jj) 626 END DO 627 END DO 628 ENDIF 602 629 ! 603 630 ! --- East --- ! 604 istart = jpiglo - nbghostcells 605 iend = jpiglo - 1 606 DO ji = mi0(istart), mi1(iend) 607 DO jj = 1, jpj 608 ssha_e(ji,jj) = hbdy(ji,jj) 609 ENDDO 610 ENDDO 631 IF(lk_east) THEN 632 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 633 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 634 DO ji = mi0(istart), mi1(iend) 635 DO jj = 1, jpj 636 ssha_e(ji,jj) = hbdy(ji,jj) 637 END DO 638 END DO 639 ENDIF 611 640 ! 612 641 ! --- South --- ! 613 jstart = 2 614 jend = 1+nbghostcells 615 DO jj = mj0(jstart), mj1(jend) 616 DO ji = 1, jpi 617 ssha_e(ji,jj) = hbdy(ji,jj) 618 ENDDO 619 ENDDO 642 IF(lk_south) THEN 643 jstart = nn_hls + 2 ! halo + land + 1 644 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 645 DO jj = mj0(jstart), mj1(jend) 646 DO ji = 1, jpi 647 ssha_e(ji,jj) = hbdy(ji,jj) 648 END DO 649 END DO 650 ENDIF 620 651 ! 621 652 ! --- North --- ! 622 jstart = jpjglo - nbghostcells 623 jend = jpjglo - 1 624 DO jj = mj0(jstart), mj1(jend) 625 DO ji = 1, jpi 626 ssha_e(ji,jj) = hbdy(ji,jj) 627 ENDDO 628 ENDDO 653 IF(lk_north) THEN 654 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 655 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 656 DO jj = mj0(jstart), mj1(jend) 657 DO ji = 1, jpi 658 ssha_e(ji,jj) = hbdy(ji,jj) 659 END DO 660 END DO 661 ENDIF 629 662 ! 630 663 END SUBROUTINE Agrif_ssh_ts 631 664 665 632 666 SUBROUTINE Agrif_avm 633 667 !!---------------------------------------------------------------------- … … 650 684 ! 651 685 END SUBROUTINE Agrif_avm 652 686 653 687 654 688 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) … … 662 696 INTEGER :: ji, jj, jk, jn ! dummy loop indices 663 697 INTEGER :: N_in, N_out 698 INTEGER :: item 664 699 ! vertical interpolation: 665 700 REAL(wp) :: zhtot 666 701 REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin 667 REAL(wp), DIMENSION(k1:k2) :: h_in 668 REAL(wp), DIMENSION(1:jpk) :: h_out 669 !!---------------------------------------------------------------------- 670 671 IF( before ) THEN 702 REAL(wp), DIMENSION(k1:k2) :: h_in, z_in 703 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 704 !!---------------------------------------------------------------------- 705 706 IF( before ) THEN 707 708 item = Kmm_a 709 IF( l_ini_child ) Kmm_a = Kbb_a 710 672 711 DO jn = 1,jpts 673 712 DO jk=k1,k2 … … 678 717 END DO 679 718 END DO 680 END DO 681 682 # if defined key_vertical 683 ! Interpolate thicknesses 684 ! Warning: these are masked, hence extrapolated prior interpolation. 685 DO jk=k1,k2 686 DO jj=j1,j2 687 DO ji=i1,i2 688 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 689 END DO 690 END DO 691 END DO 692 693 ! Extrapolate thicknesses in partial bottom cells: 694 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 695 IF (ln_zps) THEN 696 DO jj=j1,j2 697 DO ji=i1,i2 698 jk = mbkt(ji,jj) 699 ptab(ji,jj,jk,jpts+1) = 0._wp 700 END DO 701 END DO 702 END IF 703 704 ! Save ssh at last level: 705 IF (.NOT.ln_linssh) THEN 706 ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 707 ELSE 708 ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp 709 END IF 710 # endif 719 END DO 720 721 IF( l_vremap .OR. l_ini_child) THEN 722 ! Interpolate thicknesses 723 ! Warning: these are masked, hence extrapolated prior interpolation. 724 DO jk=k1,k2 725 DO jj=j1,j2 726 DO ji=i1,i2 727 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 728 729 END DO 730 END DO 731 END DO 732 733 ! Extrapolate thicknesses in partial bottom cells: 734 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 735 IF (ln_zps) THEN 736 DO jj=j1,j2 737 DO ji=i1,i2 738 jk = mbkt(ji,jj) 739 ptab(ji,jj,jk,jpts+1) = 0._wp 740 END DO 741 END DO 742 END IF 743 744 ! Save ssh at last level: 745 IF (.NOT.ln_linssh) THEN 746 ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 747 ELSE 748 ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp 749 END IF 750 ENDIF 751 Kmm_a = item 752 711 753 ELSE 712 713 # if defined key_vertical 714 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 715 716 DO jj=j1,j2 717 DO ji=i1,i2 718 ts(ji,jj,:,:,Krhs_a) = 0._wp 719 N_in = mbkt_parent(ji,jj) 720 zhtot = 0._wp 721 DO jk=1,N_in !k2 = jpk of parent grid 722 IF (jk==N_in) THEN 723 h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot 724 ELSE 725 h_in(jk) = ptab(ji,jj,jk,n2) 754 item = Krhs_a 755 IF( l_ini_child ) Krhs_a = Kbb_a 756 757 IF( l_vremap .OR. l_ini_child ) THEN 758 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 759 760 DO jj=j1,j2 761 DO ji=i1,i2 762 ts(ji,jj,:,:,Krhs_a) = 0. 763 ! IF( l_ini_child) ts(ji,jj,:,:,Krhs_a) = ptab(ji,jj,:,1:jpts) 764 N_in = mbkt_parent(ji,jj) 765 zhtot = 0._wp 766 DO jk=1,N_in !k2 = jpk of parent grid 767 IF (jk==N_in) THEN 768 h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot 769 ELSE 770 h_in(jk) = ptab(ji,jj,jk,n2) 771 ENDIF 772 zhtot = zhtot + h_in(jk) 773 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 774 END DO 775 z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj) 776 DO jk=2,N_in 777 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 778 END DO 779 780 N_out = 0 781 DO jk=1,jpk ! jpk of child grid 782 IF (tmask(ji,jj,jk) == 0._wp) EXIT 783 N_out = N_out + 1 784 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 785 END DO 786 787 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj) 788 DO jk=2,N_out 789 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 790 END DO 791 792 IF (N_in*N_out > 0) THEN 793 IF( l_ini_child ) THEN 794 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 795 & z_out(1:N_out),N_in,N_out,jpts) 796 ELSE 797 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 798 & h_out(1:N_out),N_in,N_out,jpts) 799 ENDIF 726 800 ENDIF 727 zhtot = zhtot + h_in(jk) 728 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 729 END DO 730 N_out = 0 731 DO jk=1,jpk ! jpk of child grid 732 IF (tmask(ji,jj,jk) == 0._wp) EXIT 733 N_out = N_out + 1 734 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 735 ENDDO 736 IF (N_in*N_out > 0) THEN 737 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a),h_out(1:N_out),N_in,N_out,jpts) 738 ENDIF 739 ENDDO 740 ENDDO 741 # else 742 ! 743 DO jn=1, jpts 744 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) 745 END DO 746 # endif 801 END DO 802 END DO 803 Krhs_a = item 804 805 ELSE 806 807 DO jn=1, jpts 808 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) 809 END DO 810 ENDIF 747 811 748 812 ENDIF … … 750 814 END SUBROUTINE interptsn 751 815 816 752 817 SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before ) 753 818 !!---------------------------------------------------------------------- … … 768 833 END SUBROUTINE interpsshn 769 834 835 770 836 SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 771 837 !!---------------------------------------------------------------------- … … 780 846 REAL(wp) :: zrhoy, zhtot 781 847 ! vertical interpolation: 782 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 783 REAL(wp), DIMENSION(1:jpk) :: h_out 784 INTEGER :: N_in, N_out 848 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in 849 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 850 INTEGER :: N_in, N_out,item 785 851 REAL(wp) :: h_diff 786 852 !!--------------------------------------------- 787 853 ! 788 854 IF (before) THEN 855 856 item = Kmm_a 857 IF( l_ini_child ) Kmm_a = Kbb_a 858 789 859 DO jk=1,jpk 790 860 DO jj=j1,j2 791 861 DO ji=i1,i2 792 862 ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) * uu(ji,jj,jk,Kmm_a)*umask(ji,jj,jk)) 793 # if defined key_vertical 794 ! Interpolate thicknesses (masked for subsequent extrapolation) 795 ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 796 # endif 797 END DO 798 END DO 799 END DO 800 # if defined key_vertical 863 IF( l_vremap .OR. l_ini_child) THEN 864 ! Interpolate thicknesses (masked for subsequent extrapolation) 865 ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 866 ENDIF 867 END DO 868 END DO 869 END DO 870 871 IF( l_vremap .OR. l_ini_child) THEN 801 872 ! Extrapolate thicknesses in partial bottom cells: 802 873 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 803 IF (ln_zps) THEN 804 DO jj=j1,j2 805 DO ji=i1,i2 806 jk = mbku(ji,jj) 807 ptab(ji,jj,jk,2) = 0._wp 808 END DO 809 END DO 810 END IF 811 ! Save ssh at last level: 812 ptab(i1:i2,j1:j2,k2,2) = 0._wp 813 IF (.NOT.ln_linssh) THEN 814 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 815 DO jk=1,jpk 816 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3u(i1:i2,j1:j2,jk,Kmm_a) * umask(i1:i2,j1:j2,jk) 817 END DO 818 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2) 819 END IF 820 # endif 874 IF (ln_zps) THEN 875 DO jj=j1,j2 876 DO ji=i1,i2 877 jk = mbku(ji,jj) 878 ptab(ji,jj,jk,2) = 0._wp 879 END DO 880 END DO 881 END IF 882 883 ! Save ssh at last level: 884 ptab(i1:i2,j1:j2,k2,2) = 0._wp 885 IF (.NOT.ln_linssh) THEN 886 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 887 DO jk=1,jpk 888 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3u(i1:i2,j1:j2,jk,Kmm_a) * umask(i1:i2,j1:j2,jk) 889 END DO 890 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2) 891 END IF 892 ENDIF 893 894 Kmm_a = item 821 895 ! 822 896 ELSE 823 897 zrhoy = Agrif_rhoy() 824 # if defined key_vertical 898 899 IF( l_vremap .OR. l_ini_child) THEN 825 900 ! VERTICAL REFINEMENT BEGIN 826 901 827 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 828 829 DO ji=i1,i2 830 DO jj=j1,j2 831 uu(ji,jj,:,Krhs_a) = 0._wp 832 N_in = mbku_parent(ji,jj) 833 zhtot = 0._wp 834 DO jk=1,N_in 835 IF (jk==N_in) THEN 836 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 837 ELSE 838 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 839 ENDIF 840 zhtot = zhtot + h_in(jk) 841 tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk)) 842 ENDDO 843 844 N_out = 0 845 DO jk=1,jpk 846 if (umask(ji,jj,jk) == 0) EXIT 847 N_out = N_out + 1 848 h_out(N_out) = e3u(ji,jj,jk,Krhs_a) 849 ENDDO 850 IF (N_in*N_out > 0) THEN 851 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 852 ENDIF 853 ENDDO 854 ENDDO 855 856 # else 857 DO jk = 1, jpkm1 858 DO jj=j1,j2 859 uu(i1:i2,jj,jk,Krhs_a) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u(i1:i2,jj,jk,Krhs_a) ) 860 END DO 861 END DO 862 # endif 902 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 903 904 DO ji=i1,i2 905 DO jj=j1,j2 906 uu(ji,jj,:,Krhs_a) = 0._wp 907 N_in = mbku_parent(ji,jj) 908 zhtot = 0._wp 909 DO jk=1,N_in 910 IF (jk==N_in) THEN 911 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 912 ELSE 913 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 914 ENDIF 915 zhtot = zhtot + h_in(jk) 916 IF( h_in(jk) .GT. 0. ) THEN 917 tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk)) 918 ELSE 919 tabin(jk) = 0. 920 ENDIF 921 END DO 922 z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 923 DO jk=2,N_in 924 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 925 END DO 926 927 N_out = 0 928 DO jk=1,jpk 929 IF (umask(ji,jj,jk) == 0) EXIT 930 N_out = N_out + 1 931 h_out(N_out) = e3u(ji,jj,jk,Krhs_a) 932 END DO 933 934 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj) 935 DO jk=2,N_out 936 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 937 END DO 938 939 IF (N_in*N_out > 0) THEN 940 IF( l_ini_child ) THEN 941 CALL remap_linear (tabin(1:N_in),z_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1) 942 ELSE 943 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 944 ENDIF 945 ENDIF 946 END DO 947 END DO 948 ELSE 949 DO jk = 1, jpkm1 950 DO jj=j1,j2 951 uu(i1:i2,jj,jk,Krhs_a) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u(i1:i2,jj,jk,Krhs_a) ) 952 END DO 953 END DO 954 ENDIF 863 955 864 956 ENDIF … … 866 958 END SUBROUTINE interpun 867 959 960 868 961 SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 869 962 !!---------------------------------------------------------------------- … … 878 971 REAL(wp) :: zrhox 879 972 ! vertical interpolation: 880 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 881 REAL(wp), DIMENSION(1:jpk) :: h_out 882 INTEGER :: N_in, N_out 973 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in 974 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 975 INTEGER :: N_in, N_out, item 883 976 REAL(wp) :: h_diff, zhtot 884 977 !!--------------------------------------------- 885 978 ! 886 IF (before) THEN 979 IF (before) THEN 980 981 item = Kmm_a 982 IF( l_ini_child ) Kmm_a = Kbb_a 983 887 984 DO jk=k1,k2 888 985 DO jj=j1,j2 889 986 DO ji=i1,i2 890 987 ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) * vv(ji,jj,jk,Kmm_a)*vmask(ji,jj,jk)) 891 # if defined key_vertical 892 ! Interpolate thicknesses (masked for subsequent extrapolation) 893 ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 894 # endif 895 END DO 896 END DO 897 END DO 898 # if defined key_vertical 988 IF( l_vremap .OR. l_ini_child) THEN 989 ! Interpolate thicknesses (masked for subsequent extrapolation) 990 ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 991 ENDIF 992 END DO 993 END DO 994 END DO 995 996 IF( l_vremap .OR. l_ini_child) THEN 899 997 ! Extrapolate thicknesses in partial bottom cells: 900 998 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 901 IF (ln_zps) THEN 999 IF (ln_zps) THEN 1000 DO jj=j1,j2 1001 DO ji=i1,i2 1002 jk = mbkv(ji,jj) 1003 ptab(ji,jj,jk,2) = 0._wp 1004 END DO 1005 END DO 1006 END IF 1007 ! Save ssh at last level: 1008 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1009 IF (.NOT.ln_linssh) THEN 1010 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 1011 DO jk=1,jpk 1012 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk) 1013 END DO 1014 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2) 1015 END IF 1016 ENDIF 1017 item = Kmm_a 1018 1019 ELSE 1020 zrhox = Agrif_rhox() 1021 1022 IF( l_vremap .OR. l_ini_child ) THEN 1023 1024 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1025 902 1026 DO jj=j1,j2 903 1027 DO ji=i1,i2 904 jk = mbkv(ji,jj) 905 ptab(ji,jj,jk,2) = 0._wp 906 END DO 907 END DO 908 END IF 909 ! Save ssh at last level: 910 ptab(i1:i2,j1:j2,k2,2) = 0._wp 911 IF (.NOT.ln_linssh) THEN 912 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 913 DO jk=1,jpk 914 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) + e3v(i1:i2,j1:j2,jk,Kmm_a) * vmask(i1:i2,j1:j2,jk) 915 END DO 916 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2) 917 END IF 918 # endif 919 ELSE 920 zrhox = Agrif_rhox() 921 # if defined key_vertical 922 923 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 924 925 DO jj=j1,j2 926 DO ji=i1,i2 927 vv(ji,jj,:,Krhs_a) = 0._wp 928 N_in = mbkv_parent(ji,jj) 929 zhtot = 0._wp 930 DO jk=1,N_in 931 IF (jk==N_in) THEN 932 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 933 ELSE 934 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1028 vv(ji,jj,:,Krhs_a) = 0._wp 1029 N_in = mbkv_parent(ji,jj) 1030 zhtot = 0._wp 1031 DO jk=1,N_in 1032 IF (jk==N_in) THEN 1033 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1034 ELSE 1035 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1036 ENDIF 1037 zhtot = zhtot + h_in(jk) 1038 IF( h_in(jk) .GT. 0. ) THEN 1039 tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk)) 1040 ELSE 1041 tabin(jk) = 0. 1042 ENDIF 1043 END DO 1044 1045 z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj) 1046 DO jk=2,N_in 1047 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 1048 END DO 1049 1050 N_out = 0 1051 DO jk=1,jpk 1052 IF (vmask(ji,jj,jk) == 0) EXIT 1053 N_out = N_out + 1 1054 h_out(N_out) = e3v(ji,jj,jk,Krhs_a) 1055 END DO 1056 1057 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj) 1058 DO jk=2,N_out 1059 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 1060 END DO 1061 1062 IF (N_in*N_out > 0) THEN 1063 IF( l_ini_child ) THEN 1064 CALL remap_linear (tabin(1:N_in),z_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1) 1065 ELSE 1066 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 1067 ENDIF 935 1068 ENDIF 936 zhtot = zhtot + h_in(jk) 937 tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk)) 938 ENDDO 939 940 N_out = 0 941 DO jk=1,jpk 942 if (vmask(ji,jj,jk) == 0) EXIT 943 N_out = N_out + 1 944 h_out(N_out) = e3v(ji,jj,jk,Krhs_a) 945 END DO 946 IF (N_in*N_out > 0) THEN 947 call reconstructandremap(tabin(1:N_in),h_in(1:N_in),vv(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 948 ENDIF 949 END DO 950 END DO 951 # else 952 DO jk = 1, jpkm1 953 vv(i1:i2,j1:j2,jk,Krhs_a) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Krhs_a) ) 954 END DO 955 # endif 1069 END DO 1070 END DO 1071 ELSE 1072 DO jk = 1, jpkm1 1073 vv(i1:i2,j1:j2,jk,Krhs_a) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v(i1:i2,j1:j2,jk,Krhs_a) ) 1074 END DO 1075 ENDIF 956 1076 ENDIF 957 1077 ! … … 1152 1272 WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', & 1153 1273 & ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), & 1154 & ji+nimpp-1, jj+njmpp-1, jk1155 kindic_agr = kindic_agr + 11274 & mig0(ji), mig0(jj), jk 1275 ! kindic_agr = kindic_agr + 1 1156 1276 ENDIF 1157 1277 END DO … … 1162 1282 ! 1163 1283 END SUBROUTINE interpe3t 1284 1285 SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before ) 1286 !!---------------------------------------------------------------------- 1287 !! *** ROUTINE interpglamt *** 1288 !!---------------------------------------------------------------------- 1289 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1290 REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1291 LOGICAL , INTENT(in ) :: before 1292 ! 1293 INTEGER :: ji, jj, jk 1294 REAL(wp):: ztst 1295 !!---------------------------------------------------------------------- 1296 ! 1297 IF( before ) THEN 1298 ptab(i1:i2,j1:j2) = glamt(i1:i2,j1:j2) 1299 ELSE 1300 ztst = MAXVAL(ABS(glamt(i1:i2,j1:j2)))*1.e-4 1301 DO jj = j1, j2 1302 DO ji = i1, i2 1303 IF( ABS( ptab(ji,jj) - glamt(ji,jj) ) > ztst ) THEN 1304 WRITE(numout,*) ' Agrif error for glamt: parent, child, i, j ', ptab(ji,jj), glamt(ji,jj), mig0(ji), mig0(jj) 1305 ! kindic_agr = kindic_agr + 1 1306 ENDIF 1307 END DO 1308 END DO 1309 ENDIF 1310 ! 1311 END SUBROUTINE interpglamt 1312 1313 1314 SUBROUTINE interpgphit( ptab, i1, i2, j1, j2, before ) 1315 !!---------------------------------------------------------------------- 1316 !! *** ROUTINE interpgphit *** 1317 !!---------------------------------------------------------------------- 1318 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1319 REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1320 LOGICAL , INTENT(in ) :: before 1321 ! 1322 INTEGER :: ji, jj, jk 1323 REAL(wp):: ztst 1324 !!---------------------------------------------------------------------- 1325 ! 1326 IF( before ) THEN 1327 ptab(i1:i2,j1:j2) = gphit(i1:i2,j1:j2) 1328 ELSE 1329 ztst = MAXVAL(ABS(gphit(i1:i2,j1:j2)))*1.e-4 1330 DO jj = j1, j2 1331 DO ji = i1, i2 1332 IF( ABS( ptab(ji,jj) - gphit(ji,jj) ) > ztst ) THEN 1333 WRITE(numout,*) ' Agrif error for gphit: parent, child, i, j ', ptab(ji,jj), gphit(ji,jj), mig0(ji), mig0(jj) 1334 ! kindic_agr = kindic_agr + 1 1335 ENDIF 1336 END DO 1337 END DO 1338 ENDIF 1339 ! 1340 END SUBROUTINE interpgphit 1164 1341 1165 1342 … … 1185 1362 END DO 1186 1363 END DO 1187 END DO 1188 1189 # if defined key_vertical 1190 ! Interpolate thicknesses 1191 ! Warning: these are masked, hence extrapolated prior interpolation. 1192 DO jk=k1,k2 1193 DO jj=j1,j2 1194 DO ji=i1,i2 1195 ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 1196 END DO 1197 END DO 1198 END DO 1199 1200 ! Extrapolate thicknesses in partial bottom cells: 1201 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 1202 IF (ln_zps) THEN 1203 DO jj=j1,j2 1204 DO ji=i1,i2 1205 jk = mbkt(ji,jj) 1206 ptab(ji,jj,jk,2) = 0._wp 1207 END DO 1208 END DO 1209 END IF 1210 1211 ! Save ssh at last level: 1212 IF (.NOT.ln_linssh) THEN 1213 ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 1214 ELSE 1215 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1216 END IF 1217 # endif 1364 END DO 1365 1366 IF( l_vremap ) THEN 1367 ! Interpolate thicknesses 1368 ! Warning: these are masked, hence extrapolated prior interpolation. 1369 DO jk=k1,k2 1370 DO jj=j1,j2 1371 DO ji=i1,i2 1372 ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 1373 END DO 1374 END DO 1375 END DO 1376 1377 ! Extrapolate thicknesses in partial bottom cells: 1378 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 1379 IF (ln_zps) THEN 1380 DO jj=j1,j2 1381 DO ji=i1,i2 1382 jk = mbkt(ji,jj) 1383 ptab(ji,jj,jk,2) = 0._wp 1384 END DO 1385 END DO 1386 END IF 1387 1388 ! Save ssh at last level: 1389 IF (.NOT.ln_linssh) THEN 1390 ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 1391 ELSE 1392 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1393 END IF 1394 ENDIF 1395 1218 1396 ELSE 1219 #ifdef key_vertical 1220 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1221 avm_k(i1:i2,j1:j2,k1:k2) = 0._wp 1222 1223 DO jj = j1, j2 1224 DO ji =i1, i2 1225 N_in = mbkt_parent(ji,jj) 1226 IF ( tmask(ji,jj,1) == 0._wp) N_in = 0 1227 z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2) 1228 DO jk = N_in, 1, -1 ! Parent vertical grid 1229 z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2) 1230 tabin(jk) = ptab(ji,jj,jk,1) 1231 END DO 1232 N_out = mbkt(ji,jj) 1233 DO jk = 1, N_out ! Child vertical grid 1234 z_out(jk) = gdepw(ji,jj,jk,Kmm_a) 1235 ENDDO 1236 IF (N_in*N_out > 0) THEN 1237 CALL remap_linear(tabin(1:N_in),z_in(1:N_in),avm_k(ji,jj,1:N_out),z_out(1:N_out),N_in,N_out,1) 1238 ENDIF 1239 ENDDO 1240 ENDDO 1241 #else 1242 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) 1243 #endif 1397 1398 IF( l_vremap ) THEN 1399 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1400 avm_k(i1:i2,j1:j2,k1:k2) = 0._wp 1401 1402 DO jj = j1, j2 1403 DO ji =i1, i2 1404 N_in = mbkt_parent(ji,jj) 1405 IF ( tmask(ji,jj,1) == 0._wp) N_in = 0 1406 z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2) 1407 DO jk = N_in, 1, -1 ! Parent vertical grid 1408 z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2) 1409 tabin(jk) = ptab(ji,jj,jk,1) 1410 END DO 1411 N_out = mbkt(ji,jj) 1412 DO jk = 1, N_out ! Child vertical grid 1413 z_out(jk) = gdepw(ji,jj,jk,Kmm_a) 1414 END DO 1415 IF (N_in*N_out > 0) THEN 1416 CALL remap_linear(tabin(1:N_in),z_in(1:N_in),avm_k(ji,jj,1:N_out),z_out(1:N_out),N_in,N_out,1) 1417 ENDIF 1418 END DO 1419 END DO 1420 ELSE 1421 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) 1422 ENDIF 1244 1423 ENDIF 1245 1424 ! 1246 1425 END SUBROUTINE interpavm 1247 1426 1248 # if defined key_vertical 1427 1249 1428 SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before ) 1250 1429 !!---------------------------------------------------------------------- … … 1265 1444 END SUBROUTINE interpmbkt 1266 1445 1446 1267 1447 SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before ) 1268 1448 !!---------------------------------------------------------------------- … … 1282 1462 ! 1283 1463 END SUBROUTINE interpht0 1284 #endif 1285 1464 1465 1466 SUBROUTINE agrif_initts(tabres,i1,i2,j1,j2,k1,k2,m1,m2,before) 1467 INTEGER :: i1, i2, j1, j2, k1, k2, m1, m2 1468 REAL(wp):: tabres(i1:i2,j1:j2,k1:k2,m1:m2) 1469 LOGICAL :: before 1470 1471 INTEGER :: jm 1472 1473 IF (before) THEN 1474 DO jm=1,jpts 1475 tabres(i1:i2,j1:j2,k1:k2,jm) = ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a) 1476 END DO 1477 ELSE 1478 DO jm=1,jpts 1479 ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a)=tabres(i1:i2,j1:j2,k1:k2,jm) 1480 END DO 1481 ENDIF 1482 END SUBROUTINE agrif_initts 1483 1484 1485 SUBROUTINE agrif_initssh( ptab, i1, i2, j1, j2, before ) 1486 !!---------------------------------------------------------------------- 1487 !! *** ROUTINE interpsshn *** 1488 !!---------------------------------------------------------------------- 1489 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1490 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1491 LOGICAL , INTENT(in ) :: before 1492 ! 1493 !!---------------------------------------------------------------------- 1494 ! 1495 IF( before) THEN 1496 ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kbb_a) 1497 ELSE 1498 ssh(i1:i2,j1:j2,Kbb_a) = ptab(i1:i2,j1:j2)*tmask(i1:i2,j1:j2,1) 1499 ENDIF 1500 ! 1501 END SUBROUTINE agrif_initssh 1502 1286 1503 #else 1287 1504 !!---------------------------------------------------------------------- -
NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_sponge.F90
r12511 r13540 78 78 zcoef = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot()) 79 79 80 Agrif_SpecialValue =0.80 Agrif_SpecialValue = 0._wp 81 81 Agrif_UseSpecialValue = ln_spc_dyn 82 use_sign_north = .TRUE. 83 sign_north = -1._wp 82 84 ! 83 85 tabspongedone_u = .FALSE. … … 90 92 ! 91 93 Agrif_UseSpecialValue = .FALSE. 94 use_sign_north = .FALSE. 92 95 #endif 93 96 ! … … 106 109 REAL(wp) :: z1_ispongearea, z1_jspongearea 107 110 REAL(wp), DIMENSION(jpi,jpj) :: ztabramp 111 #if defined key_vertical 112 REAL(wp), DIMENSION(jpi,jpj) :: ztabrampu 113 REAL(wp), DIMENSION(jpi,jpj) :: ztabrampv 114 #endif 108 115 REAL(wp), DIMENSION(jpjmax) :: zmskwest, zmskeast 109 116 REAL(wp), DIMENSION(jpimax) :: zmsknorth, zmsksouth … … 126 133 ! Retrieve masks at open boundaries: 127 134 128 ! --- West --- ! 129 ztabramp(:,:) = 0._wp 130 ind1 = 1+nbghostcells 131 DO ji = mi0(ind1), mi1(ind1) 132 ztabramp(ji,:) = ssumask(ji,:) 133 END DO 134 ! 135 zmskwest(:) = 0._wp 136 zmskwest(1:jpj) = MAXVAL(ztabramp(:,:), dim=1) 137 138 ! --- East --- ! 139 ztabramp(:,:) = 0._wp 140 ind1 = jpiglo - nbghostcells - 1 141 DO ji = mi0(ind1), mi1(ind1) 142 ztabramp(ji,:) = ssumask(ji,:) 143 END DO 144 ! 145 zmskeast(:) = 0._wp 146 zmskeast(1:jpj) = MAXVAL(ztabramp(:,:), dim=1) 147 148 ! --- South --- ! 149 ztabramp(:,:) = 0._wp 150 ind1 = 1+nbghostcells 151 DO jj = mj0(ind1), mj1(ind1) 152 ztabramp(:,jj) = ssvmask(:,jj) 153 END DO 154 ! 155 zmsksouth(:) = 0._wp 156 zmsksouth(1:jpi) = MAXVAL(ztabramp(:,:), dim=2) 157 158 ! --- North --- ! 159 ztabramp(:,:) = 0._wp 160 ind1 = jpjglo - nbghostcells - 1 161 DO jj = mj0(ind1), mj1(ind1) 162 ztabramp(:,jj) = ssvmask(:,jj) 163 END DO 164 ! 165 zmsknorth(:) = 0._wp 166 zmsknorth(1:jpi) = MAXVAL(ztabramp(:,:), dim=2) 135 IF( lk_west ) THEN ! --- West --- ! 136 ztabramp(:,:) = 0._wp 137 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 138 DO ji = mi0(ind1), mi1(ind1) 139 ztabramp(ji,:) = ssumask(ji,:) 140 END DO 141 zmskwest( 1:jpj ) = MAXVAL(ztabramp(:,:), dim=1) 142 zmskwest(jpj+1:jpjmax) = 0._wp 143 ENDIF 144 IF( lk_east ) THEN ! --- East --- ! 145 ztabramp(:,:) = 0._wp 146 ind1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 147 DO ji = mi0(ind1), mi1(ind1) 148 ztabramp(ji,:) = ssumask(ji,:) 149 END DO 150 zmskeast( 1:jpj ) = MAXVAL(ztabramp(:,:), dim=1) 151 zmskeast(jpj+1:jpjmax) = 0._wp 152 ENDIF 153 IF( lk_south ) THEN ! --- South --- ! 154 ztabramp(:,:) = 0._wp 155 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 156 DO jj = mj0(ind1), mj1(ind1) 157 ztabramp(:,jj) = ssvmask(:,jj) 158 END DO 159 zmsksouth( 1:jpi ) = MAXVAL(ztabramp(:,:), dim=2) 160 zmsksouth(jpi+1:jpimax) = 0._wp 161 ENDIF 162 IF( lk_north ) THEN ! --- North --- ! 163 ztabramp(:,:) = 0._wp 164 ind1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells 165 DO jj = mj0(ind1), mj1(ind1) 166 ztabramp(:,jj) = ssvmask(:,jj) 167 END DO 168 zmsknorth( 1:jpi ) = MAXVAL(ztabramp(:,:), dim=2) 169 zmsknorth(jpi+1:jpimax) = 0._wp 170 ENDIF 171 167 172 ! JC: SPONGE MASKING TO BE SORTED OUT: 168 173 zmskwest(:) = 1._wp 169 174 zmskeast(:) = 1._wp 175 zmsksouth(:) = 1._wp 170 176 zmsknorth(:) = 1._wp 171 zmsksouth(:) = 1._wp172 177 #if defined key_mpp_mpi 173 178 ! CALL mpp_max( 'AGRIF_sponge', zmskwest(:) , jpjmax ) … … 180 185 ! Store it in ztabramp 181 186 182 ispongearea = nn_sponge_len * Agrif_irhox()183 z1_ispongearea = 1._wp / REAL( ispongearea )184 jspongearea = nn_sponge_len * Agrif_irhoy()185 z1_jspongearea = 1._wp / REAL( jspongearea )187 ispongearea = nn_sponge_len * Agrif_irhox() 188 z1_ispongearea = 1._wp / REAL( ispongearea, wp ) 189 jspongearea = nn_sponge_len * Agrif_irhoy() 190 z1_jspongearea = 1._wp / REAL( jspongearea, wp ) 186 191 187 192 ztabramp(:,:) = 0._wp … … 191 196 IF ( nbcellsy <= 3 ) jspongearea = -1 192 197 193 ! --- West --- ! 194 ind1 = 1+nbghostcells 195 ind2 = 1+nbghostcells + ispongearea 196 DO ji = mi0(ind1), mi1(ind2) 197 DO jj = 1, jpj 198 ztabramp(ji,jj) = REAL( ind2 - mig(ji) ) * z1_ispongearea * zmskwest(jj) 199 END DO 200 END DO 201 202 ! ghost cells: 203 ind1 = 1 204 ind2 = nbghostcells + 1 205 DO ji = mi0(ind1), mi1(ind2) 206 DO jj = 1, jpj 207 ztabramp(ji,jj) = zmskwest(jj) 208 END DO 209 END DO 210 211 ! --- East --- ! 212 ind1 = jpiglo - nbghostcells - ispongearea 213 ind2 = jpiglo - nbghostcells 214 DO ji = mi0(ind1), mi1(ind2) 215 DO jj = 1, jpj 216 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mig(ji) - ind1 ) * z1_ispongearea) * zmskeast(jj) 217 ENDDO 218 END DO 219 220 ! ghost cells: 221 ind1 = jpiglo - nbghostcells 222 ind2 = jpiglo 223 DO ji = mi0(ind1), mi1(ind2) 224 DO jj = 1, jpj 225 ztabramp(ji,jj) = zmskeast(jj) 226 ENDDO 227 END DO 228 229 ! --- South --- ! 230 ind1 = 1+nbghostcells 231 ind2 = 1+nbghostcells + jspongearea 232 DO jj = mj0(ind1), mj1(ind2) 233 DO ji = 1, jpi 234 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - mjg(jj) ) * z1_jspongearea) * zmsksouth(ji) 235 END DO 236 END DO 237 238 ! ghost cells: 239 ind1 = 1 240 ind2 = nbghostcells + 1 241 DO jj = mj0(ind1), mj1(ind2) 242 DO ji = 1, jpi 243 ztabramp(ji,jj) = zmsksouth(ji) 244 END DO 245 END DO 246 247 ! --- North --- ! 248 ind1 = jpjglo - nbghostcells - jspongearea 249 ind2 = jpjglo - nbghostcells 250 DO jj = mj0(ind1), mj1(ind2) 251 DO ji = 1, jpi 252 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mjg(jj) - ind1 ) * z1_jspongearea) * zmsknorth(ji) 253 END DO 254 END DO 255 256 ! ghost cells: 257 ind1 = jpjglo - nbghostcells 258 ind2 = jpjglo 259 DO jj = mj0(ind1), mj1(ind2) 260 DO ji = 1, jpi 261 ztabramp(ji,jj) = zmsknorth(ji) 262 END DO 263 END DO 264 198 IF( lk_west ) THEN ! --- West --- ! 199 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 200 ind2 = nn_hls + 1 + nbghostcells + ispongearea 201 DO ji = mi0(ind1), mi1(ind2) 202 DO jj = 1, jpj 203 ztabramp(ji,jj) = REAL(ind2 - mig(ji), wp) * z1_ispongearea * zmskwest(jj) 204 END DO 205 END DO 206 ! ghost cells: 207 ind1 = 1 208 ind2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 209 DO ji = mi0(ind1), mi1(ind2) 210 DO jj = 1, jpj 211 ztabramp(ji,jj) = zmskwest(jj) 212 END DO 213 END DO 214 ENDIF 215 IF( lk_east ) THEN ! --- East --- ! 216 ind1 = jpiglo - ( nn_hls + nbghostcells ) - ispongearea 217 ind2 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 218 DO ji = mi0(ind1), mi1(ind2) 219 DO jj = 1, jpj 220 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mig(ji) - ind1, wp) * z1_ispongearea ) * zmskeast(jj) 221 END DO 222 END DO 223 ! ghost cells: 224 ind1 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 225 ind2 = jpiglo 226 DO ji = mi0(ind1), mi1(ind2) 227 DO jj = 1, jpj 228 ztabramp(ji,jj) = zmskeast(jj) 229 END DO 230 END DO 231 ENDIF 232 IF( lk_south ) THEN ! --- South --- ! 233 ind1 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 234 ind2 = nn_hls + 1 + nbghostcells + jspongearea 235 DO jj = mj0(ind1), mj1(ind2) 236 DO ji = 1, jpi 237 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(ind2 - mjg(jj), wp) * z1_jspongearea ) * zmsksouth(ji) 238 END DO 239 END DO 240 ! ghost cells: 241 ind1 = 1 242 ind2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells 243 DO jj = mj0(ind1), mj1(ind2) 244 DO ji = 1, jpi 245 ztabramp(ji,jj) = zmsksouth(ji) 246 END DO 247 END DO 248 ENDIF 249 IF( lk_north ) THEN ! --- North --- ! 250 ind1 = jpjglo - ( nn_hls + nbghostcells ) - jspongearea 251 ind2 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 252 DO jj = mj0(ind1), mj1(ind2) 253 DO ji = 1, jpi 254 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL(mjg(jj) - ind1, wp) * z1_jspongearea ) * zmsknorth(ji) 255 END DO 256 END DO 257 ! ghost cells: 258 ind1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 259 ind2 = jpjglo 260 DO jj = mj0(ind1), mj1(ind2) 261 DO ji = 1, jpi 262 ztabramp(ji,jj) = zmsknorth(ji) 263 END DO 264 END DO 265 ENDIF 266 ! 265 267 ENDIF 266 268 … … 269 271 fspu(:,:) = 0._wp 270 272 fspv(:,:) = 0._wp 271 DO_2D _00_00273 DO_2D( 0, 0, 0, 0 ) 272 274 fspu(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji+1,jj ) ) * ssumask(ji,jj) 273 275 fspv(ji,jj) = 0.5_wp * ( ztabramp(ji,jj) + ztabramp(ji ,jj+1) ) * ssvmask(ji,jj) 274 276 END_2D 275 CALL lbc_lnk( 'agrif_Sponge', fspu, 'U', 1. ) ! Lateral boundary conditions276 CALL lbc_lnk( 'agrif_Sponge', fspv, 'V', 1. )277 278 spongedoneT = .TRUE.279 277 ENDIF 280 278 … … 283 281 fspt(:,:) = 0._wp 284 282 fspf(:,:) = 0._wp 285 DO_2D _00_00283 DO_2D( 0, 0, 0, 0 ) 286 284 fspt(ji,jj) = ztabramp(ji,jj) * ssmask(ji,jj) 287 285 fspf(ji,jj) = 0.25_wp * ( ztabramp(ji ,jj ) + ztabramp(ji ,jj+1) & … … 289 287 & * ssvmask(ji,jj) * ssvmask(ji,jj+1) 290 288 END_2D 291 CALL lbc_lnk( 'agrif_Sponge', fspt, 'T', 1. ) ! Lateral boundary conditions 292 CALL lbc_lnk( 'agrif_Sponge', fspf, 'F', 1. ) 293 289 ENDIF 290 291 IF( .NOT. spongedoneT .AND. .NOT. spongedoneU ) THEN 292 CALL lbc_lnk_multi( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp, fspt, 'T', 1._wp, fspf, 'F', 1._wp ) 293 spongedoneT = .TRUE. 294 294 spongedoneU = .TRUE. 295 295 ENDIF 296 IF( .NOT. spongedoneT ) THEN 297 CALL lbc_lnk_multi( 'agrif_Sponge', fspu, 'U', 1._wp, fspv, 'V', 1._wp ) 298 spongedoneT = .TRUE. 299 ENDIF 300 IF( .NOT. spongedoneT .AND. .NOT. spongedoneU ) THEN 301 CALL lbc_lnk_multi( 'agrif_Sponge', fspt, 'T', 1._wp, fspf, 'F', 1._wp ) 302 spongedoneU = .TRUE. 303 ENDIF 296 304 297 305 #if defined key_vertical 298 306 ! Remove vertical interpolation where not needed: 299 DO_2D _00_00307 DO_2D( 0, 0, 0, 0 ) 300 308 IF ((fspu(ji-1,jj)==0._wp).AND.(fspu(ji,jj)==0._wp).AND. & 301 309 & (fspv(ji,jj-1)==0._wp).AND.(fspv(ji,jj)==0._wp)) mbkt_parent(ji,jj) = 0 … … 312 320 END_2D 313 321 ! 314 ztabramp(:,:) = REAL( mbkt_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'T', 1. ) 315 mbkt_parent(:,:) = NINT( ztabramp(:,:) ) 316 ztabramp(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'U', 1. ) 317 mbku_parent(:,:) = NINT( ztabramp(:,:) ) 318 ztabramp(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_Sponge', ztabramp, 'V', 1. ) 319 mbkv_parent(:,:) = NINT( ztabramp(:,:) ) 322 ztabramp (:,:) = REAL( mbkt_parent(:,:), wp ) 323 ztabrampu(:,:) = REAL( mbku_parent(:,:), wp ) 324 ztabrampv(:,:) = REAL( mbkv_parent(:,:), wp ) 325 CALL lbc_lnk_multi( 'Agrif_Sponge', ztabramp, 'T', 1._wp, ztabrampu, 'U', 1._wp, ztabrampv, 'V', 1._wp ) 326 mbkt_parent(:,:) = NINT( ztabramp (:,:) ) 327 mbku_parent(:,:) = NINT( ztabrampu(:,:) ) 328 mbkv_parent(:,:) = NINT( ztabrampv(:,:) ) 320 329 #endif 321 330 ! … … 324 333 END SUBROUTINE Agrif_Sponge 325 334 335 326 336 SUBROUTINE interptsn_sponge( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 327 337 !!---------------------------------------------------------------------- … … 334 344 INTEGER :: ji, jj, jk, jn ! dummy loop indices 335 345 INTEGER :: iku, ikv 336 REAL(wp) :: ztsa, zabe1, zabe2, zbtr, zhtot , ztrelax346 REAL(wp) :: ztsa, zabe1, zabe2, zbtr, zhtot 337 347 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk) :: ztu, ztv 338 348 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tsbdiff … … 411 421 N_out = N_out + 1 412 422 h_out(jk) = e3t(ji,jj,jk,Kbb_a) !Child grid scale factors. Could multiply by e1e2t here instead of division above 413 END DO423 END DO 414 424 415 425 ! Account for small differences in free-surface … … 422 432 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) 423 433 ENDIF 424 END DO425 END DO434 END DO 435 END DO 426 436 # endif 427 437 … … 434 444 tsbdiff(ji,jj,jk,1:jpts) = (ts(ji,jj,jk,1:jpts,Kbb_a) - tabres(ji,jj,jk,1:jpts))*tmask(ji,jj,jk) 435 445 # endif 436 ENDDO 437 ENDDO 438 ENDDO 439 440 !* set relaxation time scale 441 IF( l_1st_euler .AND. lk_agrif_fstep ) THEN ; ztrelax = rn_trelax_tra / ( rn_Dt ) 442 ELSE ; ztrelax = rn_trelax_tra / (2._wp * rn_Dt ) 443 ENDIF 446 END DO 447 END DO 448 END DO 444 449 445 450 DO jn = 1, jpts … … 448 453 DO jj = j1,j2 449 454 DO ji = i1,i2-1 450 zabe1 = rn_sponge_tra * fspu(ji,jj) * umask(ji,jj,jk) * e2_e1u(ji,jj) * e3u(ji,jj,jk,Kmm_a)455 zabe1 = rn_sponge_tra * r1_Dt * fspu(ji,jj) * umask(ji,jj,jk) * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 451 456 ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 452 457 END DO … … 455 460 DO ji = i1,i2 456 461 DO jj = j1,j2-1 457 zabe2 = rn_sponge_tra * fspv(ji,jj) * vmask(ji,jj,jk) * e1_e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a)462 zabe2 = rn_sponge_tra * r1_Dt * fspv(ji,jj) * vmask(ji,jj,jk) * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 458 463 ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 459 464 END DO … … 480 485 ! horizontal diffusive trends 481 486 ztsa = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) & 482 & - ztrelax* fspt(ji,jj) * tsbdiff(ji,jj,jk,jn)487 & - rn_trelax_tra * r1_Dt * fspt(ji,jj) * tsbdiff(ji,jj,jk,jn) 483 488 ! add it to the general tracer trends 484 489 ts(ji,jj,jk,jn,Krhs_a) = ts(ji,jj,jk,jn,Krhs_a) + ztsa … … 496 501 END SUBROUTINE interptsn_sponge 497 502 503 498 504 SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before) 499 505 !!--------------------------------------------- … … 504 510 LOGICAL, INTENT(in) :: before 505 511 506 INTEGER :: ji,jj,jk,jmax507 512 INTEGER :: ji,jj,jk,jmax 513 INTEGER :: ind1 508 514 ! sponge parameters 509 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot , ztrelax515 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot 510 516 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ubdiff 511 517 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff … … 569 575 zhtot = zhtot + h_in(jk) 570 576 tabin(jk) = tabres(ji,jj,jk,m1) 571 END DO577 END DO 572 578 ! 573 579 N_out = 0 … … 576 582 N_out = N_out + 1 577 583 h_out(N_out) = e3u(ji,jj,jk,Kbb_a) 578 END DO584 END DO 579 585 580 586 ! Account for small differences in free-surface … … 588 594 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) 589 595 ENDIF 590 END DO591 END DO596 END DO 597 END DO 592 598 593 599 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) … … 595 601 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) 596 602 #endif 597 !* set relaxation time scale598 IF( l_1st_euler .AND. lk_agrif_fstep ) THEN ; ztrelax = rn_trelax_dyn / ( rn_Dt )599 ELSE ; ztrelax = rn_trelax_dyn / (2._wp * rn_Dt )600 ENDIF601 603 ! 602 604 DO jk = 1, jpkm1 ! Horizontal slab … … 608 610 DO jj = j1,j2 609 611 DO ji = i1+1,i2 ! vector opt. 610 zbtr = r 1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb_a) * rn_sponge_dyn * fspt(ji,jj)612 zbtr = rn_sponge_dyn * r1_Dt * fspt(ji,jj) / e3t(ji,jj,jk,Kbb_a) 611 613 hdivdiff(ji,jj,jk) = ( e2u(ji ,jj)*e3u(ji ,jj,jk,Kbb_a) * ubdiff(ji ,jj,jk) & 612 614 & -e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb_a) * ubdiff(ji-1,jj,jk) ) * zbtr … … 616 618 DO jj = j1,j2-1 617 619 DO ji = i1,i2 ! vector opt. 618 zbtr = r 1_e1e2f(ji,jj) * e3f(ji,jj,jk) * rn_sponge_dyn * fspf(ji,jj)620 zbtr = rn_sponge_dyn * r1_Dt * fspf(ji,jj) * e3f(ji,jj,jk) 619 621 rotdiff(ji,jj,jk) = ( -e1u(ji,jj+1) * ubdiff(ji,jj+1,jk) & 620 622 & +e1u(ji,jj ) * ubdiff(ji,jj ,jk) ) * fmask(ji,jj,jk) * zbtr … … 633 635 zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) ) & 634 636 & + ( hdivdiff(ji+1,jj,jk) - ze1v ) * r1_e1u(ji,jj) & 635 & - ztrelax* fspu(ji,jj) * ubdiff(ji,jj,jk)637 & - rn_trelax_dyn * r1_Dt * fspu(ji,jj) * ubdiff(ji,jj,jk) 636 638 637 639 ! add it to the general momentum trends … … 646 648 647 649 jmax = j2-1 648 IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-nbghostcells-2) ! North 650 ind1 = jpjglo - ( nn_hls + nbghostcells + 2 ) ! North 651 DO jj = mj0(ind1), mj1(ind1) 652 jmax = MIN(jmax,jj) 653 END DO 649 654 650 655 DO jj = j1+1, jmax … … 674 679 END SUBROUTINE interpun_sponge 675 680 676 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before,nb,ndir) 681 682 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before) 677 683 !!--------------------------------------------- 678 684 !! *** ROUTINE interpvn_sponge *** … … 681 687 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres 682 688 LOGICAL, INTENT(in) :: before 683 INTEGER, INTENT(in) :: nb , ndir684 689 ! 685 690 INTEGER :: ji, jj, jk, imax 686 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot, ztrelax 691 INTEGER :: ind1 692 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot 687 693 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: vbdiff 688 694 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff … … 745 751 zhtot = zhtot + h_in(jk) 746 752 tabin(jk) = tabres(ji,jj,jk,m1) 747 END DO753 END DO 748 754 ! 749 755 N_out = 0 … … 752 758 N_out = N_out + 1 753 759 h_out(N_out) = e3v(ji,jj,jk,Kbb_a) 754 END DO760 END DO 755 761 756 762 ! Account for small differences in free-surface … … 764 770 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) 765 771 ENDIF 766 END DO767 END DO772 END DO 773 END DO 768 774 769 775 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:) … … 771 777 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) 772 778 # endif 773 !* set relaxation time scale774 IF( l_1st_euler .AND. lk_agrif_fstep ) THEN ; ztrelax = rn_trelax_dyn / ( rn_Dt )775 ELSE ; ztrelax = rn_trelax_dyn / (2._wp * rn_Dt )776 ENDIF777 779 ! 778 780 DO jk = 1, jpkm1 ! Horizontal slab … … 784 786 DO jj = j1+1,j2 785 787 DO ji = i1,i2 ! vector opt. 786 zbtr = r 1_e1e2t(ji,jj) / e3t(ji,jj,jk,Kbb_a) * rn_sponge_dyn * fspt(ji,jj)788 zbtr = rn_sponge_dyn * r1_Dt * fspt(ji,jj) / e3t(ji,jj,jk,Kbb_a) 787 789 hdivdiff(ji,jj,jk) = ( e1v(ji,jj ) * e3v(ji,jj ,jk,Kbb_a) * vbdiff(ji,jj ,jk) & 788 790 & -e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kbb_a) * vbdiff(ji,jj-1,jk) ) * zbtr … … 791 793 DO jj = j1,j2 792 794 DO ji = i1,i2-1 ! vector opt. 793 zbtr = r 1_e1e2f(ji,jj) * e3f(ji,jj,jk) * rn_sponge_dyn * fspf(ji,jj)795 zbtr = rn_sponge_dyn * r1_Dt * fspf(ji,jj) * e3f(ji,jj,jk) 794 796 rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) & 795 797 & -e2v(ji ,jj) * vbdiff(ji ,jj,jk) ) * fmask(ji,jj,jk) * zbtr … … 802 804 803 805 imax = i2 - 1 804 IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-nbghostcells-2) ! East 805 806 ind1 = jpiglo - ( nn_hls + nbghostcells + 2 ) ! East 807 DO ji = mi0(ind1), mi1(ind1) 808 imax = MIN(imax,ji) 809 END DO 810 806 811 DO jj = j1+1, j2 807 812 DO ji = i1+1, imax ! vector opt. 808 813 IF( .NOT. tabspongedone_u(ji,jj) ) THEN 809 814 DO jk = 1, jpkm1 810 uu(ji,jj,jk,Krhs_a) = uu(ji,jj,jk,Krhs_a) 815 uu(ji,jj,jk,Krhs_a) = uu(ji,jj,jk,Krhs_a) & 811 816 & - ( rotdiff (ji ,jj,jk) - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) ) & 812 817 & + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj ,jk)) * r1_e1u(ji,jj) … … 822 827 IF( .NOT. tabspongedone_v(ji,jj) ) THEN 823 828 DO jk = 1, jpkm1 824 vv(ji,jj,jk,Krhs_a) = vv(ji,jj,jk,Krhs_a) 829 vv(ji,jj,jk,Krhs_a) = vv(ji,jj,jk,Krhs_a) & 825 830 & + ( rotdiff (ji,jj ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) ) & 826 & + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji ,jj,jk) ) * r1_e2v(ji,jj) &827 & - ztrelax* fspv(ji,jj) * vbdiff(ji,jj,jk)831 & + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji ,jj,jk) ) * r1_e2v(ji,jj) & 832 & - rn_trelax_dyn * r1_Dt * fspv(ji,jj) * vbdiff(ji,jj,jk) 828 833 END DO 829 834 ENDIF -
NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_oce_update.F90
r12511 r13540 26 26 USE domvvl ! Need interpolation routines 27 27 USE vremap ! Vertical remapping 28 USE lbclnk 28 29 29 30 IMPLICIT NONE … … 84 85 85 86 Agrif_UseSpecialValueInUpdate = .FALSE. 86 Agrif_SpecialValueFineGrid = 0. 87 Agrif_SpecialValueFineGrid = 0._wp 88 89 use_sign_north = .TRUE. 90 sign_north = -1._wp 91 87 92 ! 88 93 # if ! defined DECAL_FEEDBACK … … 127 132 END IF 128 133 ! 134 use_sign_north = .FALSE. 135 ! 129 136 END SUBROUTINE Agrif_Update_Dyn 130 137 … … 137 144 ! 138 145 Agrif_UseSpecialValueInUpdate = .TRUE. 139 Agrif_SpecialValueFineGrid = 0. 146 Agrif_SpecialValueFineGrid = 0._wp 140 147 # if ! defined DECAL_FEEDBACK_2D 141 148 CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) … … 148 155 # if defined VOL_REFLUX 149 156 IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN 157 use_sign_north = .TRUE. 158 sign_north = -1._wp 150 159 ! Refluxing on ssh: 151 160 # if defined DECAL_FEEDBACK_2D … … 156 165 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/ 0, 0/),locupdate2=(/-1,-1/),procname = reflux_sshv) 157 166 # endif 167 use_sign_north = .FALSE. 158 168 END IF 159 169 # endif … … 826 836 SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 827 837 !!--------------------------------------------- 828 !! *** ROUTINE correct_ u_bdy ***838 !! *** ROUTINE correct_v_bdy *** 829 839 !!--------------------------------------------- 830 840 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 -
NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_top_interp.F90
r12377 r13540 119 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 120 END DO 121 122 121 ENDIF 123 122 ! -
NEMO/branches/2020/r12377_ticket2386/src/NST/agrif_user.F90
r12511 r13540 11 11 END SUBROUTINE agrif_user 12 12 13 13 14 SUBROUTINE agrif_before_regridding 14 15 END SUBROUTINE agrif_before_regridding 15 16 17 16 18 SUBROUTINE Agrif_InitWorkspace 17 19 END SUBROUTINE Agrif_InitWorkspace 18 20 21 19 22 SUBROUTINE Agrif_InitValues 20 23 !!---------------------------------------------------------------------- … … 28 31 ! 29 32 ! !* Agrif initialization 30 CALL agrif_nemo_init31 CALL Agrif_InitValues_cont_dom32 33 CALL Agrif_InitValues_cont 33 34 # if defined key_top … … 40 41 END SUBROUTINE Agrif_initvalues 41 42 42 SUBROUTINE Agrif_InitValues_cont_dom 43 !!---------------------------------------------------------------------- 44 !! *** ROUTINE Agrif_InitValues_cont_dom *** 45 !!---------------------------------------------------------------------- 46 ! 47 CALL agrif_declare_var_dom 48 ! 49 END SUBROUTINE Agrif_InitValues_cont_dom 50 51 SUBROUTINE agrif_declare_var_dom 52 !!---------------------------------------------------------------------- 53 !! *** ROUTINE agrif_declare_var_dom *** 54 !!---------------------------------------------------------------------- 55 USE par_oce, ONLY: nbghostcells 43 44 SUBROUTINE Agrif_Istate( Kbb, Kmm, Kaa ) 45 !!---------------------------------------------------------------------- 46 !! *** ROUTINE agrif_istate *** 47 !!---------------------------------------------------------------------- 48 USE domvvl 49 USE domain 50 USE par_oce 51 USE agrif_oce 52 USE agrif_oce_interp 53 USE oce 54 USE lib_mpp 55 USE lbclnk 56 ! 57 IMPLICIT NONE 58 ! 59 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 60 INTEGER :: jn 61 !!---------------------------------------------------------------------- 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_wp 68 Agrif_UseSpecialValue = .TRUE. 69 uu(:,:,:,:) = 0.0_wp ; vv(:,:,:,:) = 0.0_wp ; ts(:,:,:,:,:) = 0.0_wp 70 71 Krhs_a = Kbb ; Kmm_a = Kbb 72 73 ! Brutal fix to pas 1x1 refinment. 74 ! IF(Agrif_Irhox() == 1) THEN 75 ! CALL Agrif_Init_Variable(tsini_id, procname=agrif_initts) 76 ! ELSE 77 CALL Agrif_Init_Variable(tsini_id, procname=interptsn) 78 79 ! ENDIF 80 ! just for VORTEX because Parent velocities can actually be exactly zero 81 ! Agrif_UseSpecialValue = .FALSE. 82 Agrif_UseSpecialValue = ln_spc_dyn 83 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 = Kmm 93 94 DO jn = 1, jpts 95 ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb)*tmask(:,:,:) 96 END DO 97 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_Istate 105 106 107 SUBROUTINE agrif_declare_var_ini 108 !!---------------------------------------------------------------------- 109 !! *** ROUTINE agrif_declare_var_ini *** 110 !!---------------------------------------------------------------------- 111 USE agrif_util 112 USE agrif_oce 113 USE par_oce 114 USE zdf_oce 115 USE oce 116 USE dom_oce 56 117 ! 57 118 IMPLICIT NONE 58 119 ! 59 120 INTEGER :: ind1, ind2, ind3 60 !!---------------------------------------------------------------------- 121 INTEGER :: its 122 External :: nemo_mapping 123 !!---------------------------------------------------------------------- 124 125 ! In case of East-West periodicity, prevent AGRIF interpolation at east and west boundaries 126 ! The procnames will not be called at these boundaries 127 IF (jperio == 1) THEN 128 CALL Agrif_Set_NearCommonBorderX(.TRUE.) 129 CALL Agrif_Set_DistantCommonBorderX(.TRUE.) 130 ENDIF 131 132 IF ( .NOT. lk_south ) THEN 133 CALL Agrif_Set_NearCommonBorderY(.TRUE.) 134 ENDIF 61 135 62 136 ! 1. Declaration of the type of variable which have to be interpolated 63 137 !--------------------------------------------------------------------- 64 ind1 = nbghostcells 65 ind2 = 1 + nbghostcells 66 ind3 = 2 + nbghostcells 67 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 68 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 69 138 ind1 = nbghostcells 139 ind2 = nn_hls + 2 + nbghostcells_x 140 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) 148 149 ! Initial or restart velues 150 its = jpts+1 151 CALL agrif_declare_variable((/2,2,0,0/),(/ind2 ,ind3 ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,its/), tsini_id) 152 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 /), uini_id) 153 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 /), vini_id) 154 CALL agrif_declare_variable((/2,2 /),(/ind2 ,ind3 /),(/'x','y' /),(/1,1 /),(/jpi,jpj /),sshini_id) 155 ! 156 70 157 ! 2. Type of interpolation 71 158 !------------------------- 72 CALL Agrif_Set_bcinterp( e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm ) 73 CALL Agrif_Set_bcinterp( e2v_id, interp1=AGRIF_ppm , interp2=Agrif_linear ) 74 75 ! 3. Location of interpolation 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 ) 168 169 ! Initial fields 170 CALL Agrif_Set_bcinterp( tsini_id,interp =AGRIF_linear ) 171 CALL Agrif_Set_interp ( tsini_id,interp =AGRIF_linear ) 172 CALL Agrif_Set_bcinterp( uini_id,interp =AGRIF_linear ) 173 CALL Agrif_Set_interp ( uini_id,interp =AGRIF_linear ) 174 CALL Agrif_Set_bcinterp( vini_id,interp =AGRIF_linear ) 175 CALL Agrif_Set_interp ( vini_id,interp =AGRIF_linear ) 176 CALL Agrif_Set_bcinterp(sshini_id,interp =AGRIF_linear ) 177 CALL Agrif_Set_interp (sshini_id,interp =AGRIF_linear ) 178 179 ! 3. Location of interpolation 76 180 !----------------------------- 77 CALL Agrif_Set_bc(e1u_id,(/0,ind1-1/)) 78 CALL Agrif_Set_bc(e2v_id,(/0,ind1-1/)) 181 ! CALL Agrif_Set_bc( e3t_id, (/-nn_sponge_len*Agrif_irhox(),ind1-1/) ) 182 ! JC: check near the boundary only until matching in sponge has been sorted out: 183 CALL Agrif_Set_bc( e3t_id, (/0,ind1-1/) ) 184 185 ! extend the interpolation zone by 1 more point than necessary: 186 ! 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/) ) 79 197 80 198 ! 4. Update type 81 199 !--------------- 82 200 # if defined UPD_HIGH 83 CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Full_Weighting)84 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting, update2=Agrif_Update_Average )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 ) 85 203 #else 86 CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy , update2=Agrif_Update_Average)87 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average , update2=Agrif_Update_Copy)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 ) 88 206 #endif 89 90 END SUBROUTINE agrif_declare_var_dom 91 92 SUBROUTINE Agrif_InitValues_cont 93 !!---------------------------------------------------------------------- 94 !! *** ROUTINE Agrif_InitValues_cont *** 95 !!---------------------------------------------------------------------- 96 USE agrif_oce 207 208 ! CALL Agrif_Set_ExternalMapping(nemo_mapping) 209 ! 210 END SUBROUTINE agrif_declare_var_ini 211 212 213 SUBROUTINE Agrif_Init_Domain( Kbb, Kmm, Kaa ) 214 !!---------------------------------------------------------------------- 215 !! *** ROUTINE Agrif_Init_Domain *** 216 !!---------------------------------------------------------------------- 217 USE agrif_oce_update 97 218 USE agrif_oce_interp 98 219 USE agrif_oce_sponge 220 USE Agrif_Util 221 USE oce 99 222 USE dom_oce 100 USE oce 223 USE zdf_oce 224 USE nemogcm 225 USE agrif_oce 226 ! 227 USE lbclnk 101 228 USE lib_mpp 102 USE lbclnk 103 ! 104 IMPLICIT NONE 105 ! 106 INTEGER :: ji, jj 229 USE in_out_manager 230 ! 231 IMPLICIT NONE 232 ! 233 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 234 ! 107 235 LOGICAL :: check_namelist 108 236 CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4 109 #if defined key_vertical110 237 REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace 111 #endif 112 !!---------------------------------------------------------------------- 113 114 ! 1. Declaration of the type of variable which have to be interpolated 115 !--------------------------------------------------------------------- 116 CALL agrif_declare_var 117 118 ! 2. First interpolations of potentially non zero fields 119 !------------------------------------------------------- 120 121 #if defined key_vertical 238 INTEGER :: ji, jj, jk 239 !!---------------------------------------------------------------------- 240 241 ! CALL Agrif_Declare_Var_ini 242 243 IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 244 122 245 ! Build consistent parent bathymetry and number of levels 123 246 ! on the child grid 124 247 Agrif_UseSpecialValue = .FALSE. 125 ht0_parent( :,:) = 0._wp248 ht0_parent( :,:) = 0._wp 126 249 mbkt_parent(:,:) = 0 127 250 ! 128 CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 ) 129 CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt) 251 ! CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 ) 252 ! CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt) 253 CALL Agrif_Init_Variable(ht0_id , procname=interpht0 ) 254 CALL Agrif_Init_Variable(mbkt_id, procname=interpmbkt) 130 255 ! 131 256 ! Assume step wise change of bathymetry near interface 132 257 ! TODO: Switch to linear interpolation of bathymetry in the s-coordinate case 133 258 ! and no refinement 134 DO_2D _10_10135 mbku_parent(ji,jj) = MIN( mbkt_parent(ji+1,jj ) , mbkt_parent(ji,jj))136 mbkv_parent(ji,jj) = MIN( mbkt_parent(ji ,jj+1) , mbkt_parent(ji,jj))259 DO_2D( 1, 0, 1, 0 ) 260 mbku_parent(ji,jj) = MIN( mbkt_parent(ji+1,jj ), mbkt_parent(ji,jj) ) 261 mbkv_parent(ji,jj) = MIN( mbkt_parent(ji ,jj+1), mbkt_parent(ji,jj) ) 137 262 END_2D 138 263 IF ( ln_sco.AND.Agrif_Parent(ln_sco) ) THEN 139 DO_2D _10_10264 DO_2D( 1, 0, 1, 0 ) 140 265 hu0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji+1,jj) ) 141 266 hv0_parent(ji,jj) = 0.5_wp * ( ht0_parent(ji,jj)+ht0_parent(ji,jj+1) ) 142 267 END_2D 143 268 ELSE 144 DO_2D _10_10145 hu0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji+1,jj) )146 hv0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji,jj+1) )269 DO_2D( 1, 0, 1, 0 ) 270 hu0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji+1,jj) ) 271 hv0_parent(ji,jj) = MIN( ht0_parent(ji,jj), ht0_parent(ji,jj+1) ) 147 272 END_2D 148 149 ENDIF 150 ! 151 CALL lbc_lnk( 'Agrif_InitValues_cont', hu0_parent, 'U', 1. ) 152 CALL lbc_lnk( 'Agrif_InitValues_cont', hv0_parent, 'V', 1. ) 153 zk(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1. ) 273 ENDIF 274 ! 275 CALL lbc_lnk_multi( 'Agrif_Init_Domain', hu0_parent, 'U', 1.0_wp, hv0_parent, 'V', 1.0_wp ) 276 DO_2D( 0, 0, 0, 0 ) 277 zk(ji,jj) = REAL( mbku_parent(ji,jj), wp ) 278 END_2D 279 CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1.0_wp ) 154 280 mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 155 zk(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1. ) 281 DO_2D( 0, 0, 0, 0 ) 282 zk(ji,jj) = REAL( mbkv_parent(ji,jj), wp ) 283 END_2D 284 CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1.0_wp ) 156 285 mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 157 #endif 158 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 DO jk = 1, jpk 291 e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) & 292 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 293 & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 294 END DO 295 ENDIF 296 297 ! check if masks and bathymetries match 298 IF(ln_chk_bathy) THEN 299 Agrif_UseSpecialValue = .FALSE. 300 ! 301 IF(lwp) WRITE(numout,*) ' ' 302 IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() 303 ! 304 kindic_agr = 0 305 IF( .NOT. l_vremap ) THEN 306 ! 307 ! check if tmask and vertical scale factors agree with parent in sponge area: 308 CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 309 ! 310 ELSE 311 ! 312 ! In case of vertical interpolation, check only that total depths agree between child and parent: 313 DO ji = 1, jpi 314 DO jj = 1, jpj 315 IF ((mbkt_parent(ji,jj)/=0).AND.(ABS(ht0_parent(ji,jj)-ht_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 316 IF ((mbku_parent(ji,jj)/=0).AND.(ABS(hu0_parent(ji,jj)-hu_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 317 IF ((mbkv_parent(ji,jj)/=0).AND.(ABS(hv0_parent(ji,jj)-hv_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 318 END DO 319 END DO 320 321 CALL mpp_sum( 'agrif_user', kindic_agr ) 322 IF( kindic_agr /= 0 ) THEN 323 CALL ctl_stop('==> Child Bathymetry is NOT correct near boundaries.') 324 ELSE 325 IF(lwp) WRITE(numout,*) '==> Child Bathymetry is ok near boundaries.' 326 IF(lwp) WRITE(numout,*) ' ' 327 ENDIF 328 ENDIF 329 ENDIF 330 331 IF( l_vremap ) THEN 332 ! Additional constrain that should be removed someday: 333 IF ( Agrif_Parent(jpk).GT.jpk ) THEN 334 CALL ctl_stop( ' With l_vremap, child grids must have jpk greater or equal to the parent value' ) 335 ENDIF 336 ENDIF 337 ! 338 END SUBROUTINE Agrif_Init_Domain 339 340 341 SUBROUTINE Agrif_InitValues_cont 342 !!---------------------------------------------------------------------- 343 !! *** ROUTINE Agrif_InitValues_cont *** 344 !! 345 !! ** Purpose :: Declaration of variables to be interpolated 346 !!---------------------------------------------------------------------- 347 USE agrif_oce_update 348 USE agrif_oce_interp 349 USE agrif_oce_sponge 350 USE Agrif_Util 351 USE oce 352 USE dom_oce 353 USE zdf_oce 354 USE nemogcm 355 USE agrif_oce 356 ! 357 USE lbclnk 358 USE lib_mpp 359 USE in_out_manager 360 ! 361 IMPLICIT NONE 362 ! 363 LOGICAL :: check_namelist 364 CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4 365 REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace 366 INTEGER :: ji, jj 367 368 ! 1. Declaration of the type of variable which have to be interpolated 369 !--------------------------------------------------------------------- 370 CALL agrif_declare_var 371 372 ! 2. First interpolations of potentially non zero fields 373 !------------------------------------------------------- 159 374 Agrif_SpecialValue = 0._wp 160 375 Agrif_UseSpecialValue = .TRUE. 161 CALL Agrif_Bc_variable( tsn_id,calledweight=1.,procname=interptsn)376 CALL Agrif_Bc_variable( tsn_id,calledweight=1.,procname=interptsn) 162 377 CALL Agrif_Sponge 163 378 tabspongedone_tsn = .FALSE. 164 379 CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 165 ! reset ts (:,:,:,:,Krhs_a)to zero380 ! reset tsa to zero 166 381 ts(:,:,:,:,Krhs_a) = 0._wp 167 382 168 383 Agrif_UseSpecialValue = ln_spc_dyn 384 use_sign_north = .TRUE. 385 sign_north = -1. 169 386 CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 170 387 CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) … … 175 392 tabspongedone_v = .FALSE. 176 393 CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 394 use_sign_north = .FALSE. 177 395 uu(:,:,:,Krhs_a) = 0._wp 178 396 vv(:,:,:,Krhs_a) = 0._wp … … 185 403 IF ( ln_dynspg_ts ) THEN 186 404 Agrif_UseSpecialValue = ln_spc_dyn 187 CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 188 CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 405 use_sign_north = .TRUE. 406 sign_north = -1. 407 CALL Agrif_Bc_variable( unb_id,calledweight=1.,procname=interpunb ) 408 CALL Agrif_Bc_variable( vnb_id,calledweight=1.,procname=interpvnb ) 189 409 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 190 410 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 411 use_sign_north = .FALSE. 191 412 ubdy(:,:) = 0._wp 192 413 vbdy(:,:) = 0._wp 193 414 ENDIF 194 195 Agrif_UseSpecialValue = .FALSE. 196 197 ! 3. Some controls 415 Agrif_UseSpecialValue = .FALSE. 416 198 417 !----------------- 199 418 check_namelist = .TRUE. 200 419 201 420 IF( check_namelist ) THEN 202 203 ! Check time steps204 IF( NINT(Agrif_Rhot()) * NINT(rn_Dt) .NE. Agrif_Parent(rn_Dt) ) THEN205 WRITE(cl_check1,*) NINT(Agrif_Parent(rn_Dt))206 WRITE(cl_check2,*) NINT(rn_Dt)207 WRITE(cl_check3,*) NINT(Agrif_Parent(rn_Dt)/Agrif_Rhot())208 CALL ctl_stop( 'Incompatible time step between ocean grids', &209 & 'parent grid value : '//cl_check1 , &210 & 'child grid value : '//cl_check2 , &211 & 'value on child grid should be changed to : '//cl_check3 )212 ENDIF213 214 ! Check run length215 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &216 Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN217 WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1218 WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot()219 CALL ctl_warn( 'Incompatible run length between grids' , &220 & 'nit000 on fine grid will be changed to : '//cl_check1, &221 & 'nitend on fine grid will be changed to : '//cl_check2 )222 nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1223 nitend = Agrif_Parent(nitend) *Agrif_IRhot()224 ENDIF225 226 421 ! Check free surface scheme 227 422 IF ( ( Agrif_Parent(ln_dynspg_ts ).AND.ln_dynspg_exp ).OR.& … … 251 446 STOP 252 447 ENDIF 253 254 ENDIF 255 256 ! check if masks and bathymetries match 257 IF(ln_chk_bathy) THEN 258 Agrif_UseSpecialValue = .FALSE. 259 ! 260 IF(lwp) WRITE(numout,*) ' ' 261 IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() 262 ! 263 kindic_agr = 0 264 # if ! defined key_vertical 265 ! 266 ! check if tmask and vertical scale factors agree with parent in sponge area: 267 CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 268 ! 269 # else 270 ! 271 ! In case of vertical interpolation, check only that total depths agree between child and parent: 272 DO ji = 1, jpi 273 DO jj = 1, jpj 274 IF ((mbkt_parent(ji,jj)/=0).AND.(ABS(ht0_parent(ji,jj)-ht_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 275 IF ((mbku_parent(ji,jj)/=0).AND.(ABS(hu0_parent(ji,jj)-hu_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 276 IF ((mbkv_parent(ji,jj)/=0).AND.(ABS(hv0_parent(ji,jj)-hv_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 277 END DO 278 END DO 279 # endif 280 CALL mpp_sum( 'agrif_user', kindic_agr ) 281 IF( kindic_agr /= 0 ) THEN 282 CALL ctl_stop('==> Child Bathymetry is NOT correct near boundaries.') 283 ELSE 284 IF(lwp) WRITE(numout,*) '==> Child Bathymetry is ok near boundaries.' 285 IF(lwp) WRITE(numout,*) ' ' 286 END IF 287 ! 288 ENDIF 289 290 # if defined key_vertical 291 ! Additional constrain that should be removed someday: 292 IF ( Agrif_Parent(jpk).GT.jpk ) THEN 293 CALL ctl_stop( ' With key_vertical, child grids must have jpk greater or equal to the parent value' ) 294 ENDIF 295 # endif 296 ! 448 ENDIF 449 297 450 END SUBROUTINE Agrif_InitValues_cont 298 451 … … 314 467 ! 1. Declaration of the type of variable which have to be interpolated 315 468 !--------------------------------------------------------------------- 316 ind1 = nbghostcells317 ind2 = 1 + nbghostcells318 ind3 = 2 + nbghostcells469 ind1 = nbghostcells 470 ind2 = nn_hls + 2 + nbghostcells_x 471 ind3 = nn_hls + 2 + nbghostcells_y_s 319 472 # if defined key_vertical 320 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_id) 321 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_sponge_id) 322 323 CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_interp_id) 324 CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_interp_id) 325 CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_update_id) 326 CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_update_id) 327 CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_sponge_id) 328 CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_sponge_id) 473 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) 474 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) 475 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) 476 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) 477 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_update_id) 478 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_update_id) 479 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) 480 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) 329 481 # else 330 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 331 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 332 333 CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_interp_id) 334 CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_interp_id) 335 CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_update_id) 336 CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_update_id) 337 CALL agrif_declare_variable((/1,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_sponge_id) 338 CALL agrif_declare_variable((/2,1,0,0/),(/ind3,ind2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_sponge_id) 482 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) 483 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) 484 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) 485 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) 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_update_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_update_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_sponge_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_sponge_id) 339 490 # endif 340 341 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 342 491 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 492 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) 493 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_interp_id) 494 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_interp_id) 495 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_update_id) 496 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_update_id) 497 498 ! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),glamt_id) 499 ! CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gphit_id) 500 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 501 502 503 IF( ln_zdftke.OR.ln_zdfgls ) THEN ! logical not known at this point 504 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 505 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 343 506 # if defined key_vertical 344 CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),mbkt_id) 345 CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ht0_id) 507 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) 508 # else 509 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) 346 510 # endif 347 348 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 349 350 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 351 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 352 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 353 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 354 CALL agrif_declare_variable((/1,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 355 CALL agrif_declare_variable((/2,1/),(/ind3,ind2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 356 357 CALL agrif_declare_variable((/2,2/),(/ind3,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 358 359 IF( ln_zdftke.OR.ln_zdfgls ) THEN 360 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/), en_id) 361 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),avt_id) 362 # if defined key_vertical 363 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),avm_id) 364 # else 365 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),avm_id) 366 # endif 367 ENDIF 368 511 ENDIF 512 369 513 ! 2. Type of interpolation 370 514 !------------------------- 371 CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 372 373 CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 374 CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 375 376 CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 377 378 CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) 379 CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 380 CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 381 CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 382 CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 515 CALL Agrif_Set_bcinterp( tsn_id,interp =AGRIF_linear) 516 CALL Agrif_Set_bcinterp( un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 517 CALL Agrif_Set_bcinterp( vn_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 518 519 CALL Agrif_Set_bcinterp( tsn_sponge_id,interp =AGRIF_linear) 520 CALL Agrif_Set_bcinterp( un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 521 CALL Agrif_Set_bcinterp( vn_sponge_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 522 523 CALL Agrif_Set_bcinterp( sshn_id,interp =AGRIF_linear) 524 CALL Agrif_Set_bcinterp( unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 525 CALL Agrif_Set_bcinterp( vnb_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 526 CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm ) 527 CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm ,interp2=Agrif_linear) 383 528 ! 384 529 ! > Divergence conserving alternative: … … 390 535 !< 391 536 392 CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 393 CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 394 395 CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 396 397 # if defined key_vertical 398 CALL Agrif_Set_bcinterp(mbkt_id,interp=AGRIF_constant) 399 CALL Agrif_Set_bcinterp(ht0_id ,interp=AGRIF_constant) 400 # endif 401 402 IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear ) 537 IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear ) 538 539 540 ! CALL Agrif_Set_bcinterp(gphit_id,interp=AGRIF_constant) 541 ! CALL Agrif_Set_bcinterp(glamt_id,interp=AGRIF_constant) 403 542 404 543 ! 3. Location of interpolation … … 418 557 CALL Agrif_Set_bc( vb2b_interp_id, (/0,ind1-1/) ) 419 558 420 ! CALL Agrif_Set_bc( e3t_id, (/-nn_sponge_len*Agrif_irhox(),ind1-1/) ) 421 ! JC: check near the boundary only until matching in sponge has been sorted out: 422 CALL Agrif_Set_bc( e3t_id, (/0,ind1-1/) ) 423 424 # if defined key_vertical 425 ! extend the interpolation zone by 1 more point than necessary: 426 CALL Agrif_Set_bc( mbkt_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) ) 427 CALL Agrif_Set_bc( ht0_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) ) 428 # endif 429 430 IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) ) 559 IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) ) 560 !!$ CALL Agrif_Set_bc(glamt_id, (/0,ind1-1/) ) 561 !!$ CALL Agrif_Set_bc(gphit_id, (/0,ind1-1/) ) 431 562 432 563 ! 4. Update type 433 564 !--------------- 434 CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average)435 565 436 566 # if defined UPD_HIGH 437 CALL Agrif_Set_Updatetype( tsn_id, update= Agrif_Update_Full_Weighting)438 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)439 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )440 441 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting)442 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average )443 CALL Agrif_Set_Updatetype( sshn_id,update= Agrif_Update_Full_Weighting)444 CALL Agrif_Set_Updatetype( e3t_id, update= Agrif_Update_Full_Weighting)445 446 IF( ln_zdftke.OR.ln_zdfgls ) THEN567 CALL Agrif_Set_Updatetype( tsn_id,update = Agrif_Update_Full_Weighting) 568 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) 569 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) 570 571 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) 572 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) 573 CALL Agrif_Set_Updatetype( sshn_id,update = Agrif_Update_Full_Weighting) 574 CALL Agrif_Set_Updatetype( e3t_id,update = Agrif_Update_Full_Weighting) 575 576 ! IF( ln_zdftke.OR.ln_zdfgls ) THEN 447 577 ! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Full_Weighting) 448 578 ! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Full_Weighting) 449 579 ! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Full_Weighting) 450 ENDIF580 ! ENDIF 451 581 452 582 #else 453 CALL Agrif_Set_Updatetype( tsn_id, update= AGRIF_Update_Average)454 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)455 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )456 457 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average)458 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy )459 CALL Agrif_Set_Updatetype( sshn_id,update= AGRIF_Update_Average)460 CALL Agrif_Set_Updatetype( e3t_id, update= AGRIF_Update_Average)461 462 IF( ln_zdftke.OR.ln_zdfgls ) THEN583 CALL Agrif_Set_Updatetype( tsn_id, update = AGRIF_Update_Average) 584 CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) 585 CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) 586 587 CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) 588 CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) 589 CALL Agrif_Set_Updatetype( sshn_id,update = AGRIF_Update_Average) 590 CALL Agrif_Set_Updatetype( e3t_id,update = AGRIF_Update_Average) 591 592 ! IF( ln_zdftke.OR.ln_zdfgls ) THEN 463 593 ! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 464 594 ! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 465 595 ! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 466 ENDIF596 ! ENDIF 467 597 468 598 #endif … … 471 601 472 602 #if defined key_si3 473 SUBROUTINE Agrif_InitValues_cont_ice603 SUBROUTINE Agrif_InitValues_cont_ice 474 604 !!---------------------------------------------------------------------- 475 605 !! *** ROUTINE Agrif_InitValues_cont_ice *** … … 484 614 ! 485 615 IMPLICIT NONE 486 !!---------------------------------------------------------------------- 487 ! 488 ! Declaration of the type of variable which have to be interpolated (parent=>child) 489 !---------------------------------------------------------------------------------- 490 CALL agrif_declare_var_ice 491 616 ! 617 !!---------------------------------------------------------------------- 492 618 ! Controls 493 619 … … 495 621 ! the run must satisfy CFL=Uice/(dx/dt) < 0.6/nn_fsbc(child) 496 622 ! therefore, if nn_fsbc(child)>1 one must reduce the time-step in proportion to nn_fsbc(child), which is not acceptable 497 ! If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account 623 ! If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account 498 624 IF( nn_fsbc > 1 ) CALL ctl_stop('nn_fsbc(child) must be set to 1 otherwise agrif and sea-ice may not work properly') 499 625 … … 512 638 END SUBROUTINE Agrif_InitValues_cont_ice 513 639 640 514 641 SUBROUTINE agrif_declare_var_ice 515 642 !!---------------------------------------------------------------------- … … 518 645 USE Agrif_Util 519 646 USE ice 520 USE par_oce, ONLY : nbghostcells 647 USE par_oce, ONLY : nbghostcells, nbghostcells_x, nbghostcells_y_s 521 648 ! 522 649 IMPLICIT NONE 523 650 ! 524 651 INTEGER :: ind1, ind2, ind3 652 INTEGER :: ipl 525 653 !!---------------------------------------------------------------------- 526 654 ! … … 532 660 ! 2,2 = two ghost lines 533 661 !------------------------------------------------------------------------------------- 534 ind1 = nbghostcells 535 ind2 = 1 + nbghostcells 536 ind3 = 2 + nbghostcells 537 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(8+nlay_s+nlay_i)/),tra_ice_id) 538 CALL agrif_declare_variable((/1,2/) ,(/ind2,ind3/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_ice_id ) 539 CALL agrif_declare_variable((/2,1/) ,(/ind3,ind2/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_ice_id ) 662 ind1 = nbghostcells 663 ind2 = nn_hls + 2 + nbghostcells_x 664 ind3 = nn_hls + 2 + nbghostcells_y_s 665 ipl = jpl*(9+nlay_s+nlay_i) 666 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_ice_id) 667 CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_ice_id) 668 CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), v_ice_id) 669 670 CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,ipl/),tra_iceini_id) 671 CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), u_iceini_id) 672 CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/),(/'x','y' /),(/1,1 /),(/jpi,jpj /), v_iceini_id) 540 673 541 674 ! 2. Set interpolations (normal & tangent to the grid cell for velocities) … … 545 678 CALL Agrif_Set_bcinterp(v_ice_id , interp1 = AGRIF_ppm ,interp2 = Agrif_linear) 546 679 680 CALL Agrif_Set_bcinterp(tra_iceini_id, interp = AGRIF_linear) 681 CALL Agrif_Set_interp (tra_iceini_id, interp = AGRIF_linear) 682 CALL Agrif_Set_bcinterp(u_iceini_id , interp = AGRIF_linear ) 683 CALL Agrif_Set_interp (u_iceini_id , interp = AGRIF_linear ) 684 CALL Agrif_Set_bcinterp(v_iceini_id , interp = AGRIF_linear) 685 CALL Agrif_Set_interp (v_iceini_id , interp = AGRIF_linear) 686 547 687 ! 3. Set location of interpolations 548 688 !---------------------------------- … … 550 690 CALL Agrif_Set_bc(u_ice_id ,(/0,ind1/)) 551 691 CALL Agrif_Set_bc(v_ice_id ,(/0,ind1/)) 692 693 CALL Agrif_Set_bc(tra_iceini_id,(/0,ind1/)) 694 CALL Agrif_Set_bc(u_iceini_id ,(/0,ind1/)) 695 CALL Agrif_Set_bc(v_iceini_id ,(/0,ind1/)) 552 696 553 697 ! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities) … … 557 701 CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) 558 702 CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) 559 # else703 # else 560 704 CALL Agrif_Set_Updatetype(tra_ice_id, update = AGRIF_Update_Average) 561 705 CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) 562 706 CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) 563 # endif707 # endif 564 708 565 709 END SUBROUTINE agrif_declare_var_ice … … 584 728 USE agrif_top_interp 585 729 USE agrif_top_sponge 586 ! !730 ! 587 731 IMPLICIT NONE 588 732 ! … … 604 748 tabspongedone_trn = .FALSE. 605 749 CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 606 ! reset ts (:,:,:,:,Krhs_a)to zero607 tr (:,:,:,:,Krhs_a) = 0._wp750 ! reset tsa to zero 751 tra(:,:,:,:) = 0._wp 608 752 609 753 ! 3. Some controls … … 613 757 IF( check_namelist ) THEN 614 758 ! Check time steps 615 IF( NINT(Agrif_Rhot()) * NINT(rn_Dt) .NE. Agrif_Parent(rn_Dt) ) THEN616 WRITE(cl_check1,*) Agrif_Parent(rn_Dt)617 WRITE(cl_check2,*) rn_Dt618 WRITE(cl_check3,*) rn_Dt*Agrif_Rhot()619 CALL ctl_stop( 'incompatible time step between grids', &759 IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 760 WRITE(cl_check1,*) Agrif_Parent(rdt) 761 WRITE(cl_check2,*) rdt 762 WRITE(cl_check3,*) rdt*Agrif_Rhot() 763 CALL ctl_stop( 'incompatible time step between grids', & 620 764 & 'parent grid value : '//cl_check1 , & 621 765 & 'child grid value : '//cl_check2 , & 622 766 & 'value on child grid should be changed to & 623 767 & :'//cl_check3 ) 624 ENDIF625 626 ! Check run length627 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- &768 ENDIF 769 770 ! Check run length 771 IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 628 772 Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 629 WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1630 WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot()631 CALL ctl_warn( 'incompatible run length between grids' , &773 WRITE(cl_check1,*) (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 774 WRITE(cl_check2,*) Agrif_Parent(nitend) *Agrif_IRhot() 775 CALL ctl_warn( 'incompatible run length between grids' , & 632 776 & ' nit000 on fine grid will be change to : '//cl_check1, & 633 777 & ' nitend on fine grid will be change to : '//cl_check2 ) 634 nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 635 nitend = Agrif_Parent(nitend) *Agrif_IRhot() 636 ENDIF 637 638 ENDIF 639 ! 778 nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 779 nitend = Agrif_Parent(nitend) *Agrif_IRhot() 780 ENDIF 781 ENDIF 782 ! 640 783 END SUBROUTINE Agrif_InitValues_cont_top 641 784 … … 654 797 INTEGER :: ind1, ind2, ind3 655 798 !!---------------------------------------------------------------------- 656 799 !RB_CMEMS : declare here init for top 657 800 ! 1. Declaration of the type of variable which have to be interpolated 658 801 !--------------------------------------------------------------------- 659 ind1 = nbghostcells660 ind2 = 1 + nbghostcells661 ind3 = 2 + nbghostcells802 ind1 = nbghostcells 803 ind2 = nn_hls + 2 + nbghostcells_x 804 ind3 = nn_hls + 2 + nbghostcells_y_s 662 805 # if defined key_vertical 663 CALL agrif_declare_variable((/2,2,0,0/),(/ind 3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_id)664 CALL agrif_declare_variable((/2,2,0,0/),(/ind 3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_sponge_id)806 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) 807 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) 665 808 # else 666 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 667 CALL agrif_declare_variable((/2,2,0,0/),(/ind3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 809 ! LAURENT: STRANGE why (3,3) here ? 810 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) 811 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) 668 812 # endif 669 813 … … 688 832 END SUBROUTINE agrif_declare_var_top 689 833 # endif 834 690 835 691 836 SUBROUTINE Agrif_detect( kg, ksizex ) … … 701 846 END SUBROUTINE Agrif_detect 702 847 848 703 849 SUBROUTINE agrif_nemo_init 704 850 !!---------------------------------------------------------------------- … … 707 853 USE agrif_oce 708 854 USE agrif_ice 855 USE dom_oce 709 856 USE in_out_manager 710 857 USE lib_mpp 711 ! !858 ! 712 859 IMPLICIT NONE 713 860 ! 714 861 INTEGER :: ios ! Local integer output status for namelist read 715 NAMELIST/namagrif/ ln_agrif_2way, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, &862 NAMELIST/namagrif/ ln_agrif_2way, ln_init_chfrpar, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, & 716 863 & ln_spc_dyn, ln_chk_bathy 717 864 !!-------------------------------------------------------------------------------------- … … 729 876 WRITE(numout,*) ' Namelist namagrif : set AGRIF parameters' 730 877 WRITE(numout,*) ' Two way nesting activated ln_agrif_2way = ', ln_agrif_2way 731 WRITE(numout,*) ' sponge coefficient for tracers rn_sponge_tra = ', rn_sponge_tra, ' m^2/s' 732 WRITE(numout,*) ' sponge coefficient for dynamics rn_sponge_tra = ', rn_sponge_dyn, ' m^2/s' 733 WRITE(numout,*) ' time relaxation for tracers rn_trelax_tra = ', rn_trelax_tra, ' ad.' 734 WRITE(numout,*) ' time relaxation for dynamics rn_trelax_dyn = ', rn_trelax_dyn, ' ad.' 878 WRITE(numout,*) ' child initial state from parent ln_init_chfrpar = ', ln_init_chfrpar 879 WRITE(numout,*) ' ad. sponge coeft for tracers rn_sponge_tra = ', rn_sponge_tra 880 WRITE(numout,*) ' ad. sponge coeft for dynamics rn_sponge_tra = ', rn_sponge_dyn 881 WRITE(numout,*) ' ad. time relaxation for tracers rn_trelax_tra = ', rn_trelax_tra 882 WRITE(numout,*) ' ad. time relaxation for dynamics rn_trelax_dyn = ', rn_trelax_dyn 735 883 WRITE(numout,*) ' use special values for dynamics ln_spc_dyn = ', ln_spc_dyn 736 884 WRITE(numout,*) ' check bathymetry ln_chk_bathy = ', ln_chk_bathy 737 885 ENDIF 738 ! 739 ! 740 IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 886 887 lk_west = .NOT. ( Agrif_Ix() == 1 ) 888 lk_east = .NOT. ( Agrif_Ix() + nbcellsx/AGRIF_Irhox() == Agrif_Parent(jpiglo) -1 ) 889 lk_south = .NOT. ( Agrif_Iy() == 1 ) 890 lk_north = .NOT. ( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() == Agrif_Parent(jpjglo) -1 ) 891 892 ! 893 ! Set the number of ghost cells according to periodicity 894 nbghostcells_x = nbghostcells 895 nbghostcells_y_s = nbghostcells 896 nbghostcells_y_n = nbghostcells 897 ! 898 IF( jperio == 1 ) nbghostcells_x = 0 899 IF( .NOT. lk_south ) nbghostcells_y_s = 0 900 ! Some checks 901 IF( jpiglo /= nbcellsx + 2 + 2*nn_hls + nbghostcells_x + nbghostcells_x ) CALL ctl_stop( 'STOP', & 902 & 'agrif_nemo_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nn_hls + 2*nbghostcells_x' ) 903 IF( jpjglo /= nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n ) CALL ctl_stop( 'STOP', & 904 & 'agrif_nemo_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nn_hls + nbghostcells_y_s + nbghostcells_y_n' ) 905 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'agrif_nemo_init:Agrif children requires ln_use_jattr = .false. ' ) 741 906 ! 742 907 END SUBROUTINE agrif_nemo_init 743 908 909 744 910 # if defined key_mpp_mpi 745 746 911 SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob ) 747 912 !!---------------------------------------------------------------------- … … 756 921 ! 757 922 SELECT CASE( i ) 758 CASE(1) ; indglob = indloc + nimppt(nprocloc+1) - 1 759 CASE(2) ; indglob = indloc + njmppt(nprocloc+1) - 1 760 CASE DEFAULT 761 indglob = indloc 923 CASE(1) ; indglob = mig(indloc) 924 CASE(2) ; indglob = mjg(indloc) 925 CASE DEFAULT ; indglob = indloc 762 926 END SELECT 763 927 ! 764 928 END SUBROUTINE Agrif_InvLoc 765 929 930 766 931 SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 767 932 !!---------------------------------------------------------------------- … … 776 941 !!---------------------------------------------------------------------- 777 942 ! 778 imin = nimppt(Agrif_Procrank+1) ! ?????779 jmin = njmppt(Agrif_Procrank+1) ! ?????780 imax = imin + jpi - 1781 jmax = jmin + jpj - 1943 imin = mig( 1 ) 944 jmin = mjg( 1 ) 945 imax = mig(jpi) 946 jmax = mjg(jpj) 782 947 ! 783 948 END SUBROUTINE Agrif_get_proc_info 784 949 950 785 951 SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 786 952 !!---------------------------------------------------------------------- … … 803 969 # endif 804 970 971 SUBROUTINE nemo_mapping(ndim,ptx,pty,bounds,bounds_chunks,correction_required,nb_chunks) 972 !!---------------------------------------------------------------------- 973 !! *** ROUTINE Nemo_mapping *** 974 !!---------------------------------------------------------------------- 975 USE dom_oce 976 !! 977 IMPLICIT NONE 978 ! 979 INTEGER :: ndim 980 INTEGER :: ptx, pty 981 INTEGER, DIMENSION(ndim,2,2) :: bounds 982 INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: bounds_chunks 983 LOGICAL, DIMENSION(:), ALLOCATABLE :: correction_required 984 INTEGER :: nb_chunks 985 ! 986 INTEGER :: i 987 988 IF (agrif_debug_interp) THEN 989 DO i=1,ndim 990 WRITE(*,*) 'direction = ',i,bounds(i,1,2),bounds(i,2,2) 991 ENDDO 992 ENDIF 993 994 IF( bounds(2,2,2) > jpjglo) THEN 995 IF( bounds(2,1,2) <=jpjglo) THEN 996 nb_chunks = 2 997 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 998 ALLOCATE(correction_required(nb_chunks)) 999 DO i = 1,nb_chunks 1000 bounds_chunks(i,:,:,:) = bounds 1001 END DO 1002 1003 ! FIRST CHUNCK (for j<=jpjglo) 1004 1005 ! Original indices 1006 bounds_chunks(1,1,1,1) = bounds(1,1,2) 1007 bounds_chunks(1,1,2,1) = bounds(1,2,2) 1008 bounds_chunks(1,2,1,1) = bounds(2,1,2) 1009 bounds_chunks(1,2,2,1) = jpjglo 1010 1011 bounds_chunks(1,1,1,2) = bounds(1,1,2) 1012 bounds_chunks(1,1,2,2) = bounds(1,2,2) 1013 bounds_chunks(1,2,1,2) = bounds(2,1,2) 1014 bounds_chunks(1,2,2,2) = jpjglo 1015 1016 ! Correction required or not 1017 correction_required(1)=.FALSE. 1018 1019 ! SECOND CHUNCK (for j>jpjglo) 1020 1021 ! Original indices 1022 bounds_chunks(2,1,1,1) = bounds(1,1,2) 1023 bounds_chunks(2,1,2,1) = bounds(1,2,2) 1024 bounds_chunks(2,2,1,1) = jpjglo-2 1025 bounds_chunks(2,2,2,1) = bounds(2,2,2) 1026 1027 ! Where to find them 1028 ! We use the relation TAB(ji,jj)=TAB(jpiglo-ji+2,jpjglo-2-(jj-jpjglo)) 1029 1030 IF( ptx == 2) THEN ! T, V points 1031 bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+2 1032 bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+2 1033 ELSE ! U, F points 1034 bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+1 1035 bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+1 1036 ENDIF 1037 1038 IF( pty == 2) THEN ! T, U points 1039 bounds_chunks(2,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo) 1040 bounds_chunks(2,2,2,2) = jpjglo-2-(jpjglo-2 -jpjglo) 1041 ELSE ! V, F points 1042 bounds_chunks(2,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo) 1043 bounds_chunks(2,2,2,2) = jpjglo-3-(jpjglo-2 -jpjglo) 1044 ENDIF 1045 ! Correction required or not 1046 correction_required(2)=.TRUE. 1047 1048 ELSE 1049 nb_chunks = 1 1050 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 1051 ALLOCATE(correction_required(nb_chunks)) 1052 DO i=1,nb_chunks 1053 bounds_chunks(i,:,:,:) = bounds 1054 END DO 1055 1056 bounds_chunks(1,1,1,1) = bounds(1,1,2) 1057 bounds_chunks(1,1,2,1) = bounds(1,2,2) 1058 bounds_chunks(1,2,1,1) = bounds(2,1,2) 1059 bounds_chunks(1,2,2,1) = bounds(2,2,2) 1060 1061 bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2 1062 bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2 1063 1064 bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2)-jpjglo) 1065 bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2)-jpjglo) 1066 1067 IF( ptx == 2) THEN ! T, V points 1068 bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2 1069 bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2 1070 ELSE ! U, F points 1071 bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+1 1072 bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+1 1073 ENDIF 1074 1075 IF (pty == 2) THEN ! T, U points 1076 bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo) 1077 bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2) -jpjglo) 1078 ELSE ! V, F points 1079 bounds_chunks(1,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo) 1080 bounds_chunks(1,2,2,2) = jpjglo-3-(bounds(2,1,2) -jpjglo) 1081 ENDIF 1082 1083 correction_required(1)=.TRUE. 1084 ENDIF 1085 1086 ELSE IF (bounds(1,1,2) < 1) THEN 1087 IF (bounds(1,2,2) > 0) THEN 1088 nb_chunks = 2 1089 ALLOCATE(correction_required(nb_chunks)) 1090 correction_required=.FALSE. 1091 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 1092 DO i=1,nb_chunks 1093 bounds_chunks(i,:,:,:) = bounds 1094 END DO 1095 1096 bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2 1097 bounds_chunks(1,1,2,2) = 1+jpiglo-2 1098 1099 bounds_chunks(1,1,1,1) = bounds(1,1,2) 1100 bounds_chunks(1,1,2,1) = 1 1101 1102 bounds_chunks(2,1,1,2) = 2 1103 bounds_chunks(2,1,2,2) = bounds(1,2,2) 1104 1105 bounds_chunks(2,1,1,1) = 2 1106 bounds_chunks(2,1,2,1) = bounds(1,2,2) 1107 1108 ELSE 1109 nb_chunks = 1 1110 ALLOCATE(correction_required(nb_chunks)) 1111 correction_required=.FALSE. 1112 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 1113 DO i=1,nb_chunks 1114 bounds_chunks(i,:,:,:) = bounds 1115 END DO 1116 bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2 1117 bounds_chunks(1,1,2,2) = bounds(1,2,2)+jpiglo-2 1118 1119 bounds_chunks(1,1,1,1) = bounds(1,1,2) 1120 bounds_chunks(1,1,2,1) = bounds(1,2,2) 1121 ENDIF 1122 ELSE 1123 nb_chunks=1 1124 ALLOCATE(correction_required(nb_chunks)) 1125 correction_required=.FALSE. 1126 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 1127 DO i=1,nb_chunks 1128 bounds_chunks(i,:,:,:) = bounds 1129 END DO 1130 bounds_chunks(1,1,1,2) = bounds(1,1,2) 1131 bounds_chunks(1,1,2,2) = bounds(1,2,2) 1132 bounds_chunks(1,2,1,2) = bounds(2,1,2) 1133 bounds_chunks(1,2,2,2) = bounds(2,2,2) 1134 1135 bounds_chunks(1,1,1,1) = bounds(1,1,2) 1136 bounds_chunks(1,1,2,1) = bounds(1,2,2) 1137 bounds_chunks(1,2,1,1) = bounds(2,1,2) 1138 bounds_chunks(1,2,2,1) = bounds(2,2,2) 1139 ENDIF 1140 1141 END SUBROUTINE nemo_mapping 1142 1143 FUNCTION agrif_external_switch_index(ptx,pty,i1,isens) 1144 1145 USE dom_oce 1146 ! 1147 IMPLICIT NONE 1148 1149 INTEGER :: ptx, pty, i1, isens 1150 INTEGER :: agrif_external_switch_index 1151 !!---------------------------------------------------------------------- 1152 1153 IF( isens == 1 ) THEN 1154 IF( ptx == 2 ) THEN ! T, V points 1155 agrif_external_switch_index = jpiglo-i1+2 1156 ELSE ! U, F points 1157 agrif_external_switch_index = jpiglo-i1+1 1158 ENDIF 1159 ELSE IF( isens ==2 ) THEN 1160 IF ( pty == 2 ) THEN ! T, U points 1161 agrif_external_switch_index = jpjglo-2-(i1 -jpjglo) 1162 ELSE ! V, F points 1163 agrif_external_switch_index = jpjglo-3-(i1 -jpjglo) 1164 ENDIF 1165 ENDIF 1166 1167 END FUNCTION agrif_external_switch_index 1168 1169 SUBROUTINE Correct_field(tab2d,i1,i2,j1,j2) 1170 !!---------------------------------------------------------------------- 1171 !! *** ROUTINE Correct_field *** 1172 !!---------------------------------------------------------------------- 1173 USE dom_oce 1174 USE agrif_oce 1175 ! 1176 IMPLICIT NONE 1177 ! 1178 INTEGER :: i1,i2,j1,j2 1179 REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2d 1180 ! 1181 INTEGER :: i,j 1182 REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2dtemp 1183 !!---------------------------------------------------------------------- 1184 1185 tab2dtemp = tab2d 1186 1187 IF( .NOT. use_sign_north ) THEN 1188 DO j=j1,j2 1189 DO i=i1,i2 1190 tab2d(i,j)=tab2dtemp(i2-(i-i1),j2-(j-j1)) 1191 END DO 1192 END DO 1193 ELSE 1194 DO j=j1,j2 1195 DO i=i1,i2 1196 tab2d(i,j)=sign_north * tab2dtemp(i2-(i-i1),j2-(j-j1)) 1197 END DO 1198 END DO 1199 ENDIF 1200 1201 END SUBROUTINE Correct_field 1202 805 1203 #else 806 1204 SUBROUTINE Subcalledbyagrif
Note: See TracChangeset
for help on using the changeset viewer.
