Changeset 13216 for NEMO/trunk/src/NST
- Timestamp:
- 2020-07-02T11:25:49+02:00 (4 years ago)
- Location:
- NEMO/trunk
- Files:
-
- 10 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/trunk
- Property svn:externals
-
old new 2 2 ^/utils/build/makenemo@HEAD makenemo 3 3 ^/utils/build/mk@HEAD mk 4 ^/utils/tools @HEADtools5 ^/vendors/AGRIF/dev @HEADext/AGRIF4 ^/utils/tools/@HEAD tools 5 ^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL
-
- Property svn:externals
-
NEMO/trunk/src/NST/agrif_ice.F90
r10068 r13216 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/trunk/src/NST/agrif_ice_interp.F90
r10069 r13216 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 -
NEMO/trunk/src/NST/agrif_ice_update.F90
r12377 r13216 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 ) -
NEMO/trunk/src/NST/agrif_oce.F90
r12377 r13216 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 … … 68 69 INTEGER, PUBLIC :: mbkt_id, ht0_id 69 70 INTEGER, PUBLIC :: kindic_agr 71 72 ! North fold 73 !$AGRIF_DO_NOT_TREAT 74 LOGICAL, PUBLIC :: use_sign_north 75 REAL, PUBLIC :: sign_north 76 LOGICAL, PUBLIC :: l_ini_child = .FALSE. 77 # if defined key_vertical 78 LOGICAL, PUBLIC :: l_vremap = .TRUE. 79 # else 80 LOGICAL, PUBLIC :: l_vremap = .FALSE. 81 # endif 82 !$AGRIF_END_DO_NOT_TREAT 70 83 71 84 !!---------------------------------------------------------------------- … … 91 104 & tabspongedone_trn(jpi,jpj), & 92 105 # endif 93 # if defined key_vertical94 106 & ht0_parent(jpi,jpj), mbkt_parent(jpi,jpj), & 95 107 & hu0_parent(jpi,jpj), mbku_parent(jpi,jpj), & 96 108 & hv0_parent(jpi,jpj), mbkv_parent(jpi,jpj), & 97 # endif98 109 & tabspongedone_u (jpi,jpj), & 99 110 & tabspongedone_v (jpi,jpj), STAT = ierr(1) ) -
NEMO/trunk/src/NST/agrif_oce_interp.F90
r12377 r13216 34 34 USE lib_mpp 35 35 USE vremap 36 USE lbclnk 36 37 37 38 IMPLICIT NONE … … 44 45 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b 45 46 PUBLIC interpe3t 46 #if defined key_vertical47 47 PUBLIC interpht0, interpmbkt 48 # endif 48 PUBLIC agrif_initts, agrif_initssh 49 49 50 INTEGER :: bdy_tinterp = 0 50 51 … … 89 90 Agrif_UseSpecialValue = ln_spc_dyn 90 91 ! 92 use_sign_north = .TRUE. 93 sign_north = -1. 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 = 2 103 ibdy2 = 1+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 109 DO jk = 1, jpkm1 110 DO jj = 1, jpj 111 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 112 END DO 113 END DO 114 115 DO jj = 1, jpj 116 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 117 END DO 118 END DO 119 ENDIF 120 ! 101 121 DO ji = mi0(ibdy1), mi1(ibdy2) 102 uu_b(ji,:,Krhs_a) = 0._wp 103 122 zub(ji,:) = 0._wp ! Correct transport 104 123 DO jk = 1, jpkm1 105 124 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 125 zub(ji,jj) = zub(ji,jj) & 126 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a)*umask(ji,jj,jk) 127 END DO 128 END DO 129 DO jj=1,jpj 130 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 131 END DO 132 138 133 DO jk = 1, jpkm1 139 134 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 135 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) 136 END DO 137 END DO 138 END DO 139 140 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 141 DO ji = mi0(ibdy1), mi1(ibdy2) 142 zvb(ji,:) = 0._wp 143 DO jk = 1, jpkm1 144 DO jj = 1, jpj 145 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 146 END DO 147 END DO 148 DO jj = 1, jpj 149 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 150 END DO 151 DO jk = 1, jpkm1 152 DO jj = 1, jpj 153 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) 154 END DO 155 END DO 156 END DO 157 ENDIF 158 ENDIF 159 160 ! --- East --- ! 161 IF( lk_east) THEN 162 ibdy1 = jpiglo-1-nbghostcells 163 ibdy2 = jpiglo-2 164 ! 165 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 166 DO ji = mi0(ibdy1), mi1(ibdy2) 167 uu_b(ji,:,Krhs_a) = 0._wp 168 DO jk = 1, jpkm1 169 DO jj = 1, jpj 170 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) & 171 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 172 END DO 173 END DO 174 DO jj = 1, jpj 175 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 176 END DO 177 END DO 178 ENDIF 179 ! 180 DO ji = mi0(ibdy1), mi1(ibdy2) 181 zub(ji,:) = 0._wp ! Correct transport 146 182 DO jk = 1, jpkm1 147 183 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 184 zub(ji,jj) = zub(ji,jj) & 185 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 186 END DO 187 END DO 188 DO jj=1,jpj 189 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 190 END DO 191 161 192 DO jk = 1, jpkm1 162 193 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 194 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 195 & + uu_b(ji,jj,Krhs_a)-zub(ji,jj))*umask(ji,jj,jk) 196 END DO 197 END DO 198 END DO 199 200 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 201 ibdy1 = jpiglo-nbghostcells 202 ibdy2 = jpiglo-1 203 DO ji = mi0(ibdy1), mi1(ibdy2) 204 zvb(ji,:) = 0._wp 205 DO jk = 1, jpkm1 206 DO jj = 1, jpj 207 zvb(ji,jj) = zvb(ji,jj) & 208 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 209 END DO 210 END DO 199 211 DO jj = 1, jpj 200 zvb(ji,jj) = zvb(ji,jj) & 212 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 213 END DO 214 DO jk = 1, jpkm1 215 DO jj = 1, jpj 216 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 217 & + vv_b(ji,jj,Krhs_a)-zvb(ji,jj)) * vmask(ji,jj,jk) 218 END DO 219 END DO 220 END DO 221 ENDIF 222 ENDIF 223 224 ! --- South --- ! 225 IF( lk_south ) THEN 226 jbdy1 = 2 227 jbdy2 = 1+nbghostcells 228 ! 229 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 230 DO jj = mj0(jbdy1), mj1(jbdy2) 231 vv_b(:,jj,Krhs_a) = 0._wp 232 DO jk = 1, jpkm1 233 DO ji = 1, jpi 234 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) & 235 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 236 END DO 237 END DO 238 DO ji=1,jpi 239 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 240 END DO 241 END DO 242 ENDIF 243 ! 244 DO jj = mj0(jbdy1), mj1(jbdy2) 245 zvb(:,jj) = 0._wp ! Correct transport 246 DO jk=1,jpkm1 247 DO ji=1,jpi 248 zvb(ji,jj) = zvb(ji,jj) & 201 249 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 202 250 END DO 203 251 END DO 204 DO j j = 1, jpj252 DO ji = 1, jpi 205 253 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 206 254 END DO 207 DO jk = 1, jpkm1 208 DO jj = 1, jpj 209 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 DO 212 END DO 213 END DO 214 ENDIF 215 216 ! --- South --- ! 217 jbdy1 = 2 218 jbdy2 = 1+nbghostcells 219 ! 220 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 221 DO jj = mj0(jbdy1), mj1(jbdy2) 222 vv_b(:,jj,Krhs_a) = 0._wp 255 223 256 DO jk = 1, jpkm1 224 257 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 258 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 259 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 260 END DO 261 END DO 262 END DO 263 264 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 265 DO jj = mj0(jbdy1), mj1(jbdy2) 266 zub(:,jj) = 0._wp 267 DO jk = 1, jpkm1 268 DO ji = 1, jpi 269 zub(ji,jj) = zub(ji,jj) & 270 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 271 END DO 272 END DO 273 DO ji = 1, jpi 274 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 275 END DO 276 277 DO jk = 1, jpkm1 278 DO ji = 1, jpi 279 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 280 & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 281 END DO 282 END DO 283 END DO 284 ENDIF 285 ENDIF 286 287 ! --- North --- ! 288 IF( lk_north ) THEN 289 jbdy1 = jpjglo-1-nbghostcells 290 jbdy2 = jpjglo-2 291 ! 292 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 293 DO jj = mj0(jbdy1), mj1(jbdy2) 294 vv_b(:,jj,Krhs_a) = 0._wp 295 DO jk = 1, jpkm1 296 DO ji = 1, jpi 297 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) & 298 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 299 END DO 300 END DO 301 DO ji=1,jpi 302 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 303 END DO 304 END DO 305 ENDIF 306 ! 307 DO jj = mj0(jbdy1), mj1(jbdy2) 308 zvb(:,jj) = 0._wp ! Correct transport 309 DO jk=1,jpkm1 310 DO ji=1,jpi 311 zvb(ji,jj) = zvb(ji,jj) & 312 & + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 313 END DO 314 END DO 248 315 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 316 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 317 END DO 318 258 319 DO jk = 1, jpkm1 259 320 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 321 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) & 322 & + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 323 END DO 324 END DO 325 END DO 267 326 268 DO jk = 1, jpkm1 327 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 328 jbdy1 = jpjglo-nbghostcells 329 jbdy2 = jpjglo-1 330 DO jj = mj0(jbdy1), mj1(jbdy2) 331 zub(:,jj) = 0._wp 332 DO jk = 1, jpkm1 333 DO ji = 1, jpi 334 zub(ji,jj) = zub(ji,jj) & 335 & + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 336 END DO 337 END DO 269 338 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 339 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 340 END DO 341 342 DO jk = 1, jpkm1 343 DO ji = 1, jpi 344 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) & 345 & + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 346 END DO 347 END DO 348 END DO 349 ENDIF 338 350 ENDIF 339 351 ! … … 354 366 ! 355 367 !--- 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 368 IF( lk_west ) THEN 369 istart = 2 370 iend = nbghostcells+1 371 DO ji = mi0(istart), mi1(iend) 372 DO jj=1,jpj 373 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 374 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 375 END DO 376 END DO 377 ENDIF 364 378 ! 365 379 !--- 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 380 IF( lk_east ) THEN 381 istart = jpiglo-nbghostcells 382 iend = jpiglo-1 383 DO ji = mi0(istart), mi1(iend) 384 385 DO jj=1,jpj 386 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 387 END DO 388 END DO 389 istart = jpiglo-nbghostcells-1 390 iend = jpiglo-2 391 DO ji = mi0(istart), mi1(iend) 392 DO jj=1,jpj 393 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 394 END DO 395 END DO 396 ENDIF 380 397 ! 381 398 !--- 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 399 IF( lk_south ) THEN 400 jstart = 2 401 jend = nbghostcells+1 402 DO jj = mj0(jstart), mj1(jend) 403 404 DO ji=1,jpi 405 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 406 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 407 END DO 408 END DO 409 ENDIF 390 410 ! 391 411 !--- 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 412 IF( lk_north ) THEN 413 jstart = jpjglo-nbghostcells 414 jend = jpjglo-1 415 DO jj = mj0(jstart), mj1(jend) 416 DO ji=1,jpi 417 ua_e(ji,jj) = ubdy(ji,jj) * hur_e(ji,jj) 418 END DO 419 END DO 420 jstart = jpjglo-nbghostcells-1 421 jend = jpjglo-2 422 DO jj = mj0(jstart), mj1(jend) 423 DO ji=1,jpi 424 va_e(ji,jj) = vbdy(ji,jj) * hvr_e(ji,jj) 425 END DO 426 END DO 427 ENDIF 406 428 ! 407 429 END SUBROUTINE Agrif_dyn_ts … … 421 443 ! 422 444 !--- 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 445 IF( lk_west ) THEN 446 istart = 2 447 iend = nbghostcells+1 448 DO ji = mi0(istart), mi1(iend) 449 DO jj=1,jpj 450 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 451 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 452 END DO 453 END DO 454 ENDIF 431 455 ! 432 456 !--- 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 457 IF( lk_east ) THEN 458 istart = jpiglo-nbghostcells 459 iend = jpiglo-1 460 DO ji = mi0(istart), mi1(iend) 461 DO jj=1,jpj 462 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 463 END DO 464 END DO 465 istart = jpiglo-nbghostcells-1 466 iend = jpiglo-2 467 DO ji = mi0(istart), mi1(iend) 468 DO jj=1,jpj 469 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 470 END DO 471 END DO 472 ENDIF 447 473 ! 448 474 !--- 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 475 IF( lk_south ) THEN 476 jstart = 2 477 jend = nbghostcells+1 478 DO jj = mj0(jstart), mj1(jend) 479 DO ji=1,jpi 480 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 481 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 482 END DO 483 END DO 484 ENDIF 457 485 ! 458 486 !--- 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 487 IF( lk_north ) THEN 488 jstart = jpjglo-nbghostcells 489 jend = jpjglo-1 490 DO jj = mj0(jstart), mj1(jend) 491 DO ji=1,jpi 492 zu(ji,jj) = ubdy(ji,jj) * e2u(ji,jj) 493 END DO 494 END DO 495 jstart = jpjglo-nbghostcells-1 496 jend = jpjglo-2 497 DO jj = mj0(jstart), mj1(jend) 498 DO ji=1,jpi 499 zv(ji,jj) = vbdy(ji,jj) * e1v(ji,jj) 500 END DO 501 END DO 502 ENDIF 473 503 ! 474 504 END SUBROUTINE Agrif_dyn_ts_flux … … 494 524 Agrif_SpecialValue = 0._wp 495 525 Agrif_UseSpecialValue = ln_spc_dyn 526 527 use_sign_north = .TRUE. 528 sign_north = -1. 529 496 530 ! 497 531 ! Set bdy time interpolation stage to 0 (latter incremented locally do deal with corners) … … 518 552 ENDIF 519 553 Agrif_UseSpecialValue = .FALSE. 554 use_sign_north = .FALSE. 520 555 ! 521 556 END SUBROUTINE Agrif_dta_ts … … 542 577 ! 543 578 ! --- 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) 579 IF(lk_west) THEN 580 istart = 2 581 iend = 1 + nbghostcells 582 DO ji = mi0(istart), mi1(iend) 583 DO jj = 1, jpj 584 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 585 ENDDO 549 586 ENDDO 550 END DO587 ENDIF 551 588 ! 552 589 ! --- 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) 590 IF(lk_east) THEN 591 istart = jpiglo - nbghostcells 592 iend = jpiglo - 1 593 DO ji = mi0(istart), mi1(iend) 594 DO jj = 1, jpj 595 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 596 ENDDO 558 597 ENDDO 559 END DO598 ENDIF 560 599 ! 561 600 ! --- 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) 601 IF(lk_south) THEN 602 jstart = 2 603 jend = 1 + nbghostcells 604 DO jj = mj0(jstart), mj1(jend) 605 DO ji = 1, jpi 606 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 607 ENDDO 567 608 ENDDO 568 END DO609 ENDIF 569 610 ! 570 611 ! --- 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) 612 IF(lk_north) THEN 613 jstart = jpjglo - nbghostcells 614 jend = jpjglo - 1 615 DO jj = mj0(jstart), mj1(jend) 616 DO ji = 1, jpi 617 ssh(ji,jj,Krhs_a) = hbdy(ji,jj) 618 ENDDO 576 619 ENDDO 577 END DO620 ENDIF 578 621 ! 579 622 END SUBROUTINE Agrif_ssh … … 593 636 ! 594 637 ! --- 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) 638 IF(lk_west) THEN 639 istart = 2 640 iend = 1+nbghostcells 641 DO ji = mi0(istart), mi1(iend) 642 DO jj = 1, jpj 643 ssha_e(ji,jj) = hbdy(ji,jj) 644 ENDDO 600 645 ENDDO 601 END DO646 ENDIF 602 647 ! 603 648 ! --- 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) 649 IF(lk_east) THEN 650 istart = jpiglo - nbghostcells 651 iend = jpiglo - 1 652 DO ji = mi0(istart), mi1(iend) 653 DO jj = 1, jpj 654 ssha_e(ji,jj) = hbdy(ji,jj) 655 ENDDO 609 656 ENDDO 610 END DO657 ENDIF 611 658 ! 612 659 ! --- 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) 660 IF(lk_south) THEN 661 jstart = 2 662 jend = 1+nbghostcells 663 DO jj = mj0(jstart), mj1(jend) 664 DO ji = 1, jpi 665 ssha_e(ji,jj) = hbdy(ji,jj) 666 ENDDO 618 667 ENDDO 619 END DO668 ENDIF 620 669 ! 621 670 ! --- 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) 671 IF(lk_north) THEN 672 jstart = jpjglo - nbghostcells 673 jend = jpjglo - 1 674 DO jj = mj0(jstart), mj1(jend) 675 DO ji = 1, jpi 676 ssha_e(ji,jj) = hbdy(ji,jj) 677 ENDDO 627 678 ENDDO 628 END DO679 ENDIF 629 680 ! 630 681 END SUBROUTINE Agrif_ssh_ts … … 662 713 INTEGER :: ji, jj, jk, jn ! dummy loop indices 663 714 INTEGER :: N_in, N_out 715 INTEGER :: item 664 716 ! vertical interpolation: 665 717 REAL(wp) :: zhtot 666 718 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 719 REAL(wp), DIMENSION(k1:k2) :: h_in, z_in 720 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 721 !!---------------------------------------------------------------------- 722 723 IF( before ) THEN 724 725 item = Kmm_a 726 IF( l_ini_child ) Kmm_a = Kbb_a 727 672 728 DO jn = 1,jpts 673 729 DO jk=k1,k2 … … 678 734 END DO 679 735 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 736 END DO 737 738 IF( l_vremap .OR. l_ini_child) THEN 739 ! Interpolate thicknesses 740 ! Warning: these are masked, hence extrapolated prior interpolation. 741 DO jk=k1,k2 742 DO jj=j1,j2 743 DO ji=i1,i2 744 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 745 746 END DO 747 END DO 748 END DO 749 750 ! Extrapolate thicknesses in partial bottom cells: 751 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 752 IF (ln_zps) THEN 753 DO jj=j1,j2 754 DO ji=i1,i2 755 jk = mbkt(ji,jj) 756 ptab(ji,jj,jk,jpts+1) = 0._wp 757 END DO 758 END DO 759 END IF 760 761 ! Save ssh at last level: 762 IF (.NOT.ln_linssh) THEN 763 ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 764 ELSE 765 ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp 766 END IF 767 ENDIF 768 Kmm_a = item 769 711 770 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) 771 item = Krhs_a 772 IF( l_ini_child ) Krhs_a = Kbb_a 773 774 IF( l_vremap .OR. l_ini_child ) THEN 775 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 776 777 DO jj=j1,j2 778 DO ji=i1,i2 779 ts(ji,jj,:,:,Krhs_a) = 0. 780 ! IF( l_ini_child) ts(ji,jj,:,:,Krhs_a) = ptab(ji,jj,:,1:jpts) 781 N_in = mbkt_parent(ji,jj) 782 zhtot = 0._wp 783 DO jk=1,N_in !k2 = jpk of parent grid 784 IF (jk==N_in) THEN 785 h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot 786 ELSE 787 h_in(jk) = ptab(ji,jj,jk,n2) 788 ENDIF 789 zhtot = zhtot + h_in(jk) 790 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 791 END DO 792 z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj) 793 DO jk=2,N_in 794 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 795 ENDDO 796 797 N_out = 0 798 DO jk=1,jpk ! jpk of child grid 799 IF (tmask(ji,jj,jk) == 0._wp) EXIT 800 N_out = N_out + 1 801 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 802 ENDDO 803 804 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj) 805 DO jk=2,N_out 806 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 807 ENDDO 808 809 IF (N_in*N_out > 0) THEN 810 IF( l_ini_child ) THEN 811 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 812 & z_out(1:N_out),N_in,N_out,jpts) 813 ELSE 814 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 815 & h_out(1:N_out),N_in,N_out,jpts) 816 ENDIF 726 817 ENDIF 727 zhtot = zhtot + h_in(jk)728 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1)729 END DO730 N_out = 0731 DO jk=1,jpk ! jpk of child grid732 IF (tmask(ji,jj,jk) == 0._wp) EXIT733 N_out = N_out + 1734 h_out(jk) = e3t(ji,jj,jk,Krhs_a)735 818 ENDDO 736 IF (N_in*N_out > 0) THEN737 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 ENDIF739 819 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 820 Krhs_a = item 821 822 ELSE 823 824 DO jn=1, jpts 825 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) 826 END DO 827 ENDIF 747 828 748 829 ENDIF … … 780 861 REAL(wp) :: zrhoy, zhtot 781 862 ! 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 863 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in 864 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 865 INTEGER :: N_in, N_out,item 785 866 REAL(wp) :: h_diff 786 867 !!--------------------------------------------- 787 868 ! 788 869 IF (before) THEN 870 871 item = Kmm_a 872 IF( l_ini_child ) Kmm_a = Kbb_a 873 789 874 DO jk=1,jpk 790 875 DO jj=j1,j2 791 876 DO ji=i1,i2 792 877 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 878 IF( l_vremap .OR. l_ini_child) THEN 879 ! Interpolate thicknesses (masked for subsequent extrapolation) 880 ptab(ji,jj,jk,2) = umask(ji,jj,jk) * e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 881 ENDIF 882 END DO 883 END DO 884 END DO 885 886 IF( l_vremap .OR. l_ini_child) THEN 801 887 ! Extrapolate thicknesses in partial bottom cells: 802 888 ! 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 889 IF (ln_zps) THEN 890 DO jj=j1,j2 891 DO ji=i1,i2 892 jk = mbku(ji,jj) 893 ptab(ji,jj,jk,2) = 0._wp 894 END DO 895 END DO 896 END IF 897 898 ! Save ssh at last level: 899 ptab(i1:i2,j1:j2,k2,2) = 0._wp 900 IF (.NOT.ln_linssh) THEN 901 ! This vertical sum below should be replaced by the sea-level at U-points (optimization): 902 DO jk=1,jpk 903 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) 904 END DO 905 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hu_0(i1:i2,j1:j2) 906 END IF 907 ENDIF 908 909 Kmm_a = item 821 910 ! 822 911 ELSE 823 912 zrhoy = Agrif_rhoy() 824 # if defined key_vertical 913 914 IF( l_vremap .OR. l_ini_child) THEN 825 915 ! VERTICAL REFINEMENT BEGIN 826 916 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 917 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 918 919 DO ji=i1,i2 920 DO jj=j1,j2 921 uu(ji,jj,:,Krhs_a) = 0._wp 922 N_in = mbku_parent(ji,jj) 923 zhtot = 0._wp 924 DO jk=1,N_in 925 IF (jk==N_in) THEN 926 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 927 ELSE 928 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 929 ENDIF 930 zhtot = zhtot + h_in(jk) 931 IF( h_in(jk) .GT. 0. ) THEN 932 tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk)) 933 ELSE 934 tabin(jk) = 0. 935 ENDIF 936 ENDDO 937 z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 938 DO jk=2,N_in 939 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 940 ENDDO 941 942 N_out = 0 943 DO jk=1,jpk 944 IF (umask(ji,jj,jk) == 0) EXIT 945 N_out = N_out + 1 946 h_out(N_out) = e3u(ji,jj,jk,Krhs_a) 947 ENDDO 948 949 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj) 950 DO jk=2,N_out 951 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 952 ENDDO 953 954 IF (N_in*N_out > 0) THEN 955 IF( l_ini_child ) THEN 956 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) 957 ELSE 958 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) 959 ENDIF 960 ENDIF 961 ENDDO 853 962 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 963 ELSE 964 DO jk = 1, jpkm1 965 DO jj=j1,j2 966 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) ) 967 END DO 968 END DO 969 ENDIF 863 970 864 971 ENDIF … … 878 985 REAL(wp) :: zrhox 879 986 ! 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 987 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in, z_in 988 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 989 INTEGER :: N_in, N_out, item 883 990 REAL(wp) :: h_diff, zhtot 884 991 !!--------------------------------------------- 885 992 ! 886 IF (before) THEN 993 IF (before) THEN 994 995 item = Kmm_a 996 IF( l_ini_child ) Kmm_a = Kbb_a 997 887 998 DO jk=k1,k2 888 999 DO jj=j1,j2 889 1000 DO ji=i1,i2 890 1001 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 1002 IF( l_vremap .OR. l_ini_child) THEN 1003 ! Interpolate thicknesses (masked for subsequent extrapolation) 1004 ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 1005 ENDIF 1006 END DO 1007 END DO 1008 END DO 1009 1010 IF( l_vremap .OR. l_ini_child) THEN 899 1011 ! Extrapolate thicknesses in partial bottom cells: 900 1012 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 901 IF (ln_zps) THEN 1013 IF (ln_zps) THEN 1014 DO jj=j1,j2 1015 DO ji=i1,i2 1016 jk = mbkv(ji,jj) 1017 ptab(ji,jj,jk,2) = 0._wp 1018 END DO 1019 END DO 1020 END IF 1021 ! Save ssh at last level: 1022 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1023 IF (.NOT.ln_linssh) THEN 1024 ! This vertical sum below should be replaced by the sea-level at V-points (optimization): 1025 DO jk=1,jpk 1026 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) 1027 END DO 1028 ptab(i1:i2,j1:j2,k2,2) = ptab(i1:i2,j1:j2,k2,2) - hv_0(i1:i2,j1:j2) 1029 END IF 1030 ENDIF 1031 item = Kmm_a 1032 1033 ELSE 1034 zrhox = Agrif_rhox() 1035 1036 IF( l_vremap .OR. l_ini_child ) THEN 1037 1038 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1039 902 1040 DO jj=j1,j2 903 1041 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) 1042 vv(ji,jj,:,Krhs_a) = 0._wp 1043 N_in = mbkv_parent(ji,jj) 1044 zhtot = 0._wp 1045 DO jk=1,N_in 1046 IF (jk==N_in) THEN 1047 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1048 ELSE 1049 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1050 ENDIF 1051 zhtot = zhtot + h_in(jk) 1052 IF( h_in(jk) .GT. 0. ) THEN 1053 tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk)) 1054 ELSE 1055 tabin(jk) = 0. 1056 ENDIF 1057 ENDDO 1058 1059 z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj) 1060 DO jk=2,N_in 1061 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 1062 ENDDO 1063 1064 N_out = 0 1065 DO jk=1,jpk 1066 IF (vmask(ji,jj,jk) == 0) EXIT 1067 N_out = N_out + 1 1068 h_out(N_out) = e3v(ji,jj,jk,Krhs_a) 1069 ENDDO 1070 1071 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj) 1072 DO jk=2,N_out 1073 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 1074 ENDDO 1075 1076 IF (N_in*N_out > 0) THEN 1077 IF( l_ini_child ) THEN 1078 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) 1079 ELSE 1080 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) 1081 ENDIF 935 1082 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 1083 END DO 1084 END DO 1085 ELSE 1086 DO jk = 1, jpkm1 1087 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) ) 1088 END DO 1089 ENDIF 956 1090 ENDIF 957 1091 ! … … 1163 1297 END SUBROUTINE interpe3t 1164 1298 1165 1166 1299 SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before ) 1167 1300 !!---------------------------------------------------------------------- … … 1185 1318 END DO 1186 1319 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 1320 END DO 1321 1322 IF( l_vremap ) THEN 1323 ! Interpolate thicknesses 1324 ! Warning: these are masked, hence extrapolated prior interpolation. 1325 DO jk=k1,k2 1326 DO jj=j1,j2 1327 DO ji=i1,i2 1328 ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 1329 END DO 1330 END DO 1331 END DO 1332 1333 ! Extrapolate thicknesses in partial bottom cells: 1334 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 1335 IF (ln_zps) THEN 1336 DO jj=j1,j2 1337 DO ji=i1,i2 1338 jk = mbkt(ji,jj) 1339 ptab(ji,jj,jk,2) = 0._wp 1340 END DO 1341 END DO 1342 END IF 1343 1344 ! Save ssh at last level: 1345 IF (.NOT.ln_linssh) THEN 1346 ptab(i1:i2,j1:j2,k2,2) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 1347 ELSE 1348 ptab(i1:i2,j1:j2,k2,2) = 0._wp 1349 END IF 1350 ENDIF 1351 1218 1352 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) 1353 1354 IF( l_vremap ) THEN 1355 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1356 avm_k(i1:i2,j1:j2,k1:k2) = 0._wp 1357 1358 DO jj = j1, j2 1359 DO ji =i1, i2 1360 N_in = mbkt_parent(ji,jj) 1361 IF ( tmask(ji,jj,1) == 0._wp) N_in = 0 1362 z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2) 1363 DO jk = N_in, 1, -1 ! Parent vertical grid 1364 z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2) 1365 tabin(jk) = ptab(ji,jj,jk,1) 1366 END DO 1367 N_out = mbkt(ji,jj) 1368 DO jk = 1, N_out ! Child vertical grid 1369 z_out(jk) = gdepw(ji,jj,jk,Kmm_a) 1370 ENDDO 1371 IF (N_in*N_out > 0) THEN 1372 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) 1373 ENDIF 1235 1374 ENDDO 1236 IF (N_in*N_out > 0) THEN1237 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 ENDIF1239 1375 ENDDO 1240 ENDDO 1241 #else 1242 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) 1243 #endif 1376 ELSE 1377 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1) 1378 ENDIF 1244 1379 ENDIF 1245 1380 ! 1246 1381 END SUBROUTINE interpavm 1247 1382 1248 # if defined key_vertical1249 1383 SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before ) 1250 1384 !!---------------------------------------------------------------------- … … 1282 1416 ! 1283 1417 END SUBROUTINE interpht0 1284 #endif 1285 1418 1419 SUBROUTINE agrif_initts(tabres,i1,i2,j1,j2,k1,k2,m1,m2,before) 1420 INTEGER :: i1, i2, j1, j2, k1, k2, m1, m2 1421 REAL(wp):: tabres(i1:i2,j1:j2,k1:k2,m1:m2) 1422 LOGICAL :: before 1423 1424 INTEGER :: jm 1425 1426 IF (before) THEN 1427 DO jm=1,jpts 1428 tabres(i1:i2,j1:j2,k1:k2,jm) = ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a) 1429 END DO 1430 ELSE 1431 DO jm=1,jpts 1432 ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a)=tabres(i1:i2,j1:j2,k1:k2,jm) 1433 END DO 1434 ENDIF 1435 END SUBROUTINE agrif_initts 1436 1437 SUBROUTINE agrif_initssh( ptab, i1, i2, j1, j2, before ) 1438 !!---------------------------------------------------------------------- 1439 !! *** ROUTINE interpsshn *** 1440 !!---------------------------------------------------------------------- 1441 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1442 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1443 LOGICAL , INTENT(in ) :: before 1444 ! 1445 !!---------------------------------------------------------------------- 1446 ! 1447 IF( before) THEN 1448 ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kbb_a) 1449 ELSE 1450 ssh(i1:i2,j1:j2,Kbb_a) = ptab(i1:i2,j1:j2)*tmask(i1:i2,j1:j2,1) 1451 ENDIF 1452 ! 1453 END SUBROUTINE agrif_initssh 1454 1286 1455 #else 1287 1456 !!---------------------------------------------------------------------- -
NEMO/trunk/src/NST/agrif_oce_sponge.F90
r12489 r13216 80 80 Agrif_SpecialValue=0. 81 81 Agrif_UseSpecialValue = ln_spc_dyn 82 use_sign_north = .TRUE. 83 sign_north = -1. 82 84 ! 83 85 tabspongedone_u = .FALSE. … … 90 92 ! 91 93 Agrif_UseSpecialValue = .FALSE. 94 use_sign_north = .FALSE. 92 95 #endif 93 96 ! … … 127 130 128 131 ! --- 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) 132 IF( lk_west) THEN 133 ztabramp(:,:) = 0._wp 134 ind1 = 1+nbghostcells 135 DO ji = mi0(ind1), mi1(ind1) 136 ztabramp(ji,:) = ssumask(ji,:) 137 END DO 138 ! 139 zmskwest(:) = 0._wp 140 zmskwest(1:jpj) = MAXVAL(ztabramp(:,:), dim=1) 141 ENDIF 137 142 138 143 ! --- 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) 144 IF( lk_east ) THEN 145 ztabramp(:,:) = 0._wp 146 ind1 = jpiglo - nbghostcells - 1 147 DO ji = mi0(ind1), mi1(ind1) 148 ztabramp(ji,:) = ssumask(ji,:) 149 END DO 150 ! 151 zmskeast(:) = 0._wp 152 zmskeast(1:jpj) = MAXVAL(ztabramp(:,:), dim=1) 153 ENDIF 147 154 148 155 ! --- 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) 156 IF( lk_south ) THEN 157 ztabramp(:,:) = 0._wp 158 ind1 = 1+nbghostcells 159 DO jj = mj0(ind1), mj1(ind1) 160 ztabramp(:,jj) = ssvmask(:,jj) 161 END DO 162 ! 163 zmsksouth(:) = 0._wp 164 zmsksouth(1:jpi) = MAXVAL(ztabramp(:,:), dim=2) 165 ENDIF 157 166 158 167 ! --- 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) 168 IF( lk_north) THEN 169 ztabramp(:,:) = 0._wp 170 ind1 = jpjglo - nbghostcells - 1 171 DO jj = mj0(ind1), mj1(ind1) 172 ztabramp(:,jj) = ssvmask(:,jj) 173 END DO 174 ! 175 zmsknorth(:) = 0._wp 176 zmsknorth(1:jpi) = MAXVAL(ztabramp(:,:), dim=2) 177 ENDIF 178 167 179 ! JC: SPONGE MASKING TO BE SORTED OUT: 168 180 zmskwest(:) = 1._wp … … 192 204 193 205 ! --- 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 206 IF(lk_west) THEN 207 ind1 = 1+nbghostcells 208 ind2 = 1+nbghostcells + ispongearea 209 DO ji = mi0(ind1), mi1(ind2) 210 DO jj = 1, jpj 211 ztabramp(ji,jj) = REAL( ind2 - mig(ji) ) * z1_ispongearea * zmskwest(jj) 212 END DO 213 END DO 214 215 ! ghost cells: 216 ind1 = 1 217 ind2 = nbghostcells + 1 218 DO ji = mi0(ind1), mi1(ind2) 219 DO jj = 1, jpj 220 ztabramp(ji,jj) = zmskwest(jj) 221 END DO 222 END DO 223 ENDIF 210 224 211 225 ! --- 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 226 IF(lk_east) THEN 227 ind1 = jpiglo - nbghostcells - ispongearea 228 ind2 = jpiglo - nbghostcells 229 DO ji = mi0(ind1), mi1(ind2) 230 231 DO jj = 1, jpj 232 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mig(ji) - ind1 ) * z1_ispongearea) * zmskeast(jj) 233 ENDDO 234 END DO 235 236 ! ghost cells: 237 ind1 = jpiglo - nbghostcells 238 ind2 = jpiglo 239 DO ji = mi0(ind1), mi1(ind2) 240 241 DO jj = 1, jpj 242 ztabramp(ji,jj) = zmskeast(jj) 243 ENDDO 244 END DO 245 ENDIF 228 246 229 247 ! --- 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 248 IF( lk_south ) THEN 249 ind1 = 1+nbghostcells 250 ind2 = 1+nbghostcells + jspongearea 251 DO jj = mj0(ind1), mj1(ind2) 252 DO ji = 1, jpi 253 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( ind2 - mjg(jj) ) * z1_jspongearea) * zmsksouth(ji) 254 END DO 255 END DO 256 257 ! ghost cells: 258 ind1 = 1 259 ind2 = nbghostcells + 1 260 DO jj = mj0(ind1), mj1(ind2) 261 DO ji = 1, jpi 262 ztabramp(ji,jj) = zmsksouth(ji) 263 END DO 264 END DO 265 ENDIF 246 266 247 267 ! --- 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 268 IF( lk_north ) THEN 269 ind1 = jpjglo - nbghostcells - jspongearea 270 ind2 = jpjglo - nbghostcells 271 DO jj = mj0(ind1), mj1(ind2) 272 DO ji = 1, jpi 273 ztabramp(ji,jj) = MAX( ztabramp(ji,jj), REAL( mjg(jj) - ind1 ) * z1_jspongearea) * zmsknorth(ji) 274 END DO 275 END DO 276 277 ! ghost cells: 278 ind1 = jpjglo - nbghostcells 279 ind2 = jpjglo 280 DO jj = mj0(ind1), mj1(ind2) 281 DO ji = 1, jpi 282 ztabramp(ji,jj) = zmsknorth(ji) 283 END DO 284 END DO 285 ENDIF 286 265 287 ENDIF 266 288 … … 334 356 INTEGER :: ji, jj, jk, jn ! dummy loop indices 335 357 INTEGER :: iku, ikv 336 REAL(wp) :: ztsa, zabe1, zabe2, zbtr, zhtot , ztrelax358 REAL(wp) :: ztsa, zabe1, zabe2, zbtr, zhtot 337 359 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk) :: ztu, ztv 338 360 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tsbdiff … … 438 460 ENDDO 439 461 440 !* set relaxation time scale441 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 ENDIF444 445 462 DO jn = 1, jpts 446 463 DO jk = 1, jpkm1 … … 448 465 DO jj = j1,j2 449 466 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)467 zabe1 = rn_sponge_tra * r1_Dt * fspu(ji,jj) * umask(ji,jj,jk) * e1e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) 451 468 ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 452 469 END DO … … 455 472 DO ji = i1,i2 456 473 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)474 zabe2 = rn_sponge_tra * r1_Dt * fspv(ji,jj) * vmask(ji,jj,jk) * e1e2v(ji,jj) * e3v(ji,jj,jk,Kmm_a) 458 475 ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 459 476 END DO … … 480 497 ! horizontal diffusive trends 481 498 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)499 & - rn_trelax_tra * r1_Dt * fspt(ji,jj) * tsbdiff(ji,jj,jk,jn) 483 500 ! add it to the general tracer trends 484 501 ts(ji,jj,jk,jn,Krhs_a) = ts(ji,jj,jk,jn,Krhs_a) + ztsa … … 507 524 508 525 ! sponge parameters 509 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot , ztrelax526 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot 510 527 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ubdiff 511 528 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff … … 595 612 ubdiff(i1:i2,j1:j2,:) = (uu(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) 596 613 #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 614 ! 602 615 DO jk = 1, jpkm1 ! Horizontal slab … … 608 621 DO jj = j1,j2 609 622 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)623 zbtr = rn_sponge_dyn * r1_Dt * fspt(ji,jj) / e3t(ji,jj,jk,Kbb_a) 611 624 hdivdiff(ji,jj,jk) = ( e2u(ji ,jj)*e3u(ji ,jj,jk,Kbb_a) * ubdiff(ji ,jj,jk) & 612 625 & -e2u(ji-1,jj)*e3u(ji-1,jj,jk,Kbb_a) * ubdiff(ji-1,jj,jk) ) * zbtr … … 616 629 DO jj = j1,j2-1 617 630 DO ji = i1,i2 ! vector opt. 618 zbtr = r 1_e1e2f(ji,jj) * e3f(ji,jj,jk) * rn_sponge_dyn * fspf(ji,jj)631 zbtr = rn_sponge_dyn * r1_Dt * fspf(ji,jj) * e3f(ji,jj,jk) 619 632 rotdiff(ji,jj,jk) = ( -e1u(ji,jj+1) * ubdiff(ji,jj+1,jk) & 620 633 & +e1u(ji,jj ) * ubdiff(ji,jj ,jk) ) * fmask(ji,jj,jk) * zbtr … … 633 646 zua = - ( ze2u - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) ) & 634 647 & + ( hdivdiff(ji+1,jj,jk) - ze1v ) * r1_e1u(ji,jj) & 635 & - ztrelax* fspu(ji,jj) * ubdiff(ji,jj,jk)648 & - rn_trelax_dyn * r1_Dt * fspu(ji,jj) * ubdiff(ji,jj,jk) 636 649 637 650 ! add it to the general momentum trends … … 646 659 647 660 jmax = j2-1 661 ! IF (lk_north) jmax = MIN(jmax,nlcj-nbghostcells-2) ! North 648 662 IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-nbghostcells-2) ! North 649 663 … … 684 698 ! 685 699 INTEGER :: ji, jj, jk, imax 686 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot , ztrelax700 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, zhtot 687 701 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: vbdiff 688 702 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff … … 771 785 vbdiff(i1:i2,j1:j2,:) = (vv(i1:i2,j1:j2,:,Kbb_a) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) 772 786 # 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 787 ! 778 788 DO jk = 1, jpkm1 ! Horizontal slab … … 784 794 DO jj = j1+1,j2 785 795 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)796 zbtr = rn_sponge_dyn * r1_Dt * fspt(ji,jj) / e3t(ji,jj,jk,Kbb_a) 787 797 hdivdiff(ji,jj,jk) = ( e1v(ji,jj ) * e3v(ji,jj ,jk,Kbb_a) * vbdiff(ji,jj ,jk) & 788 798 & -e1v(ji,jj-1) * e3v(ji,jj-1,jk,Kbb_a) * vbdiff(ji,jj-1,jk) ) * zbtr … … 791 801 DO jj = j1,j2 792 802 DO ji = i1,i2-1 ! vector opt. 793 zbtr = r 1_e1e2f(ji,jj) * e3f(ji,jj,jk) * rn_sponge_dyn * fspf(ji,jj)803 zbtr = rn_sponge_dyn * r1_Dt * fspf(ji,jj) * e3f(ji,jj,jk) 794 804 rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) & 795 805 & -e2v(ji ,jj) * vbdiff(ji ,jj,jk) ) * fmask(ji,jj,jk) * zbtr … … 802 812 803 813 imax = i2 - 1 814 ! IF(lk_east) imax = MIN(imax,nlci-nbghostcells-2) ! East 804 815 IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-nbghostcells-2) ! East 805 816 … … 808 819 IF( .NOT. tabspongedone_u(ji,jj) ) THEN 809 820 DO jk = 1, jpkm1 810 uu(ji,jj,jk,Krhs_a) = uu(ji,jj,jk,Krhs_a) 821 uu(ji,jj,jk,Krhs_a) = uu(ji,jj,jk,Krhs_a) & 811 822 & - ( rotdiff (ji ,jj,jk) - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * e3u(ji,jj,jk,Kmm_a) ) & 812 823 & + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj ,jk)) * r1_e1u(ji,jj) … … 822 833 IF( .NOT. tabspongedone_v(ji,jj) ) THEN 823 834 DO jk = 1, jpkm1 824 vv(ji,jj,jk,Krhs_a) = vv(ji,jj,jk,Krhs_a) 835 vv(ji,jj,jk,Krhs_a) = vv(ji,jj,jk,Krhs_a) & 825 836 & + ( 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)837 & + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji ,jj,jk) ) * r1_e2v(ji,jj) & 838 & - rn_trelax_dyn * r1_Dt * fspv(ji,jj) * vbdiff(ji,jj,jk) 828 839 END DO 829 840 ENDIF -
NEMO/trunk/src/NST/agrif_oce_update.F90
r12489 r13216 26 26 USE domvvl ! Need interpolation routines 27 27 USE vremap ! Vertical remapping 28 USE lbclnk 28 29 29 30 IMPLICIT NONE … … 85 86 Agrif_UseSpecialValueInUpdate = .FALSE. 86 87 Agrif_SpecialValueFineGrid = 0. 88 89 use_sign_north = .TRUE. 90 sign_north = -1. 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 … … 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. 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/trunk/src/NST/agrif_top_interp.F90
r12377 r13216 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/trunk/src/NST/agrif_user.F90
r12489 r13216 28 28 ! 29 29 ! !* Agrif initialization 30 CALL agrif_nemo_init31 CALL Agrif_InitValues_cont_dom32 30 CALL Agrif_InitValues_cont 33 31 # if defined key_top … … 40 38 END SUBROUTINE Agrif_initvalues 41 39 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 40 SUBROUTINE agrif_istate( Kbb, Kmm, Kaa ) 41 42 USE domvvl 43 USE domain 44 USE par_oce 45 USE agrif_oce 46 USE agrif_oce_interp 47 USE oce 48 USE lib_mpp 49 USe lbclnk 50 51 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 52 INTEGER :: jn 53 54 IF(lwp) WRITE(numout,*) ' ' 55 IF(lwp) WRITE(numout,*) 'AGRIF: interp child initial state from parent' 56 IF(lwp) WRITE(numout,*) ' ' 57 58 l_ini_child = .TRUE. 59 Agrif_SpecialValue = 0._wp 60 Agrif_UseSpecialValue = .TRUE. 61 uu(:,:,:,:) = 0. ; vv(:,:,:,:) = 0. ; ts(:,:,:,:,:) = 0. 62 63 Krhs_a = Kbb ; Kmm_a = Kbb 64 65 ! Brutal fix to pas 1x1 refinment. 66 ! IF(Agrif_Irhox() == 1) THEN 67 ! CALL Agrif_Init_Variable(tsini_id, procname=agrif_initts) 68 ! ELSE 69 CALL Agrif_Init_Variable(tsini_id, procname=interptsn) 70 71 ! ENDIF 72 ! just for VORTEX because Parent velocities can actually be exactly zero 73 ! Agrif_UseSpecialValue = .FALSE. 74 Agrif_UseSpecialValue = ln_spc_dyn 75 use_sign_north = .TRUE. 76 sign_north = -1. 77 CALL Agrif_Init_Variable(uini_id , procname=interpun ) 78 CALL Agrif_Init_Variable(vini_id , procname=interpvn ) 79 use_sign_north = .FALSE. 80 81 Agrif_UseSpecialValue = .FALSE. ! 82 l_ini_child = .FALSE. 83 84 Krhs_a = Kaa ; Kmm_a = Kmm 85 86 DO jn = 1, jpts 87 ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb)*tmask(:,:,:) 88 END DO 89 uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:) 90 vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:) 91 92 93 CALL lbc_lnk_multi( 'agrif_istate', uu(:,:,:,Kbb), 'U', -1. , vv(:,:,:,Kbb), 'V', -1. ) 94 CALL lbc_lnk( 'agrif_istate', ts(:,:,:,:,Kbb), 'T', 1. ) 95 96 END SUBROUTINE agrif_istate 97 98 SUBROUTINE agrif_declare_var_ini 99 !!---------------------------------------------------------------------- 100 !! *** ROUTINE agrif_declare_var *** 101 !!---------------------------------------------------------------------- 102 USE agrif_util 103 USE agrif_oce 104 USE par_oce 105 USE zdf_oce 106 USE oce 107 USE dom_oce 56 108 ! 57 109 IMPLICIT NONE 58 110 ! 59 111 INTEGER :: ind1, ind2, ind3 60 !!---------------------------------------------------------------------- 112 External :: nemo_mapping 113 !!---------------------------------------------------------------------- 114 115 ! In case of East-West periodicity, prevent AGRIF interpolation at east and west boundaries 116 ! The procnames will not be called at these boundaries 117 IF (jperio == 1) THEN 118 CALL Agrif_Set_NearCommonBorderX(.TRUE.) 119 CALL Agrif_Set_DistantCommonBorderX(.TRUE.) 120 ENDIF 121 122 IF ( .NOT. lk_south ) THEN 123 CALL Agrif_Set_NearCommonBorderY(.TRUE.) 124 ENDIF 61 125 62 126 ! 1. Declaration of the type of variable which have to be interpolated 63 127 !--------------------------------------------------------------------- 64 128 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 129 ind2 = 2 + nbghostcells_x 130 ind3 = 2 + nbghostcells_y_s 131 132 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 133 CALL agrif_declare_variable((/2,2/) ,(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),mbkt_id) 134 CALL agrif_declare_variable((/2,2/) ,(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ht0_id) 135 136 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 137 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 138 139 140 ! Initial or restart velues 141 142 CALL agrif_declare_variable((/2,2,0,0/),(/ind2 ,ind3 ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsini_id) 143 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3 ,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/) ,uini_id ) 144 CALL agrif_declare_variable((/2,1,0,0/),(/ind2 ,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/) ,vini_id ) 145 CALL agrif_declare_variable((/2,2/) ,(/ind2,ind3/) ,(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshini_id) 146 ! 147 70 148 ! 2. Type of interpolation 71 149 !------------------------- 150 CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 151 152 CALL Agrif_Set_bcinterp(mbkt_id,interp=AGRIF_constant) 153 CALL Agrif_Set_interp (mbkt_id,interp=AGRIF_constant) 154 CALL Agrif_Set_bcinterp(ht0_id ,interp=AGRIF_constant) 155 CALL Agrif_Set_interp (ht0_id ,interp=AGRIF_constant) 156 72 157 CALL Agrif_Set_bcinterp( e1u_id, interp1=Agrif_linear, interp2=AGRIF_ppm ) 73 158 CALL Agrif_Set_bcinterp( e2v_id, interp1=AGRIF_ppm , interp2=Agrif_linear ) 74 159 75 ! 3. Location of interpolation 160 ! Initial fields 161 CALL Agrif_Set_bcinterp(tsini_id ,interp=AGRIF_linear) 162 CALL Agrif_Set_interp (tsini_id ,interp=AGRIF_linear) 163 CALL Agrif_Set_bcinterp(uini_id ,interp=AGRIF_linear) 164 CALL Agrif_Set_interp (uini_id ,interp=AGRIF_linear) 165 CALL Agrif_Set_bcinterp(vini_id ,interp=AGRIF_linear) 166 CALL Agrif_Set_interp (vini_id ,interp=AGRIF_linear) 167 CALL Agrif_Set_bcinterp(sshini_id,interp=AGRIF_linear) 168 CALL Agrif_Set_interp (sshini_id,interp=AGRIF_linear) 169 170 ! 3. Location of interpolation 76 171 !----------------------------- 172 ! CALL Agrif_Set_bc( e3t_id, (/-nn_sponge_len*Agrif_irhox(),ind1-1/) ) 173 ! JC: check near the boundary only until matching in sponge has been sorted out: 174 CALL Agrif_Set_bc( e3t_id, (/0,ind1-1/) ) 175 176 ! extend the interpolation zone by 1 more point than necessary: 177 ! RB check here 178 CALL Agrif_Set_bc( mbkt_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) ) 179 CALL Agrif_Set_bc( ht0_id, (/-nn_sponge_len*Agrif_irhox()-2,ind1/) ) 180 77 181 CALL Agrif_Set_bc(e1u_id,(/0,ind1-1/)) 78 CALL Agrif_Set_bc(e2v_id,(/0,ind1-1/)) 182 CALL Agrif_Set_bc(e2v_id,(/0,ind1-1/)) 183 184 CALL Agrif_Set_bc( tsini_id , (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4 185 CALL Agrif_Set_bc( uini_id , (/0,ind1-1/) ) 186 CALL Agrif_Set_bc( vini_id , (/0,ind1-1/) ) 187 CALL Agrif_Set_bc( sshini_id, (/0,ind1-1/) ) 79 188 80 189 ! 4. Update type … … 87 196 CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 88 197 #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 198 199 ! CALL Agrif_Set_ExternalMapping(nemo_mapping) 200 ! 201 END SUBROUTINE agrif_declare_var_ini 202 203 204 SUBROUTINE Agrif_Init_Domain( Kbb, Kmm, Kaa ) 205 !!---------------------------------------------------------------------- 206 !! *** ROUTINE Agrif_InitValues_cont_dom *** 207 !!---------------------------------------------------------------------- 208 209 !!---------------------------------------------------------------------- 210 !! *** ROUTINE Agrif_InitValues_cont *** 211 !! 212 !! ** Purpose :: Declaration of variables to be interpolated 213 !!---------------------------------------------------------------------- 214 USE agrif_oce_update 97 215 USE agrif_oce_interp 98 216 USE agrif_oce_sponge 217 USE Agrif_Util 218 USE oce 99 219 USE dom_oce 100 USE oce 220 USE zdf_oce 221 USE nemogcm 222 USE agrif_oce 223 ! 224 USE lbclnk 101 225 USE lib_mpp 102 USE lbclnk226 USE in_out_manager 103 227 ! 104 228 IMPLICIT NONE 105 229 ! 106 INTEGER :: ji, jj 230 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 231 ! 107 232 LOGICAL :: check_namelist 108 233 CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4 109 #if defined key_vertical110 234 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 235 INTEGER :: ji, jj, jk 236 !!---------------------------------------------------------------------- 237 238 ! CALL Agrif_Declare_Var_ini 239 240 IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 241 122 242 ! Build consistent parent bathymetry and number of levels 123 243 ! on the child grid … … 126 246 mbkt_parent(:,:) = 0 127 247 ! 128 CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 ) 129 CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt) 248 ! CALL Agrif_Bc_variable(ht0_id ,calledweight=1.,procname=interpht0 ) 249 ! CALL Agrif_Bc_variable(mbkt_id,calledweight=1.,procname=interpmbkt) 250 CALL Agrif_Init_Variable(ht0_id , procname=interpht0 ) 251 CALL Agrif_Init_Variable(mbkt_id, procname=interpmbkt) 130 252 ! 131 253 ! Assume step wise change of bathymetry near interface … … 149 271 ENDIF 150 272 ! 151 CALL lbc_lnk( 'Agrif_Init Values_cont', hu0_parent, 'U', 1. )152 CALL lbc_lnk( 'Agrif_Init Values_cont', hv0_parent, 'V', 1. )273 CALL lbc_lnk( 'Agrif_Init_Domain', hu0_parent, 'U', 1. ) 274 CALL lbc_lnk( 'Agrif_Init_Domain', hv0_parent, 'V', 1. ) 153 275 zk(:,:) = REAL( mbku_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'U', 1. ) 154 mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 276 mbku_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) ; 155 277 zk(:,:) = REAL( mbkv_parent(:,:), wp ) ; CALL lbc_lnk( 'Agrif_InitValues_cont', zk, 'V', 1. ) 156 278 mbkv_parent(:,:) = MAX( NINT( zk(:,:) ), 1 ) 157 #endif 158 279 280 IF ( ln_init_chfrpar ) THEN 281 CALL Agrif_Init_Variable(sshini_id, procname=agrif_initssh) 282 CALL lbc_lnk( 'Agrif_Init_Domain', ssh(:,:,Kbb), 'T', 1. ) 283 DO jk = 1, jpk 284 e3t(:,:,jk,Kbb) = e3t_0(:,:,jk) * ( ht_0(:,:) + ssh(:,:,Kbb) ) & 285 & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & 286 & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) 287 END DO 288 ENDIF 289 290 ! check if masks and bathymetries match 291 IF(ln_chk_bathy) THEN 292 Agrif_UseSpecialValue = .FALSE. 293 ! 294 IF(lwp) WRITE(numout,*) ' ' 295 IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() 296 ! 297 kindic_agr = 0 298 IF( .NOT. l_vremap ) THEN 299 ! 300 ! check if tmask and vertical scale factors agree with parent in sponge area: 301 CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 302 ! 303 ELSE 304 ! 305 ! In case of vertical interpolation, check only that total depths agree between child and parent: 306 DO ji = 1, jpi 307 DO jj = 1, jpj 308 IF ((mbkt_parent(ji,jj)/=0).AND.(ABS(ht0_parent(ji,jj)-ht_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 309 IF ((mbku_parent(ji,jj)/=0).AND.(ABS(hu0_parent(ji,jj)-hu_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 310 IF ((mbkv_parent(ji,jj)/=0).AND.(ABS(hv0_parent(ji,jj)-hv_0(ji,jj))>1.e-3)) kindic_agr = kindic_agr + 1 311 END DO 312 END DO 313 314 CALL mpp_sum( 'agrif_user', kindic_agr ) 315 IF( kindic_agr /= 0 ) THEN 316 CALL ctl_stop('==> Child Bathymetry is NOT correct near boundaries.') 317 ELSE 318 IF(lwp) WRITE(numout,*) '==> Child Bathymetry is ok near boundaries.' 319 IF(lwp) WRITE(numout,*) ' ' 320 ENDIF 321 ENDIF 322 ENDIF 323 324 IF( l_vremap ) THEN 325 ! Additional constrain that should be removed someday: 326 IF ( Agrif_Parent(jpk).GT.jpk ) THEN 327 CALL ctl_stop( ' With l_vremap, child grids must have jpk greater or equal to the parent value' ) 328 ENDIF 329 ENDIF 330 ! 331 END SUBROUTINE Agrif_Init_Domain 332 333 334 SUBROUTINE Agrif_InitValues_cont 335 !!---------------------------------------------------------------------- 336 !! *** ROUTINE Agrif_InitValues_cont *** 337 !! 338 !! ** Purpose :: Declaration of variables to be interpolated 339 !!---------------------------------------------------------------------- 340 USE agrif_oce_update 341 USE agrif_oce_interp 342 USE agrif_oce_sponge 343 USE Agrif_Util 344 USE oce 345 USE dom_oce 346 USE zdf_oce 347 USE nemogcm 348 USE agrif_oce 349 ! 350 USE lbclnk 351 USE lib_mpp 352 USE in_out_manager 353 ! 354 IMPLICIT NONE 355 ! 356 LOGICAL :: check_namelist 357 CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3, cl_check4 358 REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace 359 INTEGER :: ji, jj 360 361 ! 1. Declaration of the type of variable which have to be interpolated 362 !--------------------------------------------------------------------- 363 CALL agrif_declare_var 364 365 ! 2. First interpolations of potentially non zero fields 366 !------------------------------------------------------- 159 367 Agrif_SpecialValue = 0._wp 160 368 Agrif_UseSpecialValue = .TRUE. … … 163 371 tabspongedone_tsn = .FALSE. 164 372 CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 165 ! reset ts (:,:,:,:,Krhs_a)to zero373 ! reset tsa to zero 166 374 ts(:,:,:,:,Krhs_a) = 0._wp 167 375 168 376 Agrif_UseSpecialValue = ln_spc_dyn 377 use_sign_north = .TRUE. 378 sign_north = -1. 169 379 CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 170 380 CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) … … 175 385 tabspongedone_v = .FALSE. 176 386 CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 387 use_sign_north = .FALSE. 177 388 uu(:,:,:,Krhs_a) = 0._wp 178 389 vv(:,:,:,Krhs_a) = 0._wp … … 185 396 IF ( ln_dynspg_ts ) THEN 186 397 Agrif_UseSpecialValue = ln_spc_dyn 398 use_sign_north = .TRUE. 399 sign_north = -1. 187 400 CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 188 401 CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 189 402 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 190 403 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 404 use_sign_north = .FALSE. 191 405 ubdy(:,:) = 0._wp 192 406 vbdy(:,:) = 0._wp 193 407 ENDIF 194 195 Agrif_UseSpecialValue = .FALSE. 196 197 ! 3. Some controls 408 Agrif_UseSpecialValue = .FALSE. 409 198 410 !----------------- 199 411 check_namelist = .TRUE. 200 412 201 413 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 414 ! Check free surface scheme 227 415 IF ( ( Agrif_Parent(ln_dynspg_ts ).AND.ln_dynspg_exp ).OR.& … … 251 439 STOP 252 440 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 ! 441 ENDIF 442 297 443 END SUBROUTINE Agrif_InitValues_cont 298 444 … … 314 460 ! 1. Declaration of the type of variable which have to be interpolated 315 461 !--------------------------------------------------------------------- 462 316 463 ind1 = nbghostcells 317 ind2 = 1 + nbghostcells 318 ind3 = 2 + nbghostcells 464 ind2 = 2 + nbghostcells_x 465 ind3 = 2 + nbghostcells_y_s 466 319 467 # 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) 468 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_id) 469 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_sponge_id) 470 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_interp_id) 471 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_interp_id) 472 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_update_id) 473 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_update_id) 474 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_sponge_id) 475 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_sponge_id) 329 476 # 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) 477 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 478 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 479 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_interp_id) 480 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_interp_id) 481 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_update_id) 482 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_update_id) 483 CALL agrif_declare_variable((/1,2,0,0/),(/ind2-1,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_sponge_id) 484 CALL agrif_declare_variable((/2,1,0,0/),(/ind2,ind3-1,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_sponge_id) 339 485 # 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 343 # 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) 346 # 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 486 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 487 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 488 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 489 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 490 CALL agrif_declare_variable((/1,2/),(/ind2-1,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 491 CALL agrif_declare_variable((/2,1/),(/ind2,ind3-1/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 492 493 CALL agrif_declare_variable((/2,2/),(/ind2,ind3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 494 495 496 IF( ln_zdftke.OR.ln_zdfgls ) THEN ! logical not known at this point 360 497 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/), en_id) 361 498 ! CALL agrif_declare_variable((/2,2,0/),(/ind3,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),avt_id) 362 499 # if defined key_vertical 363 CALL agrif_declare_variable((/2,2,0,0/),(/ind 3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),avm_id)500 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),avm_id) 364 501 # else 365 CALL agrif_declare_variable((/2,2,0,0/),(/ind 3,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),avm_id)502 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),avm_id) 366 503 # endif 367 504 ENDIF 368 505 369 506 ! 2. Type of interpolation 370 507 !------------------------- 371 508 CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 372 373 509 CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 374 510 CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 375 511 376 512 CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 513 CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 514 CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 377 515 378 516 CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) … … 390 528 !< 391 529 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 ) 403 404 ! 3. Location of interpolation 530 IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bcinterp( avm_id, interp=AGRIF_linear ) 531 532 533 ! 3. Location of interpolation 405 534 !----------------------------- 406 535 CALL Agrif_Set_bc( tsn_id, (/0,ind1-1/) ) ! if west, rhox=3 and nbghost=3: columns 2 to 4 … … 418 547 CALL Agrif_Set_bc( vb2b_interp_id, (/0,ind1-1/) ) 419 548 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/) ) 549 IF( ln_zdftke.OR.ln_zdfgls ) CALL Agrif_Set_bc( avm_id, (/0,ind1/) ) 431 550 432 551 ! 4. Update type 433 552 !--------------- 434 CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average)435 553 436 554 # if defined UPD_HIGH … … 444 562 CALL Agrif_Set_Updatetype(e3t_id, update = Agrif_Update_Full_Weighting) 445 563 446 IF( ln_zdftke.OR.ln_zdfgls ) THEN564 ! IF( ln_zdftke.OR.ln_zdfgls ) THEN 447 565 ! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Full_Weighting) 448 566 ! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Full_Weighting) 449 567 ! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Full_Weighting) 450 ENDIF568 ! ENDIF 451 569 452 570 #else … … 460 578 CALL Agrif_Set_Updatetype(e3t_id, update = AGRIF_Update_Average) 461 579 462 IF( ln_zdftke.OR.ln_zdfgls ) THEN580 ! IF( ln_zdftke.OR.ln_zdfgls ) THEN 463 581 ! CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 464 582 ! CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 465 583 ! CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 466 ENDIF584 ! ENDIF 467 585 468 586 #endif … … 472 590 #if defined key_si3 473 591 SUBROUTINE Agrif_InitValues_cont_ice 474 !!----------------------------------------------------------------------475 !! *** ROUTINE Agrif_InitValues_cont_ice ***476 !!----------------------------------------------------------------------477 592 USE Agrif_Util 478 593 USE sbc_oce, ONLY : nn_fsbc ! clem: necessary otherwise Agrif_Parent(nn_fsbc) = nn_fsbc … … 482 597 USE agrif_ice_interp 483 598 USE lib_mpp 484 ! 485 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 599 !!---------------------------------------------------------------------- 600 !! *** ROUTINE Agrif_InitValues_cont_ice *** 601 !!---------------------------------------------------------------------- 491 602 492 603 ! Controls … … 495 606 ! the run must satisfy CFL=Uice/(dx/dt) < 0.6/nn_fsbc(child) 496 607 ! 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 608 ! If a solution is found, the following stop could be removed because the rest of the code take nn_fsbc(child) into account 498 609 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 610 … … 516 627 !! *** ROUTINE agrif_declare_var_ice *** 517 628 !!---------------------------------------------------------------------- 629 518 630 USE Agrif_Util 519 631 USE ice 520 USE par_oce, ONLY : nbghostcells 632 USE par_oce, ONLY : nbghostcells, nbghostcells_x, nbghostcells_y_s 521 633 ! 522 634 IMPLICIT NONE 523 635 ! 524 636 INTEGER :: ind1, ind2, ind3 525 !!----------------------------------------------------------------------637 !!---------------------------------------------------------------------- 526 638 ! 527 639 ! 1. Declaration of the type of variable which have to be interpolated (parent=>child) … … 532 644 ! 2,2 = two ghost lines 533 645 !------------------------------------------------------------------------------------- 646 534 647 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 ) 648 ind2 = 2 + nbghostcells_x 649 ind3 = 2 + nbghostcells_y_s 650 CALL agrif_declare_variable((/2,2,0/),(/ind2,ind3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpl*(8+nlay_s+nlay_i)/),tra_ice_id) 651 CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_ice_id ) 652 CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_ice_id ) 653 654 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_iceini_id) 655 CALL agrif_declare_variable((/1,2/) ,(/ind2-1,ind3/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,u_iceini_id ) 656 CALL agrif_declare_variable((/2,1/) ,(/ind2,ind3-1/) ,(/'x','y'/) ,(/1,1/) ,(/nlci,nlcj/) ,v_iceini_id ) 540 657 541 658 ! 2. Set interpolations (normal & tangent to the grid cell for velocities) … … 545 662 CALL Agrif_Set_bcinterp(v_ice_id , interp1 = AGRIF_ppm ,interp2 = Agrif_linear) 546 663 664 CALL Agrif_Set_bcinterp(tra_iceini_id, interp = AGRIF_linear) 665 CALL Agrif_Set_interp (tra_iceini_id, interp = AGRIF_linear) 666 CALL Agrif_Set_bcinterp(u_iceini_id , interp = AGRIF_linear ) 667 CALL Agrif_Set_interp (u_iceini_id , interp = AGRIF_linear ) 668 CALL Agrif_Set_bcinterp(v_iceini_id , interp = AGRIF_linear) 669 CALL Agrif_Set_interp (v_iceini_id , interp = AGRIF_linear) 670 547 671 ! 3. Set location of interpolations 548 672 !---------------------------------- … … 550 674 CALL Agrif_Set_bc(u_ice_id ,(/0,ind1/)) 551 675 CALL Agrif_Set_bc(v_ice_id ,(/0,ind1/)) 676 677 CALL Agrif_Set_bc(tra_iceini_id,(/0,ind1/)) 678 CALL Agrif_Set_bc(u_iceini_id ,(/0,ind1/)) 679 CALL Agrif_Set_bc(v_iceini_id ,(/0,ind1/)) 552 680 553 681 ! 4. Set update type in case 2 ways (child=>parent) (normal & tangent to the grid cell for velocities) … … 557 685 CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Average , update2 = Agrif_Update_Full_Weighting) 558 686 CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average ) 559 # else687 # else 560 688 CALL Agrif_Set_Updatetype(tra_ice_id, update = AGRIF_Update_Average) 561 689 CALL Agrif_Set_Updatetype(u_ice_id , update1 = Agrif_Update_Copy , update2 = Agrif_Update_Average) 562 690 CALL Agrif_Set_Updatetype(v_ice_id , update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy ) 563 # endif691 # endif 564 692 565 693 END SUBROUTINE agrif_declare_var_ice … … 585 713 USE agrif_top_sponge 586 714 !! 587 IMPLICIT NONE 588 ! 589 CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 590 LOGICAL :: check_namelist 591 !!---------------------------------------------------------------------- 592 593 ! 1. Declaration of the type of variable which have to be interpolated 594 !--------------------------------------------------------------------- 595 CALL agrif_declare_var_top 596 597 ! 2. First interpolations of potentially non zero fields 598 !------------------------------------------------------- 599 Agrif_SpecialValue=0._wp 600 Agrif_UseSpecialValue = .TRUE. 601 CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 602 Agrif_UseSpecialValue = .FALSE. 603 CALL Agrif_Sponge 604 tabspongedone_trn = .FALSE. 605 CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 606 ! reset ts(:,:,:,:,Krhs_a) to zero 607 tr(:,:,:,:,Krhs_a) = 0._wp 608 609 ! 3. Some controls 610 !----------------- 611 check_namelist = .TRUE. 612 613 IF( check_namelist ) THEN 614 ! Check time steps 615 IF( NINT(Agrif_Rhot()) * NINT(rn_Dt) .NE. Agrif_Parent(rn_Dt) ) THEN 616 WRITE(cl_check1,*) Agrif_Parent(rn_Dt) 617 WRITE(cl_check2,*) rn_Dt 618 WRITE(cl_check3,*) rn_Dt*Agrif_Rhot() 715 716 !! 717 IMPLICIT NONE 718 ! 719 CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 720 LOGICAL :: check_namelist 721 !!---------------------------------------------------------------------- 722 723 724 ! 1. Declaration of the type of variable which have to be interpolated 725 !--------------------------------------------------------------------- 726 CALL agrif_declare_var_top 727 728 ! 2. First interpolations of potentially non zero fields 729 !------------------------------------------------------- 730 Agrif_SpecialValue=0. 731 Agrif_UseSpecialValue = .TRUE. 732 CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 733 Agrif_UseSpecialValue = .FALSE. 734 CALL Agrif_Sponge 735 tabspongedone_trn = .FALSE. 736 CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 737 ! reset tsa to zero 738 tra(:,:,:,:) = 0. 739 740 ! 3. Some controls 741 !----------------- 742 check_namelist = .TRUE. 743 744 IF( check_namelist ) THEN 745 ! Check time steps 746 IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 747 WRITE(cl_check1,*) Agrif_Parent(rdt) 748 WRITE(cl_check2,*) rdt 749 WRITE(cl_check3,*) rdt*Agrif_Rhot() 619 750 CALL ctl_stop( 'incompatible time step between grids', & 620 751 & 'parent grid value : '//cl_check1 , & … … 635 766 nitend = Agrif_Parent(nitend) *Agrif_IRhot() 636 767 ENDIF 637 638 768 ENDIF 639 769 ! … … 655 785 !!---------------------------------------------------------------------- 656 786 787 788 789 !RB_CMEMS : declare here init for top 657 790 ! 1. Declaration of the type of variable which have to be interpolated 658 791 !--------------------------------------------------------------------- 659 792 ind1 = nbghostcells 660 ind2 = 1 + nbghostcells661 ind3 = 2 + nbghostcells 793 ind2 = 2 + nbghostcells_x 794 ind3 = 2 + nbghostcells_y_s 662 795 # 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)796 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_id) 797 CALL agrif_declare_variable((/2,2,0,0/),(/ind2,ind3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_sponge_id) 665 798 # 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) 799 ! LAURENT: STRANGE why (3,3) here ? 800 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 801 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 668 802 # endif 669 803 … … 705 839 !! *** ROUTINE agrif_init *** 706 840 !!---------------------------------------------------------------------- 707 USE agrif_oce 708 USE agrif_ice 709 USE in_out_manager 710 USE lib_mpp 841 USE agrif_oce 842 USE agrif_ice 843 USE dom_oce 844 USE in_out_manager 845 USE lib_mpp 711 846 !! 712 847 IMPLICIT NONE 713 848 ! 714 849 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, &850 NAMELIST/namagrif/ ln_agrif_2way, ln_init_chfrpar, rn_sponge_tra, rn_sponge_dyn, rn_trelax_tra, rn_trelax_dyn, & 716 851 & ln_spc_dyn, ln_chk_bathy 717 852 !!-------------------------------------------------------------------------------------- … … 729 864 WRITE(numout,*) ' Namelist namagrif : set AGRIF parameters' 730 865 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.' 866 WRITE(numout,*) ' child initial state from parent ln_init_chfrpar = ', ln_init_chfrpar 867 WRITE(numout,*) ' ad. sponge coeft for tracers rn_sponge_tra = ', rn_sponge_tra 868 WRITE(numout,*) ' ad. sponge coeft for dynamics rn_sponge_tra = ', rn_sponge_dyn 869 WRITE(numout,*) ' ad. time relaxation for tracers rn_trelax_tra = ', rn_trelax_tra 870 WRITE(numout,*) ' ad. time relaxation for dynamics rn_trelax_dyn = ', rn_trelax_dyn 735 871 WRITE(numout,*) ' use special values for dynamics ln_spc_dyn = ', ln_spc_dyn 736 872 WRITE(numout,*) ' check bathymetry ln_chk_bathy = ', ln_chk_bathy 737 873 ENDIF 738 ! 739 ! 740 IF( agrif_oce_alloc() > 0 ) CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 874 875 lk_west = .NOT. ( Agrif_Ix() == 1 ) 876 lk_east = .NOT. ( Agrif_Ix() + nbcellsx/AGRIF_Irhox() == Agrif_Parent(jpiglo) -1 ) 877 lk_south = .NOT. ( Agrif_Iy() == 1 ) 878 lk_north = .NOT. ( Agrif_Iy() + nbcellsy/AGRIF_Irhoy() == Agrif_Parent(jpjglo) -1 ) 879 880 ! 881 ! Set the number of ghost cells according to periodicity 882 nbghostcells_x = nbghostcells 883 nbghostcells_y_s = nbghostcells 884 nbghostcells_y_n = nbghostcells 885 ! 886 IF ( jperio == 1 ) nbghostcells_x = 0 887 IF ( .NOT. lk_south ) nbghostcells_y_s = 0 888 889 ! Some checks 890 IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells_x ) & 891 CALL ctl_stop( 'STOP', 'agrif_nemo_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells_x' ) 892 IF( jpjglo /= nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n ) & 893 CALL ctl_stop( 'STOP', 'agrif_nemo_init: Agrif children requires jpjglo == nbcellsy + 2 + nbghostcells_y_s + nbghostcells_y_n' ) 894 IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'agrif_nemo_init:Agrif children requires ln_use_jattr = .false. ' ) 741 895 ! 742 896 END SUBROUTINE agrif_nemo_init 743 897 744 898 # if defined key_mpp_mpi 745 746 899 SUBROUTINE Agrif_InvLoc( indloc, nprocloc, i, indglob ) 747 900 !!---------------------------------------------------------------------- … … 803 956 # endif 804 957 958 SUBROUTINE nemo_mapping(ndim,ptx,pty,bounds,bounds_chunks,correction_required,nb_chunks) 959 !!---------------------------------------------------------------------- 960 !! *** ROUTINE Nemo_mapping *** 961 !!---------------------------------------------------------------------- 962 USE dom_oce 963 !! 964 IMPLICIT NONE 965 ! 966 INTEGER :: ndim 967 INTEGER :: ptx, pty 968 INTEGER, DIMENSION(ndim,2,2) :: bounds 969 INTEGER, DIMENSION(:,:,:,:), ALLOCATABLE :: bounds_chunks 970 LOGICAL, DIMENSION(:), ALLOCATABLE :: correction_required 971 INTEGER :: nb_chunks 972 ! 973 INTEGER :: i 974 975 IF (agrif_debug_interp) THEN 976 DO i=1,ndim 977 WRITE(*,*) 'direction = ',i,bounds(i,1,2),bounds(i,2,2) 978 ENDDO 979 ENDIF 980 981 IF( bounds(2,2,2) > jpjglo) THEN 982 IF( bounds(2,1,2) <=jpjglo) THEN 983 nb_chunks = 2 984 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 985 ALLOCATE(correction_required(nb_chunks)) 986 DO i = 1,nb_chunks 987 bounds_chunks(i,:,:,:) = bounds 988 END DO 989 990 ! FIRST CHUNCK (for j<=jpjglo) 991 992 ! Original indices 993 bounds_chunks(1,1,1,1) = bounds(1,1,2) 994 bounds_chunks(1,1,2,1) = bounds(1,2,2) 995 bounds_chunks(1,2,1,1) = bounds(2,1,2) 996 bounds_chunks(1,2,2,1) = jpjglo 997 998 bounds_chunks(1,1,1,2) = bounds(1,1,2) 999 bounds_chunks(1,1,2,2) = bounds(1,2,2) 1000 bounds_chunks(1,2,1,2) = bounds(2,1,2) 1001 bounds_chunks(1,2,2,2) = jpjglo 1002 1003 ! Correction required or not 1004 correction_required(1)=.FALSE. 1005 1006 ! SECOND CHUNCK (for j>jpjglo) 1007 1008 ! Original indices 1009 bounds_chunks(2,1,1,1) = bounds(1,1,2) 1010 bounds_chunks(2,1,2,1) = bounds(1,2,2) 1011 bounds_chunks(2,2,1,1) = jpjglo-2 1012 bounds_chunks(2,2,2,1) = bounds(2,2,2) 1013 1014 ! Where to find them 1015 ! We use the relation TAB(ji,jj)=TAB(jpiglo-ji+2,jpjglo-2-(jj-jpjglo)) 1016 1017 IF( ptx == 2) THEN ! T, V points 1018 bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+2 1019 bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+2 1020 ELSE ! U, F points 1021 bounds_chunks(2,1,1,2) = jpiglo-bounds(1,2,2)+1 1022 bounds_chunks(2,1,2,2) = jpiglo-bounds(1,1,2)+1 1023 ENDIF 1024 1025 IF( pty == 2) THEN ! T, U points 1026 bounds_chunks(2,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo) 1027 bounds_chunks(2,2,2,2) = jpjglo-2-(jpjglo-2 -jpjglo) 1028 ELSE ! V, F points 1029 bounds_chunks(2,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo) 1030 bounds_chunks(2,2,2,2) = jpjglo-3-(jpjglo-2 -jpjglo) 1031 ENDIF 1032 ! Correction required or not 1033 correction_required(2)=.TRUE. 1034 1035 ELSE 1036 nb_chunks = 1 1037 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 1038 ALLOCATE(correction_required(nb_chunks)) 1039 DO i=1,nb_chunks 1040 bounds_chunks(i,:,:,:) = bounds 1041 END DO 1042 1043 bounds_chunks(1,1,1,1) = bounds(1,1,2) 1044 bounds_chunks(1,1,2,1) = bounds(1,2,2) 1045 bounds_chunks(1,2,1,1) = bounds(2,1,2) 1046 bounds_chunks(1,2,2,1) = bounds(2,2,2) 1047 1048 bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2 1049 bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2 1050 1051 bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2)-jpjglo) 1052 bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2)-jpjglo) 1053 1054 IF( ptx == 2) THEN ! T, V points 1055 bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+2 1056 bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+2 1057 ELSE ! U, F points 1058 bounds_chunks(1,1,1,2) = jpiglo-bounds(1,2,2)+1 1059 bounds_chunks(1,1,2,2) = jpiglo-bounds(1,1,2)+1 1060 ENDIF 1061 1062 IF (pty == 2) THEN ! T, U points 1063 bounds_chunks(1,2,1,2) = jpjglo-2-(bounds(2,2,2) -jpjglo) 1064 bounds_chunks(1,2,2,2) = jpjglo-2-(bounds(2,1,2) -jpjglo) 1065 ELSE ! V, F points 1066 bounds_chunks(1,2,1,2) = jpjglo-3-(bounds(2,2,2) -jpjglo) 1067 bounds_chunks(1,2,2,2) = jpjglo-3-(bounds(2,1,2) -jpjglo) 1068 ENDIF 1069 1070 correction_required(1)=.TRUE. 1071 ENDIF 1072 1073 ELSE IF (bounds(1,1,2) < 1) THEN 1074 IF (bounds(1,2,2) > 0) THEN 1075 nb_chunks = 2 1076 ALLOCATE(correction_required(nb_chunks)) 1077 correction_required=.FALSE. 1078 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 1079 DO i=1,nb_chunks 1080 bounds_chunks(i,:,:,:) = bounds 1081 END DO 1082 1083 bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2 1084 bounds_chunks(1,1,2,2) = 1+jpiglo-2 1085 1086 bounds_chunks(1,1,1,1) = bounds(1,1,2) 1087 bounds_chunks(1,1,2,1) = 1 1088 1089 bounds_chunks(2,1,1,2) = 2 1090 bounds_chunks(2,1,2,2) = bounds(1,2,2) 1091 1092 bounds_chunks(2,1,1,1) = 2 1093 bounds_chunks(2,1,2,1) = bounds(1,2,2) 1094 1095 ELSE 1096 nb_chunks = 1 1097 ALLOCATE(correction_required(nb_chunks)) 1098 correction_required=.FALSE. 1099 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 1100 DO i=1,nb_chunks 1101 bounds_chunks(i,:,:,:) = bounds 1102 END DO 1103 bounds_chunks(1,1,1,2) = bounds(1,1,2)+jpiglo-2 1104 bounds_chunks(1,1,2,2) = bounds(1,2,2)+jpiglo-2 1105 1106 bounds_chunks(1,1,1,1) = bounds(1,1,2) 1107 bounds_chunks(1,1,2,1) = bounds(1,2,2) 1108 ENDIF 1109 ELSE 1110 nb_chunks=1 1111 ALLOCATE(correction_required(nb_chunks)) 1112 correction_required=.FALSE. 1113 ALLOCATE(bounds_chunks(nb_chunks,ndim,2,2)) 1114 DO i=1,nb_chunks 1115 bounds_chunks(i,:,:,:) = bounds 1116 END DO 1117 bounds_chunks(1,1,1,2) = bounds(1,1,2) 1118 bounds_chunks(1,1,2,2) = bounds(1,2,2) 1119 bounds_chunks(1,2,1,2) = bounds(2,1,2) 1120 bounds_chunks(1,2,2,2) = bounds(2,2,2) 1121 1122 bounds_chunks(1,1,1,1) = bounds(1,1,2) 1123 bounds_chunks(1,1,2,1) = bounds(1,2,2) 1124 bounds_chunks(1,2,1,1) = bounds(2,1,2) 1125 bounds_chunks(1,2,2,1) = bounds(2,2,2) 1126 ENDIF 1127 1128 END SUBROUTINE nemo_mapping 1129 1130 FUNCTION agrif_external_switch_index(ptx,pty,i1,isens) 1131 1132 USE dom_oce 1133 1134 INTEGER :: ptx, pty, i1, isens 1135 INTEGER :: agrif_external_switch_index 1136 1137 IF( isens == 1 ) THEN 1138 IF( ptx == 2 ) THEN ! T, V points 1139 agrif_external_switch_index = jpiglo-i1+2 1140 ELSE ! U, F points 1141 agrif_external_switch_index = jpiglo-i1+1 1142 ENDIF 1143 ELSE IF( isens ==2 ) THEN 1144 IF ( pty == 2 ) THEN ! T, U points 1145 agrif_external_switch_index = jpjglo-2-(i1 -jpjglo) 1146 ELSE ! V, F points 1147 agrif_external_switch_index = jpjglo-3-(i1 -jpjglo) 1148 ENDIF 1149 ENDIF 1150 1151 END FUNCTION agrif_external_switch_index 1152 1153 SUBROUTINE Correct_field(tab2d,i1,i2,j1,j2) 1154 !!---------------------------------------------------------------------- 1155 !! *** ROUTINE Correct_field *** 1156 !!---------------------------------------------------------------------- 1157 1158 USE dom_oce 1159 USE agrif_oce 1160 1161 INTEGER :: i1,i2,j1,j2 1162 REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2d 1163 1164 INTEGER :: i,j 1165 REAL(wp), DIMENSION(i1:i2,j1:j2) :: tab2dtemp 1166 1167 tab2dtemp = tab2d 1168 1169 IF( .NOT. use_sign_north ) THEN 1170 DO j=j1,j2 1171 DO i=i1,i2 1172 tab2d(i,j)=tab2dtemp(i2-(i-i1),j2-(j-j1)) 1173 END DO 1174 END DO 1175 ELSE 1176 DO j=j1,j2 1177 DO i=i1,i2 1178 tab2d(i,j)=sign_north * tab2dtemp(i2-(i-i1),j2-(j-j1)) 1179 END DO 1180 END DO 1181 ENDIF 1182 1183 END SUBROUTINE Correct_field 1184 805 1185 #else 806 1186 SUBROUTINE Subcalledbyagrif
Note: See TracChangeset
for help on using the changeset viewer.