Changeset 14789 for NEMO/branches/2021/dev_r13747_HPC-11_mcastril_HPDAonline_DiagGPU/src/NST/agrif_oce_interp.F90
- Timestamp:
- 2021-05-05T13:18:04+02:00 (3 years ago)
- Location:
- NEMO/branches/2021/dev_r13747_HPC-11_mcastril_HPDAonline_DiagGPU
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
src/NST/agrif_oce_interp.F90 (modified) (62 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2021/dev_r13747_HPC-11_mcastril_HPDAonline_DiagGPU
- Property svn:externals
-
old new 3 3 ^/utils/build/mk@HEAD mk 4 4 ^/utils/tools@HEAD tools 5 ^/vendors/AGRIF/dev _r12970_AGRIF_CMEMSext/AGRIF5 ^/vendors/AGRIF/dev@HEAD ext/AGRIF 6 6 ^/vendors/FCM@HEAD ext/FCM 7 7 ^/vendors/IOIPSL@HEAD ext/IOIPSL 8 ^/vendors/PPR@HEAD ext/PPR 8 9 9 10 # SETTE 10 ^/utils/CI/sette@1 3559sette11 ^/utils/CI/sette@14244 sette
-
- Property svn:externals
-
NEMO/branches/2021/dev_r13747_HPC-11_mcastril_HPDAonline_DiagGPU/src/NST/agrif_oce_interp.F90
r13286 r14789 2 2 !!====================================================================== 3 3 !! *** MODULE agrif_oce_interp *** 4 !! AGRIF: interpolation package for the ocean dynamics (O PA)4 !! AGRIF: interpolation package for the ocean dynamics (OCE) 5 5 !!====================================================================== 6 6 !! History : 2.0 ! 2002-06 (L. Debreu) Original cade … … 28 28 USE agrif_oce 29 29 USE phycst 30 USE dynspg_ts, ONLY: un_adv, vn_adv30 !!! USE dynspg_ts, ONLY: un_adv, vn_adv 31 31 ! 32 32 USE in_out_manager … … 45 45 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b 46 46 PUBLIC interpe3t, interpglamt, interpgphit 47 PUBLIC interpht0, interpmbkt 48 PUBLIC agrif_initts, agrif_initssh 47 PUBLIC interpht0, interpmbkt, interpe3t0_vremap 48 PUBLIC agrif_istate_oce, agrif_istate_ssh ! called by icestate.F90 and domvvl.F90 49 PUBLIC agrif_check_bat 49 50 50 51 INTEGER :: bdy_tinterp = 0 51 52 52 !!---------------------------------------------------------------------- 53 !! * Substitutions 54 # include "domzgr_substitute.h90" 53 55 !! NEMO/NST 4.0 , NEMO Consortium (2018) 54 56 !! $Id$ … … 57 59 CONTAINS 58 60 59 SUBROUTINE Agrif_tra 60 !!---------------------------------------------------------------------- 61 !! *** ROUTINE Agrif_tra *** 62 !!---------------------------------------------------------------------- 63 ! 64 IF( Agrif_Root() ) RETURN 61 SUBROUTINE Agrif_istate_oce( Kbb, Kmm, Kaa ) 62 !!---------------------------------------------------------------------- 63 !! *** ROUTINE agrif_istate_oce *** 64 !! 65 !! set initial t, s, u, v, ssh from parent 66 !!---------------------------------------------------------------------- 67 ! 68 IMPLICIT NONE 69 ! 70 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 71 INTEGER :: jn 72 !!---------------------------------------------------------------------- 73 IF(lwp) WRITE(numout,*) ' ' 74 IF(lwp) WRITE(numout,*) 'Agrif_istate_oce : interp child initial state from parent' 75 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~' 76 IF(lwp) WRITE(numout,*) ' ' 77 78 IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 79 & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') 80 81 l_ini_child = .TRUE. 82 Agrif_SpecialValue = 0.0_wp 83 Agrif_UseSpecialValue = .TRUE. 84 85 ts(:,:,:,:,Kbb) = 0.0_wp 86 uu(:,:,:,Kbb) = 0.0_wp 87 vv(:,:,:,Kbb) = 0.0_wp 88 89 Krhs_a = Kbb ; Kmm_a = Kbb 90 91 CALL Agrif_Init_Variable(tsini_id, procname=interptsn) 92 93 Agrif_UseSpecialValue = ln_spc_dyn 94 use_sign_north = .TRUE. 95 sign_north = -1._wp 96 CALL Agrif_Init_Variable(uini_id , procname=interpun ) 97 CALL Agrif_Init_Variable(vini_id , procname=interpvn ) 98 use_sign_north = .FALSE. 99 100 Agrif_UseSpecialValue = .FALSE. 101 l_ini_child = .FALSE. 102 103 Krhs_a = Kaa ; Kmm_a = Kmm 104 105 DO jn = 1, jpts 106 ts(:,:,:,jn,Kbb) = ts(:,:,:,jn,Kbb) * tmask(:,:,:) 107 END DO 108 uu(:,:,:,Kbb) = uu(:,:,:,Kbb) * umask(:,:,:) 109 vv(:,:,:,Kbb) = vv(:,:,:,Kbb) * vmask(:,:,:) 110 111 CALL lbc_lnk( 'agrif_istate_oce', uu(:,:,: ,Kbb), 'U', -1.0_wp , vv(:,:,:,Kbb), 'V', -1.0_wp ) 112 CALL lbc_lnk( 'agrif_istate_oce', ts(:,:,:,:,Kbb), 'T', 1.0_wp ) 113 114 END SUBROUTINE Agrif_istate_oce 115 116 117 SUBROUTINE Agrif_istate_ssh( Kbb, Kmm, Kaa ) 118 !!---------------------------------------------------------------------- 119 !! *** ROUTINE agrif_istate_ssh *** 120 !! 121 !! set initial ssh from parent 122 !!---------------------------------------------------------------------- 123 ! 124 IMPLICIT NONE 125 ! 126 INTEGER, INTENT(in) :: Kbb, Kmm, Kaa 127 !!---------------------------------------------------------------------- 128 IF(lwp) WRITE(numout,*) ' ' 129 IF(lwp) WRITE(numout,*) 'Agrif_istate_ssh : interp child ssh from parent' 130 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~' 131 IF(lwp) WRITE(numout,*) ' ' 132 133 IF ( .NOT.Agrif_Parent(l_1st_euler) ) & 134 & CALL ctl_stop('AGRIF hot start requires to force Euler first step on parent') 135 136 Krhs_a = Kbb ; Kmm_a = Kbb 65 137 ! 66 138 Agrif_SpecialValue = 0._wp 67 139 Agrif_UseSpecialValue = .TRUE. 68 ! 69 CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 140 l_ini_child = .TRUE. 141 ! 142 ssh(:,:,Kbb) = 0._wp 143 CALL Agrif_Init_Variable(sshini_id, procname=interpsshn) 70 144 ! 71 145 Agrif_UseSpecialValue = .FALSE. 146 l_ini_child = .FALSE. 147 ! 148 Krhs_a = Kaa ; Kmm_a = Kmm 149 ! 150 CALL lbc_lnk( 'Agrif_istate_ssh', ssh(:,:,Kbb), 'T', 1._wp ) 151 ! 152 ssh(:,:,Kmm) = ssh(:,:,Kbb) 153 ssh(:,:,Kaa) = 0._wp 154 155 END SUBROUTINE Agrif_istate_ssh 156 157 158 SUBROUTINE Agrif_tra 159 !!---------------------------------------------------------------------- 160 !! *** ROUTINE Agrif_tra *** 161 !!---------------------------------------------------------------------- 162 ! 163 IF( Agrif_Root() ) RETURN 164 ! 165 Agrif_SpecialValue = 0._wp 166 Agrif_UseSpecialValue = .TRUE. 167 l_vremap = ln_vert_remap 168 ! 169 CALL Agrif_Bc_variable( ts_interp_id, procname=interptsn ) 170 ! 171 Agrif_UseSpecialValue = .FALSE. 172 l_vremap = .FALSE. 72 173 ! 73 174 END SUBROUTINE Agrif_tra … … 89 190 Agrif_SpecialValue = 0.0_wp 90 191 Agrif_UseSpecialValue = ln_spc_dyn 192 l_vremap = ln_vert_remap 91 193 ! 92 194 use_sign_north = .TRUE. … … 94 196 CALL Agrif_Bc_variable( un_interp_id, procname=interpun ) 95 197 CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn ) 198 199 IF( .NOT.ln_dynspg_ts ) THEN ! Get transports 200 ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp 201 utint_stage(:,:) = 0 ; vtint_stage(:,:) = 0 202 CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb ) 203 CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb ) 204 ENDIF 205 96 206 use_sign_north = .FALSE. 97 207 ! 98 208 Agrif_UseSpecialValue = .FALSE. 209 l_vremap = .FALSE. 210 ! 211 ! Ensure below that vertically integrated transports match 212 ! either transports out of time splitting procedure (ln_dynspg_ts=.TRUE.) 213 ! or parent grid transports (ln_dynspg_ts=.FALSE.) 99 214 ! 100 215 ! --- West --- ! 101 216 IF( lk_west ) THEN 102 217 ibdy1 = nn_hls + 2 ! halo + land + 1 103 ibdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells218 ibdy2 = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells 104 219 ! 105 220 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 106 221 DO ji = mi0(ibdy1), mi1(ibdy2) 107 uu_b(ji,:,Krhs_a) = 0._wp108 DO jk = 1, jpkm1109 DO jj = 1, jpj110 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)111 END DO112 END DO113 222 DO jj = 1, jpj 114 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a) 223 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 224 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 115 225 END DO 116 226 END DO … … 118 228 ! 119 229 DO ji = mi0(ibdy1), mi1(ibdy2) 120 zub(ji,:) = 0._wp ! Correct transport230 zub(ji,:) = 0._wp 121 231 DO jk = 1, jpkm1 122 232 DO jj = 1, jpj … … 134 244 END DO 135 245 ! 136 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 137 DO ji = mi0(ibdy1), mi1(ibdy2) 138 zvb(ji,:) = 0._wp 139 DO jk = 1, jpkm1 140 DO jj = 1, jpj 141 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 142 END DO 143 END DO 246 DO ji = mi0(ibdy1), mi1(ibdy2) 247 zvb(ji,:) = 0._wp 248 DO jk = 1, jpkm1 144 249 DO jj = 1, jpj 145 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 146 END DO 147 DO jk = 1, jpkm1 148 DO jj = 1, jpj 149 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) )*vmask(ji,jj,jk) 150 END DO 151 END DO 152 END DO 153 ENDIF 250 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 251 END DO 252 END DO 253 DO jj = 1, jpj 254 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 255 END DO 256 DO jk = 1, jpkm1 257 DO jj = 1, jpj 258 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) 259 END DO 260 END DO 261 END DO 154 262 ! 155 263 ENDIF … … 157 265 ! --- East --- ! 158 266 IF( lk_east) THEN 159 ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells160 ibdy2 = jpiglo - ( nn_hls + 2 ) ! halo + land + 1161 ! 162 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport267 ibdy1 = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox() 268 ibdy2 = jpiglo - ( nn_hls + 2 ) 269 ! 270 IF( .NOT.ln_dynspg_ts ) THEN 163 271 DO ji = mi0(ibdy1), mi1(ibdy2) 164 uu_b(ji,:,Krhs_a) = 0._wp165 DO jk = 1, jpkm1166 DO jj = 1, jpj167 uu_b(ji,jj,Krhs_a) = uu_b(ji,jj,Krhs_a) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)168 END DO169 END DO170 272 DO jj = 1, jpj 171 uu_b(ji,jj,Krhs_a) = u u_b(ji,jj,Krhs_a) * r1_hu(ji,jj,Krhs_a)273 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 172 274 END DO 173 275 END DO … … 175 277 ! 176 278 DO ji = mi0(ibdy1), mi1(ibdy2) 177 zub(ji,:) = 0._wp ! Correct transport279 zub(ji,:) = 0._wp 178 280 DO jk = 1, jpkm1 179 281 DO jj = 1, jpj … … 191 293 END DO 192 294 ! 193 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 194 ibdy1 = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 195 ibdy2 = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 295 ibdy1 = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 296 ibdy2 = jpiglo - ( nn_hls + 1 ) 297 ! 298 IF( .NOT.ln_dynspg_ts ) THEN 196 299 DO ji = mi0(ibdy1), mi1(ibdy2) 197 zvb(ji,:) = 0._wp 198 DO jk = 1, jpkm1 199 DO jj = 1, jpj 300 DO jj = 1, jpj 301 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 302 END DO 303 END DO 304 ENDIF 305 ! 306 DO ji = mi0(ibdy1), mi1(ibdy2) 307 zvb(ji,:) = 0._wp 308 DO jk = 1, jpkm1 309 DO jj = 1, jpj 200 310 zvb(ji,jj) = zvb(ji,jj) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 201 END DO 202 END DO 311 END DO 312 END DO 313 DO jj = 1, jpj 314 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a) 315 END DO 316 DO jk = 1, jpkm1 203 317 DO jj = 1, jpj 204 zvb(ji,jj) = zvb(ji,jj) * r1_hv(ji,jj,Krhs_a)205 END DO206 DO jk = 1, jpkm1207 DO jj = 1, jpj208 318 vv(ji,jj,jk,Krhs_a) = ( vv(ji,jj,jk,Krhs_a) + vv_b(ji,jj,Krhs_a) - zvb(ji,jj) ) * vmask(ji,jj,jk) 209 END DO 210 END DO 211 END DO 212 ENDIF 319 END DO 320 END DO 321 END DO 213 322 ! 214 323 ENDIF … … 216 325 ! --- South --- ! 217 326 IF( lk_south ) THEN 218 jbdy1 = nn_hls + 2 ! halo + land + 1219 jbdy2 = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells220 ! 221 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport327 jbdy1 = nn_hls + 2 328 jbdy2 = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() 329 ! 330 IF( .NOT.ln_dynspg_ts ) THEN 222 331 DO jj = mj0(jbdy1), mj1(jbdy2) 223 vv_b(:,jj,Krhs_a) = 0._wp 224 DO jk = 1, jpkm1 225 DO ji = 1, jpi 226 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 227 END DO 228 END DO 229 DO ji=1,jpi 230 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 332 DO ji = 1, jpi 333 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 334 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 231 335 END DO 232 336 END DO … … 234 338 ! 235 339 DO jj = mj0(jbdy1), mj1(jbdy2) 236 zvb(:,jj) = 0._wp ! Correct transport340 zvb(:,jj) = 0._wp 237 341 DO jk=1,jpkm1 238 342 DO ji=1,jpi … … 250 354 END DO 251 355 ! 252 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 253 DO jj = mj0(jbdy1), mj1(jbdy2) 254 zub(:,jj) = 0._wp 255 DO jk = 1, jpkm1 256 DO ji = 1, jpi 257 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 258 END DO 259 END DO 356 DO jj = mj0(jbdy1), mj1(jbdy2) 357 zub(:,jj) = 0._wp 358 DO jk = 1, jpkm1 260 359 DO ji = 1, jpi 261 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 262 END DO 263 DO jk = 1, jpkm1 264 DO ji = 1, jpi 265 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 266 END DO 267 END DO 268 END DO 269 ENDIF 360 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 361 END DO 362 END DO 363 DO ji = 1, jpi 364 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 365 END DO 366 DO jk = 1, jpkm1 367 DO ji = 1, jpi 368 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) 369 END DO 370 END DO 371 END DO 270 372 ! 271 373 ENDIF … … 273 375 ! --- North --- ! 274 376 IF( lk_north ) THEN 275 jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells276 jbdy2 = jpjglo - ( nn_hls + 2 ) ! halo + land + 1277 ! 278 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport377 jbdy1 = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy() 378 jbdy2 = jpjglo - ( nn_hls + 2 ) 379 ! 380 IF( .NOT.ln_dynspg_ts ) THEN 279 381 DO jj = mj0(jbdy1), mj1(jbdy2) 280 vv_b(:,jj,Krhs_a) = 0._wp 281 DO jk = 1, jpkm1 282 DO ji = 1, jpi 283 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) + e3v(ji,jj,jk,Krhs_a) * vv(ji,jj,jk,Krhs_a) * vmask(ji,jj,jk) 284 END DO 285 END DO 286 DO ji=1,jpi 287 vv_b(ji,jj,Krhs_a) = vv_b(ji,jj,Krhs_a) * r1_hv(ji,jj,Krhs_a) 382 DO ji = 1, jpi 383 vv_b(ji,jj,Krhs_a) = vbdy(ji,jj) * r1_hv(ji,jj,Krhs_a) 288 384 END DO 289 385 END DO … … 291 387 ! 292 388 DO jj = mj0(jbdy1), mj1(jbdy2) 293 zvb(:,jj) = 0._wp ! Correct transport389 zvb(:,jj) = 0._wp 294 390 DO jk=1,jpkm1 295 391 DO ji=1,jpi … … 307 403 END DO 308 404 ! 309 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 310 jbdy1 = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1 311 jbdy2 = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 405 jbdy1 = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 406 jbdy2 = jpjglo - ( nn_hls + 1 ) 407 ! 408 IF( .NOT.ln_dynspg_ts ) THEN 312 409 DO jj = mj0(jbdy1), mj1(jbdy2) 313 zub(:,jj) = 0._wp314 DO jk = 1, jpkm1315 DO ji = 1, jpi316 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk)317 END DO318 END DO319 410 DO ji = 1, jpi 320 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 321 END DO 322 DO jk = 1, jpkm1 323 DO ji = 1, jpi 411 uu_b(ji,jj,Krhs_a) = ubdy(ji,jj) * r1_hu(ji,jj,Krhs_a) 412 END DO 413 END DO 414 ENDIF 415 ! 416 DO jj = mj0(jbdy1), mj1(jbdy2) 417 zub(:,jj) = 0._wp 418 DO jk = 1, jpkm1 419 DO ji = 1, jpi 420 zub(ji,jj) = zub(ji,jj) + e3u(ji,jj,jk,Krhs_a) * uu(ji,jj,jk,Krhs_a) * umask(ji,jj,jk) 421 END DO 422 END DO 423 DO ji = 1, jpi 424 zub(ji,jj) = zub(ji,jj) * r1_hu(ji,jj,Krhs_a) 425 END DO 426 DO jk = 1, jpkm1 427 DO ji = 1, jpi 324 428 uu(ji,jj,jk,Krhs_a) = ( uu(ji,jj,jk,Krhs_a) + uu_b(ji,jj,Krhs_a) - zub(ji,jj) ) * umask(ji,jj,jk) 325 END DO 326 END DO 327 END DO 328 ENDIF 429 END DO 430 END DO 431 END DO 329 432 ! 330 433 ENDIF … … 348 451 IF( lk_west ) THEN 349 452 istart = nn_hls + 2 ! halo + land + 1 350 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells453 iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells 351 454 DO ji = mi0(istart), mi1(iend) 352 455 DO jj=1,jpj … … 359 462 !--- East ---! 360 463 IF( lk_east ) THEN 361 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1362 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1464 istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 465 iend = jpiglo - ( nn_hls + 1 ) 363 466 DO ji = mi0(istart), mi1(iend) 364 467 … … 367 470 END DO 368 471 END DO 369 istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells370 iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1472 istart = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox() 473 iend = jpiglo - ( nn_hls + 2 ) 371 474 DO ji = mi0(istart), mi1(iend) 372 475 DO jj=1,jpj … … 378 481 !--- South ---! 379 482 IF( lk_south ) THEN 380 jstart = nn_hls + 2 ! halo + land + 1381 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells483 jstart = nn_hls + 2 484 jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() 382 485 DO jj = mj0(jstart), mj1(jend) 383 486 … … 391 494 !--- North ---! 392 495 IF( lk_north ) THEN 393 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1394 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1496 jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 497 jend = jpjglo - ( nn_hls + 1 ) 395 498 DO jj = mj0(jstart), mj1(jend) 396 499 DO ji=1,jpi … … 398 501 END DO 399 502 END DO 400 jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells401 jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1503 jstart = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy() 504 jend = jpjglo - ( nn_hls + 2 ) 402 505 DO jj = mj0(jstart), mj1(jend) 403 506 DO ji=1,jpi … … 425 528 !--- West ---! 426 529 IF( lk_west ) THEN 427 istart = nn_hls + 2 ! halo + land + 1428 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells530 istart = nn_hls + 2 531 iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() 429 532 DO ji = mi0(istart), mi1(iend) 430 533 DO jj=1,jpj … … 437 540 !--- East ---! 438 541 IF( lk_east ) THEN 439 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1440 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1542 istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() 543 iend = jpiglo - ( nn_hls + 1 ) 441 544 DO ji = mi0(istart), mi1(iend) 442 545 DO jj=1,jpj … … 444 547 END DO 445 548 END DO 446 istart = jpiglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells447 iend = jpiglo - ( nn_hls + 2 ) ! halo + land + 1549 istart = jpiglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhox() 550 iend = jpiglo - ( nn_hls + 2 ) 448 551 DO ji = mi0(istart), mi1(iend) 449 552 DO jj=1,jpj … … 455 558 !--- South ---! 456 559 IF( lk_south ) THEN 457 jstart = nn_hls + 2 ! halo + land + 1458 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells560 jstart = nn_hls + 2 561 jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() 459 562 DO jj = mj0(jstart), mj1(jend) 460 563 DO ji=1,jpi … … 467 570 !--- North ---! 468 571 IF( lk_north ) THEN 469 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1470 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1572 jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() 573 jend = jpjglo - ( nn_hls + 1 ) 471 574 DO jj = mj0(jstart), mj1(jend) 472 575 DO ji=1,jpi … … 474 577 END DO 475 578 END DO 476 jstart = jpjglo - ( nn_hls + nbghostcells + 1) ! halo + land + nbghostcells477 jend = jpjglo - ( nn_hls + 2 ) ! halo + land + 1579 jstart = jpjglo - ( nn_hls + nbghostcells + 1) - nn_shift_bar*Agrif_Rhoy() 580 jend = jpjglo - ( nn_hls + 2 ) 478 581 DO jj = mj0(jstart), mj1(jend) 479 582 DO ji=1,jpi … … 492 595 INTEGER, INTENT(in) :: kt 493 596 !! 494 INTEGER :: ji, jj495 597 LOGICAL :: ll_int_cons 496 598 !!---------------------------------------------------------------------- … … 516 618 ! 517 619 IF( ll_int_cons ) THEN ! Conservative interpolation 518 ! order matters here !!!!!! 519 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 520 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 521 ! 522 bdy_tinterp = 1 523 CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After 524 CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb ) 525 ! 526 bdy_tinterp = 2 527 CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before 528 CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb ) 620 IF ( lk_tint2d_notinterp ) THEN 621 Agrif_UseSpecialValue = .FALSE. 622 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b_const ) 623 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b_const ) 624 ! Divergence conserving correction terms: 625 IF ( Agrif_Rhox()>1 ) CALL Agrif_Bc_variable( ub2b_cor_id, calledweight=1._wp, procname=ub2b_cor ) 626 IF ( Agrif_Rhoy()>1 ) CALL Agrif_Bc_variable( vb2b_cor_id, calledweight=1._wp, procname=vb2b_cor ) 627 ELSE 628 ! order matters here !!!!!! 629 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 630 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 631 ! 632 bdy_tinterp = 1 633 CALL Agrif_Bc_variable( unb_interp_id , calledweight=1._wp, procname=interpunb ) ! After 634 CALL Agrif_Bc_variable( vnb_interp_id , calledweight=1._wp, procname=interpvnb ) 635 ! 636 bdy_tinterp = 2 637 CALL Agrif_Bc_variable( unb_interp_id , calledweight=0._wp, procname=interpunb ) ! Before 638 CALL Agrif_Bc_variable( vnb_interp_id , calledweight=0._wp, procname=interpvnb ) 639 ENDIF 529 640 ELSE ! Linear interpolation 530 641 ! 531 642 ubdy(:,:) = 0._wp ; vbdy(:,:) = 0._wp 532 CALL Agrif_Bc_variable( unb_i d, procname=interpunb )533 CALL Agrif_Bc_variable( vnb_i d, procname=interpvnb )643 CALL Agrif_Bc_variable( unb_interp_id, procname=interpunb ) 644 CALL Agrif_Bc_variable( vnb_interp_id, procname=interpvnb ) 534 645 ENDIF 535 646 Agrif_UseSpecialValue = .FALSE. … … 560 671 ! --- West --- ! 561 672 IF(lk_west) THEN 562 istart = nn_hls + 2 ! halo + land + 1563 iend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells673 istart = nn_hls + 2 ! halo + land + 1 674 iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells 564 675 DO ji = mi0(istart), mi1(iend) 565 676 DO jj = 1, jpj … … 571 682 ! --- East --- ! 572 683 IF(lk_east) THEN 573 istart = jpiglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1574 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1684 istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1 685 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 575 686 DO ji = mi0(istart), mi1(iend) 576 687 DO jj = 1, jpj … … 582 693 ! --- South --- ! 583 694 IF(lk_south) THEN 584 jstart = nn_hls + 2 ! halo + land + 1585 jend = nn_hls + 1 + nbghostcells ! halo + land + nbghostcells695 jstart = nn_hls + 2 ! halo + land + 1 696 jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells 586 697 DO jj = mj0(jstart), mj1(jend) 587 698 DO ji = 1, jpi … … 593 704 ! --- North --- ! 594 705 IF(lk_north) THEN 595 jstart = jpjglo - ( nn_hls + nbghostcells ) ! halo + land + nbghostcells - 1596 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1706 jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1 707 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 597 708 DO jj = mj0(jstart), mj1(jend) 598 709 DO ji = 1, jpi … … 619 730 ! --- West --- ! 620 731 IF(lk_west) THEN 621 istart = nn_hls + 2 ! halo + land + 1622 iend = nn_hls + 1 + nbghostcells 732 istart = nn_hls + 2 ! halo + land + 1 733 iend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells 623 734 DO ji = mi0(istart), mi1(iend) 624 735 DO jj = 1, jpj … … 630 741 ! --- East --- ! 631 742 IF(lk_east) THEN 632 istart = jpiglo - ( nn_hls + nbghostcells ) 633 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1743 istart = jpiglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhox() ! halo + land + nbghostcells - 1 744 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 634 745 DO ji = mi0(istart), mi1(iend) 635 746 DO jj = 1, jpj … … 641 752 ! --- South --- ! 642 753 IF(lk_south) THEN 643 jstart = nn_hls + 2 ! halo + land + 1644 jend = nn_hls + 1 + nbghostcells 754 jstart = nn_hls + 2 ! halo + land + 1 755 jend = nn_hls + 1 + nbghostcells + nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells 645 756 DO jj = mj0(jstart), mj1(jend) 646 757 DO ji = 1, jpi … … 652 763 ! --- North --- ! 653 764 IF(lk_north) THEN 654 jstart = jpjglo - ( nn_hls + nbghostcells ) 655 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1765 jstart = jpjglo - ( nn_hls + nbghostcells ) - nn_shift_bar*Agrif_Rhoy() ! halo + land + nbghostcells - 1 766 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 656 767 DO jj = mj0(jstart), mj1(jend) 657 768 DO ji = 1, jpi … … 678 789 Agrif_SpecialValue = 0.e0 679 790 Agrif_UseSpecialValue = .TRUE. 791 l_vremap = ln_vert_remap 680 792 ! 681 793 CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm ) 682 794 ! 683 795 Agrif_UseSpecialValue = .FALSE. 796 l_vremap = .FALSE. 684 797 ! 685 798 END SUBROUTINE Agrif_avm … … 687 800 688 801 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 689 !!----------------------------------------------------------------------690 !! *** ROUTINE interptsn ***691 802 !!---------------------------------------------------------------------- 692 803 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab … … 698 809 INTEGER :: item 699 810 ! vertical interpolation: 700 REAL(wp) :: zhtot 701 REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin 702 REAL(wp), DIMENSION(k1:k2) :: h_in, z_in811 REAL(wp) :: zhtot, zwgt 812 REAL(wp), DIMENSION(k1:k2,1:jpts) :: tabin, tabin_i 813 REAL(wp), DIMENSION(k1:k2) :: z_in, h_in_i, z_in_i 703 814 REAL(wp), DIMENSION(1:jpk) :: h_out, z_out 704 815 !!---------------------------------------------------------------------- … … 719 830 END DO 720 831 721 IF( l_vremap .OR. l_ini_child) THEN 722 ! Interpolate thicknesses 832 IF( l_vremap .OR. l_ini_child .OR. ln_zps ) THEN 833 834 ! Fill cell depths (i.e. gdept) to be interpolated 723 835 ! Warning: these are masked, hence extrapolated prior interpolation. 724 DO jk=k1,k2 725 DO jj=j1,j2 726 DO ji=i1,i2 727 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a) 728 836 DO jj=j1,j2 837 DO ji=i1,i2 838 ptab(ji,jj,k1,jpts+1) = 0.5_wp * tmask(ji,jj,k1) * e3t(ji,jj,k1,Kmm_a) 839 DO jk=k1+1,k2 840 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * & 841 & ( ptab(ji,jj,jk-1,jpts+1) + 0.5_wp * (e3t(ji,jj,jk-1,Kmm_a)+e3t(ji,jj,jk,Kmm_a)) ) 729 842 END DO 730 843 END DO 731 844 END DO 732 733 ! Extrapolate thicknesses in partial bottom cells: 734 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on 735 IF (ln_zps) THEN 736 DO jj=j1,j2 737 DO ji=i1,i2 738 jk = mbkt(ji,jj) 739 ptab(ji,jj,jk,jpts+1) = 0._wp 740 END DO 741 END DO 742 END IF 743 845 744 846 ! Save ssh at last level: 745 847 IF (.NOT.ln_linssh) THEN 746 848 ptab(i1:i2,j1:j2,k2,jpts+1) = ssh(i1:i2,j1:j2,Kmm_a)*tmask(i1:i2,j1:j2,1) 747 ELSE748 ptab(i1:i2,j1:j2,k2,jpts+1) = 0._wp749 849 END IF 750 850 ENDIF … … 757 857 IF( l_vremap .OR. l_ini_child ) THEN 758 858 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,n2) = 0._wp 759 760 859 DO jj=j1,j2 761 860 DO ji=i1,i2 762 ts(ji,jj,:,:,Krhs_a) = 0. 763 ! IF( l_ini_child) ts(ji,jj,:,:,Krhs_a) = ptab(ji,jj,:,1:jpts) 861 ts(ji,jj,:,:,Krhs_a) = 0. 862 ! 863 ! Build vertical grids: 764 864 N_in = mbkt_parent(ji,jj) 765 zhtot = 0._wp 766 DO jk=1,N_in !k2 = jpk of parent grid 767 IF (jk==N_in) THEN 768 h_in(jk) = ht0_parent(ji,jj) + ptab(ji,jj,k2,n2) - zhtot 769 ELSE 770 h_in(jk) = ptab(ji,jj,jk,n2) 771 ENDIF 772 zhtot = zhtot + h_in(jk) 773 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 774 END DO 775 z_in(1) = 0.5_wp * h_in(1) - zhtot + ht0_parent(ji,jj) 776 DO jk=2,N_in 777 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 778 END DO 779 780 N_out = 0 781 DO jk=1,jpk ! jpk of child grid 782 IF (tmask(ji,jj,jk) == 0._wp) EXIT 783 N_out = N_out + 1 784 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 785 END DO 786 787 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + ht_0(ji,jj) 788 DO jk=2,N_out 789 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 790 END DO 791 865 N_out = mbkt(ji,jj) 792 866 IF (N_in*N_out > 0) THEN 867 ! Input grid (account for partial cells if any): 868 DO jk=1,N_in 869 z_in(jk) = ptab(ji,jj,jk,n2) - ptab(ji,jj,k2,n2) 870 tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts) 871 END DO 872 873 ! Intermediate grid: 874 IF ( l_vremap ) THEN 875 DO jk = 1, N_in 876 h_in_i(jk) = e3t0_parent(ji,jj,jk) * & 877 & (1._wp + ptab(ji,jj,k2,n2)/(ht0_parent(ji,jj)*ssmask(ji,jj) + 1._wp - ssmask(ji,jj))) 878 END DO 879 z_in_i(1) = 0.5_wp * h_in_i(1) 880 DO jk=2,N_in 881 z_in_i(jk) = z_in_i(jk-1) + 0.5_wp * ( h_in_i(jk) + h_in_i(jk-1) ) 882 END DO 883 z_in_i(1:N_in) = z_in_i(1:N_in) - ptab(ji,jj,k2,n2) 884 ENDIF 885 886 ! Output (Child) grid: 887 DO jk=1,N_out 888 h_out(jk) = e3t(ji,jj,jk,Krhs_a) 889 END DO 890 z_out(1) = 0.5_wp * h_out(1) 891 DO jk=2,N_out 892 z_out(jk) = z_out(jk-1) + 0.5_wp * ( h_out(jk)+h_out(jk-1) ) 893 END DO 894 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a) 895 793 896 IF( l_ini_child ) THEN 794 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), &897 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 795 898 & z_out(1:N_out),N_in,N_out,jpts) 796 899 ELSE 797 CALL reconstructandremap(tabin(1:N_in,1:jpts),h_in(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 900 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),tabin_i(1:N_in,1:jpts), & 901 & z_in_i(1:N_in),N_in,N_in,jpts) 902 CALL reconstructandremap(tabin_i(1:N_in,1:jpts),h_in_i(1:N_in),ts(ji,jj,1:N_out,1:jpts,Krhs_a), & 798 903 & h_out(1:N_out),N_in,N_out,jpts) 799 904 ENDIF … … 805 910 ELSE 806 911 807 DO jn=1, jpts 808 ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a)=ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 912 IF ( Agrif_Parent(ln_zps) ) THEN ! Account for partial cells 913 ! linear vertical interpolation 914 DO jj=j1,j2 915 DO ji=i1,i2 916 ! 917 N_in = mbkt(ji,jj) 918 N_out = mbkt(ji,jj) 919 z_in(1) = ptab(ji,jj,1,n2) 920 tabin(1,1:jpts) = ptab(ji,jj,1,1:jpts) 921 DO jk=2, N_in 922 z_in(jk) = ptab(ji,jj,jk,n2) 923 tabin(jk,1:jpts) = ptab(ji,jj,jk,1:jpts) 924 END DO 925 IF (.NOT.ln_linssh) z_in(1:N_in) = z_in(1:N_in) - ptab(ji,jj,k2,n2) 926 z_out(1) = 0.5_wp * e3t(ji,jj,1,Krhs_a) 927 DO jk=2, N_out 928 z_out(jk) = z_out(jk-1) + 0.5_wp * (e3t(ji,jj,jk-1,Krhs_a) + e3t(ji,jj,jk,Krhs_a)) 929 END DO 930 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Krhs_a) 931 CALL remap_linear(tabin(1:N_in,1:jpts),z_in(1:N_in),ptab(ji,jj,1:N_out,1:jpts), & 932 & z_out(1:N_out),N_in,N_out,jpts) 933 END DO 934 END DO 935 ENDIF 936 937 DO jn =1, jpts 938 ts(i1:i2,j1:j2,1:jpk,jn,Krhs_a) = ptab(i1:i2,j1:j2,1:jpk,jn)*tmask(i1:i2,j1:j2,1:jpk) 809 939 END DO 810 940 ENDIF … … 828 958 ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kmm_a) 829 959 ELSE 830 hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 960 IF( l_ini_child ) THEN 961 ssh(i1:i2,j1:j2,Krhs_a) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 962 ELSE 963 hbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) * tmask(i1:i2,j1:j2,1) 964 ENDIF 831 965 ENDIF 832 966 ! … … 869 1003 END DO 870 1004 871 IF( l_vremap .OR. l_ini_child ) THEN1005 IF( l_vremap .OR. l_ini_child ) THEN 872 1006 ! Extrapolate thicknesses in partial bottom cells: 873 1007 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on … … 906 1040 uu(ji,jj,:,Krhs_a) = 0._wp 907 1041 N_in = mbku_parent(ji,jj) 908 zhtot = 0._wp 909 DO jk=1,N_in 910 IF (jk==N_in) THEN 911 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 912 ELSE 913 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 914 ENDIF 915 zhtot = zhtot + h_in(jk) 916 IF( h_in(jk) .GT. 0. ) THEN 917 tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk)) 918 ELSE 919 tabin(jk) = 0. 920 ENDIF 921 END DO 922 z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 923 DO jk=2,N_in 924 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 925 END DO 1042 N_out = mbku(ji,jj) 1043 IF (N_in*N_out > 0) THEN 1044 zhtot = 0._wp 1045 DO jk=1,N_in 1046 !IF (jk==N_in) THEN 1047 ! h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1048 !ELSE 1049 ! h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 1050 !ENDIF 1051 IF ( l_vremap ) THEN 1052 h_in(jk) = e3u0_parent(ji,jj,jk) 1053 ELSE 1054 IF (jk==N_in) THEN 1055 h_in(jk) = hu0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1056 ELSE 1057 h_in(jk) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 1058 ENDIF 1059 ENDIF 1060 zhtot = zhtot + h_in(jk) 1061 IF( h_in(jk) .GT. 0. ) THEN 1062 tabin(jk) = ptab(ji,jj,jk,1)/(e2u(ji,jj)*zrhoy*h_in(jk)) 1063 ELSE 1064 tabin(jk) = 0. 1065 ENDIF 1066 END DO 1067 z_in(1) = 0.5_wp * h_in(1) - zhtot + hu0_parent(ji,jj) 1068 DO jk=2,N_in 1069 z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk)+h_in(jk-1)) 1070 END DO 926 1071 927 N_out = 0 928 DO jk=1,jpk 929 IF (umask(ji,jj,jk) == 0) EXIT 930 N_out = N_out + 1 931 h_out(N_out) = e3u(ji,jj,jk,Krhs_a) 932 END DO 933 934 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj) 935 DO jk=2,N_out 936 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 937 END DO 938 939 IF (N_in*N_out > 0) THEN 940 IF( l_ini_child ) THEN 941 CALL remap_linear (tabin(1:N_in),z_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),z_out(1:N_out),N_in,N_out,1) 942 ELSE 943 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),uu(ji,jj,1:N_out,Krhs_a),h_out(1:N_out),N_in,N_out,1) 944 ENDIF 1072 DO jk=1, N_out 1073 h_out(jk) = e3u(ji,jj,jk,Krhs_a) 1074 END DO 1075 1076 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hu_0(ji,jj) 1077 DO jk=2,N_out 1078 z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1) + h_out(jk)) 1079 END DO 1080 1081 IF( l_ini_child ) THEN 1082 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) 1083 ELSE 1084 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) 1085 ENDIF 945 1086 ENDIF 946 1087 END DO … … 1028 1169 vv(ji,jj,:,Krhs_a) = 0._wp 1029 1170 N_in = mbkv_parent(ji,jj) 1030 zhtot = 0._wp 1031 DO jk=1,N_in 1032 IF (jk==N_in) THEN 1033 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1034 ELSE 1035 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1036 ENDIF 1037 zhtot = zhtot + h_in(jk) 1038 IF( h_in(jk) .GT. 0. ) THEN 1039 tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk)) 1040 ELSE 1041 tabin(jk) = 0. 1042 ENDIF 1043 END DO 1044 1045 z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj) 1046 DO jk=2,N_in 1047 z_in(jk) = z_in(jk-1) + 0.5_wp * h_in(jk) 1048 END DO 1049 1050 N_out = 0 1051 DO jk=1,jpk 1052 IF (vmask(ji,jj,jk) == 0) EXIT 1053 N_out = N_out + 1 1054 h_out(N_out) = e3v(ji,jj,jk,Krhs_a) 1055 END DO 1056 1057 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj) 1058 DO jk=2,N_out 1059 z_out(jk) = z_out(jk-1) + 0.5_wp * h_out(jk) 1060 END DO 1171 N_out = mbkv(ji,jj) 1172 1173 IF (N_in*N_out > 0) THEN 1174 zhtot = 0._wp 1175 DO jk=1,N_in 1176 !IF (jk==N_in) THEN 1177 ! h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1178 !ELSE 1179 ! h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1180 !ENDIF 1181 IF (l_vremap) THEN 1182 h_in(jk) = e3v0_parent(ji,jj,jk) 1183 ELSE 1184 IF (jk==N_in) THEN 1185 h_in(jk) = hv0_parent(ji,jj) + ptab(ji,jj,k2,2) - zhtot 1186 ELSE 1187 h_in(jk) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1188 ENDIF 1189 ENDIF 1190 zhtot = zhtot + h_in(jk) 1191 IF( h_in(jk) .GT. 0. ) THEN 1192 tabin(jk) = ptab(ji,jj,jk,1)/(e1v(ji,jj)*zrhox*h_in(jk)) 1193 ELSE 1194 tabin(jk) = 0. 1195 ENDIF 1196 END DO 1197 1198 z_in(1) = 0.5_wp * h_in(1) - zhtot + hv0_parent(ji,jj) 1199 DO jk=2,N_in 1200 z_in(jk) = z_in(jk-1) + 0.5_wp * (h_in(jk-1)+h_in(jk)) 1201 END DO 1202 1203 DO jk=1,N_out 1204 h_out(jk) = e3v(ji,jj,jk,Krhs_a) 1205 END DO 1206 1207 z_out(1) = 0.5_wp * h_out(1) - SUM(h_out(1:N_out)) + hv_0(ji,jj) 1208 DO jk=2,N_out 1209 z_out(jk) = z_out(jk-1) + 0.5_wp * (h_out(jk-1)+h_out(jk)) 1210 END DO 1061 1211 1062 IF (N_in*N_out > 0) THEN1063 1212 IF( l_ini_child ) THEN 1064 1213 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) … … 1192 1341 !!---------------------------------------------------------------------- 1193 1342 IF( before ) THEN 1194 IF ( ln_bt_fw ) THEN1343 ! IF ( ln_bt_fw ) THEN 1195 1344 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2) 1196 ELSE1197 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2)1198 ENDIF1345 ! ELSE 1346 ! ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2) 1347 ! ENDIF 1199 1348 ELSE 1200 1349 zrhot = Agrif_rhot() … … 1214 1363 END SUBROUTINE interpub2b 1215 1364 1216 1217 SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before ) 1218 !!---------------------------------------------------------------------- 1219 !! *** ROUTINE interpvb2b *** 1365 SUBROUTINE interpub2b_const( ptab, i1, i2, j1, j2, before ) 1366 !!---------------------------------------------------------------------- 1367 !! *** ROUTINE interpub2b_const *** 1220 1368 !!---------------------------------------------------------------------- 1221 1369 INTEGER , INTENT(in ) :: i1, i2, j1, j2 … … 1223 1371 LOGICAL , INTENT(in ) :: before 1224 1372 ! 1373 REAL(wp) :: zrhoy 1374 !!---------------------------------------------------------------------- 1375 IF( before ) THEN 1376 ! IF ( ln_bt_fw ) THEN 1377 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2) 1378 ! ELSE 1379 ! ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * un_adv(i1:i2,j1:j2) 1380 ! ENDIF 1381 ELSE 1382 zrhoy = Agrif_Rhoy() 1383 ! 1384 ubdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) & 1385 & / (zrhoy*e2u(i1:i2,j1:j2)) * umask(i1:i2,j1:j2,1) 1386 ! 1387 ENDIF 1388 ! 1389 END SUBROUTINE interpub2b_const 1390 1391 1392 SUBROUTINE ub2b_cor( ptab, i1, i2, j1, j2, before ) 1393 !!---------------------------------------------------------------------- 1394 !! *** ROUTINE ub2b_cor *** 1395 !!---------------------------------------------------------------------- 1396 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1397 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1398 LOGICAL , INTENT(in ) :: before 1399 ! 1400 INTEGER :: ji, jj 1401 REAL(wp) :: zrhox, zrhoy, zx 1402 !!---------------------------------------------------------------------- 1403 IF( before ) THEN 1404 ptab(:,:) = 0._wp 1405 DO ji=i1+1,i2-1 1406 DO jj=j1+1,j2-1 1407 ptab(ji,jj) = 0.25_wp*( ( vb2_b(ji+1,jj )*e1v(ji+1,jj ) & 1408 & -vb2_b(ji-1,jj )*e1v(ji-1,jj ) ) & 1409 & -( vb2_b(ji+1,jj-1)*e1v(ji+1,jj-1) & 1410 & -vb2_b(ji-1,jj-1)*e1v(ji-1,jj-1) ) ) 1411 END DO 1412 END DO 1413 ELSE 1414 ! 1415 zrhox = Agrif_Rhox() 1416 zrhoy = Agrif_Rhoy() 1417 DO ji=i1,i2 1418 DO jj=j1,j2 1419 IF (utint_stage(ji,jj)==0) THEN 1420 zx = 2._wp*MOD(ABS(mig0(ji)-nbghostcells-1), INT(Agrif_Rhox()))/zrhox - 1._wp 1421 ubdy(ji,jj) = ubdy(ji,jj) + 0.25_wp*(1._wp-zx*zx) * ptab(ji,jj) & 1422 & / zrhoy *r1_e2u(ji,jj) * umask(ji,jj,1) 1423 utint_stage(ji,jj) = 1 1424 ENDIF 1425 END DO 1426 END DO 1427 ! 1428 ENDIF 1429 ! 1430 END SUBROUTINE ub2b_cor 1431 1432 1433 SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before ) 1434 !!---------------------------------------------------------------------- 1435 !! *** ROUTINE interpvb2b *** 1436 !!---------------------------------------------------------------------- 1437 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1438 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1439 LOGICAL , INTENT(in ) :: before 1440 ! 1225 1441 INTEGER :: ji,jj 1226 1442 REAL(wp) :: zrhot, zt0, zt1, zat … … 1228 1444 ! 1229 1445 IF( before ) THEN 1230 IF ( ln_bt_fw ) THEN1446 ! IF ( ln_bt_fw ) THEN 1231 1447 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 1232 ELSE1233 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2)1234 ENDIF1448 ! ELSE 1449 ! ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2) 1450 ! ENDIF 1235 1451 ELSE 1236 1452 zrhot = Agrif_rhot() … … 1251 1467 1252 1468 1469 SUBROUTINE interpvb2b_const( ptab, i1, i2, j1, j2, before ) 1470 !!---------------------------------------------------------------------- 1471 !! *** ROUTINE interpub2b_const *** 1472 !!---------------------------------------------------------------------- 1473 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1474 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1475 LOGICAL , INTENT(in ) :: before 1476 ! 1477 REAL(wp) :: zrhox 1478 !!---------------------------------------------------------------------- 1479 IF( before ) THEN 1480 ! IF ( ln_bt_fw ) THEN 1481 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 1482 ! ELSE 1483 ! ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vn_adv(i1:i2,j1:j2) 1484 ! ENDIF 1485 ELSE 1486 zrhox = Agrif_Rhox() 1487 ! 1488 vbdy(i1:i2,j1:j2) = ptab(i1:i2,j1:j2) & 1489 & / (zrhox*e1v(i1:i2,j1:j2)) * vmask(i1:i2,j1:j2,1) 1490 ! 1491 ENDIF 1492 ! 1493 END SUBROUTINE interpvb2b_const 1494 1495 1496 SUBROUTINE vb2b_cor( ptab, i1, i2, j1, j2, before ) 1497 !!---------------------------------------------------------------------- 1498 !! *** ROUTINE vb2b_cor *** 1499 !!---------------------------------------------------------------------- 1500 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1501 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1502 LOGICAL , INTENT(in ) :: before 1503 ! 1504 INTEGER :: ji, jj 1505 REAL(wp) :: zrhox, zrhoy, zy 1506 !!---------------------------------------------------------------------- 1507 IF( before ) THEN 1508 ptab(:,:) = 0._wp 1509 DO ji=i1+1,i2-1 1510 DO jj=j1+1,j2-1 1511 ptab(ji,jj) = 0.25_wp*( ( ub2_b(ji ,jj+1)*e2u(ji ,jj+1) & 1512 & -ub2_b(ji ,jj-1)*e2u(ji ,jj-1) ) & 1513 & -( ub2_b(ji-1,jj+1)*e2u(ji-1,jj+1) & 1514 & -ub2_b(ji-1,jj-1)*e2u(ji-1,jj-1) ) ) 1515 END DO 1516 END DO 1517 ELSE 1518 ! 1519 zrhox = Agrif_Rhox() 1520 zrhoy = Agrif_Rhoy() 1521 DO ji=i1,i2 1522 DO jj=j1,j2 1523 IF (vtint_stage(ji,jj)==0) THEN 1524 zy = 2._wp*MOD(ABS(mjg0(jj)-nbghostcells-1), INT(Agrif_Rhoy()))/zrhoy - 1._wp 1525 vbdy(ji,jj) = vbdy(ji,jj) + 0.25_wp*(1._wp-zy*zy) * ptab(ji,jj) & 1526 & / zrhox * r1_e1v(ji,jj) * vmask(ji,jj,1) 1527 vtint_stage(ji,jj) = 1 1528 ENDIF 1529 END DO 1530 END DO 1531 ! 1532 ENDIF 1533 ! 1534 END SUBROUTINE vb2b_cor 1535 1536 1253 1537 SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before ) 1254 1538 !!---------------------------------------------------------------------- … … 1272 1556 WRITE(numout,*) ' Agrif error for e3t_0: parent , child, i, j, k ', & 1273 1557 & ptab(ji,jj,jk), tmask(ji,jj,jk) * e3t_0(ji,jj,jk), & 1274 & mig0(ji), m ig0(jj), jk1275 !kindic_agr = kindic_agr + 11558 & mig0(ji), mjg0(jj), jk 1559 kindic_agr = kindic_agr + 1 1276 1560 ENDIF 1277 1561 END DO … … 1282 1566 ! 1283 1567 END SUBROUTINE interpe3t 1568 1569 1570 SUBROUTINE interpe3t0_vremap( ptab, i1, i2, j1, j2, k1, k2, before ) 1571 !!---------------------------------------------------------------------- 1572 !! *** ROUTINE interpe3t0_vremap *** 1573 !!---------------------------------------------------------------------- 1574 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 1575 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1576 LOGICAL , INTENT(in ) :: before 1577 ! 1578 INTEGER :: ji, jj, jk 1579 REAL(wp) :: zh 1580 !!---------------------------------------------------------------------- 1581 ! 1582 IF( before ) THEN 1583 IF ( ln_zps ) THEN 1584 DO jk = k1, k2 1585 DO jj = j1, j2 1586 DO ji = i1, i2 1587 ptab(ji, jj, jk) = e3t_1d(jk) 1588 END DO 1589 END DO 1590 END DO 1591 ELSE 1592 ptab(i1:i2,j1:j2,k1:k2) = e3t_0(i1:i2,j1:j2,k1:k2) 1593 ENDIF 1594 ELSE 1595 ! 1596 DO jk = k1, k2 1597 DO jj = j1, j2 1598 DO ji = i1, i2 1599 e3t0_parent(ji,jj,jk) = ptab(ji,jj,jk) 1600 END DO 1601 END DO 1602 END DO 1603 1604 ! Retrieve correct scale factor at the bottom: 1605 DO jj = j1, j2 1606 DO ji = i1, i2 1607 zh = 0._wp 1608 DO jk = 1, mbkt_parent(ji, jj)-1 1609 zh = zh + e3t0_parent(ji,jj,jk) 1610 END DO 1611 e3t0_parent(ji,jj,mbkt_parent(ji,jj)) = ht0_parent(ji, jj) - zh 1612 END DO 1613 END DO 1614 1615 ENDIF 1616 ! 1617 END SUBROUTINE interpe3t0_vremap 1618 1284 1619 1285 1620 SUBROUTINE interpglamt( ptab, i1, i2, j1, j2, before ) … … 1365 1700 1366 1701 IF( l_vremap ) THEN 1367 ! Interpolate thicknesses1702 ! Interpolate interfaces 1368 1703 ! Warning: these are masked, hence extrapolated prior interpolation. 1369 1704 DO jk=k1,k2 1370 1705 DO jj=j1,j2 1371 1706 DO ji=i1,i2 1372 ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * e3t(ji,jj,jk,Kmm_a)1707 ptab(ji,jj,jk,2) = tmask(ji,jj,jk) * gdepw(ji,jj,jk,Kmm_a) 1373 1708 END DO 1374 1709 END DO 1375 1710 END DO 1376 1377 ! Extrapolate thicknesses in partial bottom cells:1378 ! Set them to Agrif_SpecialValue (0.). Correct bottom thicknesses are retrieved later on1379 IF (ln_zps) THEN1380 DO jj=j1,j21381 DO ji=i1,i21382 jk = mbkt(ji,jj)1383 ptab(ji,jj,jk,2) = 0._wp1384 END DO1385 END DO1386 END IF1387 1711 1388 1712 ! Save ssh at last level: … … 1398 1722 IF( l_vremap ) THEN 1399 1723 IF (ln_linssh) ptab(i1:i2,j1:j2,k2,2) = 0._wp 1400 avm_k(i1:i2,j1:j2, k1:k2) = 0._wp1724 avm_k(i1:i2,j1:j2,1:jpkm1) = 0._wp 1401 1725 1402 1726 DO jj = j1, j2 1403 1727 DO ji =i1, i2 1404 1728 N_in = mbkt_parent(ji,jj) 1405 IF ( tmask(ji,jj,1) == 0._wp) N_in = 0 1406 z_in(N_in+1) = ht0_parent(ji,jj) + ptab(ji,jj,k2,2) 1407 DO jk = N_in, 1, -1 ! Parent vertical grid 1408 z_in(jk) = z_in(jk+1) - ptab(ji,jj,jk,2) 1409 tabin(jk) = ptab(ji,jj,jk,1) 1410 END DO 1411 N_out = mbkt(ji,jj) 1412 DO jk = 1, N_out ! Child vertical grid 1413 z_out(jk) = gdepw(ji,jj,jk,Kmm_a) 1414 END DO 1729 N_out = mbkt(ji,jj) 1415 1730 IF (N_in*N_out > 0) THEN 1731 DO jk = 1, N_in ! Parent vertical grid 1732 z_in(jk) = ptab(ji,jj,jk,2) - ptab(ji,jj,k2,2) 1733 tabin(jk) = ptab(ji,jj,jk,1) 1734 END DO 1735 DO jk = 1, N_out ! Child vertical grid 1736 z_out(jk) = gdepw(ji,jj,jk,Kmm_a) - ssh(ji,jj,Kmm_a) 1737 END DO 1738 IF (.NOT.ln_linssh) z_out(1:N_out) = z_out(1:N_out) - ssh(ji,jj,Kmm_a) 1739 1416 1740 CALL remap_linear(tabin(1:N_in),z_in(1:N_in),avm_k(ji,jj,1:N_out),z_out(1:N_out),N_in,N_out,1) 1417 1741 ENDIF … … 1419 1743 END DO 1420 1744 ELSE 1421 avm_k(i1:i2,j1:j2, k1:k2) = ptab (i1:i2,j1:j2,k1:k2,1)1745 avm_k(i1:i2,j1:j2,1:jpkm1) = ptab (i1:i2,j1:j2,1:jpkm1,1) 1422 1746 ENDIF 1423 1747 ENDIF … … 1428 1752 SUBROUTINE interpmbkt( ptab, i1, i2, j1, j2, before ) 1429 1753 !!---------------------------------------------------------------------- 1430 !! *** ROUTINE interp sshn***1754 !! *** ROUTINE interpmbkt *** 1431 1755 !!---------------------------------------------------------------------- 1432 1756 INTEGER , INTENT(in ) :: i1, i2, j1, j2 … … 1447 1771 SUBROUTINE interpht0( ptab, i1, i2, j1, j2, before ) 1448 1772 !!---------------------------------------------------------------------- 1449 !! *** ROUTINE interp sshn***1773 !! *** ROUTINE interpht0 *** 1450 1774 !!---------------------------------------------------------------------- 1451 1775 INTEGER , INTENT(in ) :: i1, i2, j1, j2 … … 1463 1787 END SUBROUTINE interpht0 1464 1788 1465 1466 SUBROUTINE agrif_initts(tabres,i1,i2,j1,j2,k1,k2,m1,m2,before) 1467 INTEGER :: i1, i2, j1, j2, k1, k2, m1, m2 1468 REAL(wp):: tabres(i1:i2,j1:j2,k1:k2,m1:m2) 1469 LOGICAL :: before 1470 1471 INTEGER :: jm 1472 1473 IF (before) THEN 1474 DO jm=1,jpts 1475 tabres(i1:i2,j1:j2,k1:k2,jm) = ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a) 1476 END DO 1477 ELSE 1478 DO jm=1,jpts 1479 ts(i1:i2,j1:j2,k1:k2,jm,Kbb_a)=tabres(i1:i2,j1:j2,k1:k2,jm) 1480 END DO 1481 ENDIF 1482 END SUBROUTINE agrif_initts 1483 1484 1485 SUBROUTINE agrif_initssh( ptab, i1, i2, j1, j2, before ) 1486 !!---------------------------------------------------------------------- 1487 !! *** ROUTINE interpsshn *** 1488 !!---------------------------------------------------------------------- 1489 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1490 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1491 LOGICAL , INTENT(in ) :: before 1492 ! 1493 !!---------------------------------------------------------------------- 1494 ! 1495 IF( before) THEN 1496 ptab(i1:i2,j1:j2) = ssh(i1:i2,j1:j2,Kbb_a) 1497 ELSE 1498 ssh(i1:i2,j1:j2,Kbb_a) = ptab(i1:i2,j1:j2)*tmask(i1:i2,j1:j2,1) 1499 ENDIF 1500 ! 1501 END SUBROUTINE agrif_initssh 1789 SUBROUTINE Agrif_check_bat( iindic ) 1790 !!---------------------------------------------------------------------- 1791 !! *** ROUTINE Agrif_check_bat *** 1792 !!---------------------------------------------------------------------- 1793 INTEGER, INTENT(inout) :: iindic 1794 !! 1795 INTEGER :: ji, jj 1796 INTEGER :: istart, iend, jstart, jend, ispon 1797 !!---------------------------------------------------------------------- 1798 ! 1799 ! 1800 ! --- West --- ! 1801 IF(lk_west) THEN 1802 ispon = nn_sponge_len * Agrif_irhox() 1803 istart = nn_hls + 2 ! halo + land + 1 1804 iend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge 1805 jstart = nn_hls + 2 1806 jend = jpjglo - nn_hls - 1 1807 DO ji = mi0(istart), mi1(iend) 1808 DO jj = mj0(jstart), mj1(jend) 1809 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1810 END DO 1811 DO jj = mj0(jstart), mj1(jend-1) 1812 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1813 END DO 1814 END DO 1815 DO ji = mi0(istart), mi1(iend-1) 1816 DO jj = mj0(jstart), mj1(jend) 1817 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1818 END DO 1819 END DO 1820 ENDIF 1821 ! 1822 ! --- East --- ! 1823 IF(lk_east) THEN 1824 ispon = nn_sponge_len * Agrif_irhox() 1825 istart = jpiglo - ( nn_hls + nbghostcells + ispon ) ! halo + land + nbghostcells + sponge - 1 1826 iend = jpiglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 1827 jstart = nn_hls + 2 1828 jend = jpjglo - nn_hls - 1 1829 DO ji = mi0(istart), mi1(iend) 1830 DO jj = mj0(jstart), mj1(jend) 1831 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1832 END DO 1833 DO jj = mj0(jstart), mj1(jend-1) 1834 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1835 END DO 1836 END DO 1837 DO ji = mi0(istart+1), mi1(iend-1) 1838 DO jj = mj0(jstart), mj1(jend) 1839 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1840 END DO 1841 END DO 1842 ENDIF 1843 ! 1844 ! --- South --- ! 1845 IF(lk_south) THEN 1846 ispon = nn_sponge_len * Agrif_irhoy() 1847 jstart = nn_hls + 2 ! halo + land + 1 1848 jend = nn_hls + 1 + nbghostcells + ispon ! halo + land + nbghostcells + sponge 1849 istart = nn_hls + 2 1850 iend = jpiglo - nn_hls - 1 1851 DO jj = mj0(jstart), mj1(jend) 1852 DO ji = mi0(istart), mi1(iend) 1853 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1854 END DO 1855 DO ji = mi0(istart), mi1(iend-1) 1856 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1857 END DO 1858 END DO 1859 DO jj = mj0(jstart), mj1(jend-1) 1860 DO ji = mi0(istart), mi1(iend) 1861 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1862 END DO 1863 END DO 1864 ENDIF 1865 ! 1866 ! --- North --- ! 1867 IF(lk_north) THEN 1868 ispon = nn_sponge_len * Agrif_irhoy() 1869 jstart = jpjglo - ( nn_hls + nbghostcells + ispon) ! halo + land + nbghostcells +sponge - 1 1870 jend = jpjglo - ( nn_hls + 1 ) ! halo + land + 1 - 1 1871 istart = nn_hls + 2 1872 iend = jpiglo - nn_hls - 1 1873 DO jj = mj0(jstart), mj1(jend) 1874 DO ji = mi0(istart), mi1(iend) 1875 IF ( ABS(ht0_parent(ji,jj)-ht_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1876 END DO 1877 DO ji = mi0(istart), mi1(iend-1) 1878 IF ( ABS(hu0_parent(ji,jj)-hu_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1879 END DO 1880 END DO 1881 DO jj = mj0(jstart+1), mj1(jend-1) 1882 DO ji = mi0(istart), mi1(iend) 1883 IF ( ABS(hv0_parent(ji,jj)-hv_0(ji,jj)) > 1.e-3 ) iindic = iindic + 1 1884 END DO 1885 END DO 1886 ENDIF 1887 ! 1888 END SUBROUTINE Agrif_check_bat 1502 1889 1503 1890 #else
Note: See TracChangeset
for help on using the changeset viewer.
