Changeset 6404 for branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
- Timestamp:
- 2016-03-29T11:24:48+02:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r6401 r6404 22 22 USE oce 23 23 USE dom_oce 24 USE sol_oce24 USE zdf_oce 25 25 USE agrif_oce 26 26 USE phycst 27 ! 27 28 USE in_out_manager 28 29 USE agrif_opa_sponge 29 30 USE lib_mpp 30 31 USE wrk_nemo 31 USE dynspg_oce32 USE zdf_oce33 32 34 33 IMPLICIT NONE 35 34 PRIVATE 36 37 INTEGER :: bdy_tinterp = 038 35 39 36 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts … … 49 46 # endif 50 47 51 # include "domzgr_substitute.h90" 48 INTEGER :: bdy_tinterp = 0 49 52 50 # include "vectopt_loop_substitute.h90" 53 51 !!---------------------------------------------------------------------- 54 !! NEMO/NST 3. 6 , NEMO Consortium (2010)52 !! NEMO/NST 3.7 , NEMO Consortium (2015) 55 53 !! $Id$ 56 54 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 57 55 !!---------------------------------------------------------------------- 58 59 56 ! VERTICAL REFINEMENT BEGIN 60 57 REAL, DIMENSION(:,:,:), ALLOCATABLE :: interp_scales_t, interp_scales_u, interp_scales_v … … 100 97 DO jj=j1,j2 101 98 DO ji=i1,i2 102 ! ptab(ji,jj,jk) = fse3t_n(ji,jj,jk) * tmask(ji,jj,jk)103 ptab(ji,jj,jk) = fse3t_n(ji,jj,jk)99 ! ptab(ji,jj,jk) = e3t_n(ji,jj,jk) * tmask(ji,jj,jk) 100 ptab(ji,jj,jk) = e3t_n(ji,jj,jk) 104 101 END DO 105 102 END DO … … 109 106 DO jj=j1,j2 110 107 DO ji=i1,i2 111 ! ptab(ji,jj,jk) = fse3u_n(ji,jj,jk) * umask(ji,jj,jk)112 ! ptab(ji,jj,jk) = fse3u_n(ji,jj,jk)108 ! ptab(ji,jj,jk) = e3u_n(ji,jj,jk) * umask(ji,jj,jk) 109 ! ptab(ji,jj,jk) = e3u_n(ji,jj,jk) 113 110 ptab(ji,jj,jk) = umask(ji,jj,jk) 114 111 END DO … … 119 116 DO jj=j1,j2 120 117 DO ji=i1,i2 121 ! ptab(ji,jj,jk) = fse3v_n(ji,jj,jk) * vmask(ji,jj,jk)122 ! ptab(ji,jj,jk) = fse3v_n(ji,jj,jk)118 ! ptab(ji,jj,jk) = e3v_n(ji,jj,jk) * vmask(ji,jj,jk) 119 ! ptab(ji,jj,jk) = e3v_n(ji,jj,jk) 123 120 ptab(ji,jj,jk) = vmask(ji,jj,jk) 124 121 END DO … … 167 164 ! 168 165 IF( Agrif_Root() ) RETURN 169 170 Agrif_SpecialValue = 0. e0166 ! 167 Agrif_SpecialValue = 0._wp 171 168 Agrif_UseSpecialValue = .TRUE. 172 169 ! 173 170 CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 171 ! 174 172 Agrif_UseSpecialValue = .FALSE. 175 173 ! … … 181 179 !! *** ROUTINE Agrif_DYN *** 182 180 !!---------------------------------------------------------------------- 183 !!184 181 INTEGER, INTENT(in) :: kt 185 !! 186 INTEGER :: ji,jj,jk, j1,j2, i1,i2 187 REAL(wp) :: timeref 188 REAL(wp) :: z2dt, znugdt 189 REAL(wp) :: zrhox, zrhoy 190 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 191 !!---------------------------------------------------------------------- 192 182 ! 183 INTEGER :: ji, jj, jk ! dummy loop indices 184 INTEGER :: j1, j2, i1, i2 185 REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb 186 !!---------------------------------------------------------------------- 187 ! 193 188 IF( Agrif_Root() ) RETURN 194 195 CALL wrk_alloc( jpi, jpj, spgv1, spgu1)196 197 Agrif_SpecialValue =0.189 ! 190 CALL wrk_alloc( jpi,jpj, zub, zvb ) 191 ! 192 Agrif_SpecialValue = 0._wp 198 193 Agrif_UseSpecialValue = ln_spc_dyn 199 200 CALL Agrif_Bc_variable(un_interp_id,procname=interpun) 201 CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 202 203 #if defined key_dynspg_flt 204 CALL Agrif_Bc_variable(e1u_id,calledweight=1., procname=interpun2d) 205 CALL Agrif_Bc_variable(e2v_id,calledweight=1., procname=interpvn2d) 206 #endif 207 194 ! 195 CALL Agrif_Bc_variable( un_interp_id, procname=interpun ) 196 CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn ) 197 ! 208 198 Agrif_UseSpecialValue = .FALSE. 209 210 zrhox = Agrif_Rhox() 211 zrhoy = Agrif_Rhoy() 212 213 timeref = 1. 214 ! time step: leap-frog 215 z2dt = 2. * rdt 216 ! time step: Euler if restart from rest 217 IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt 218 ! coefficients 219 znugdt = grav * z2dt 220 199 ! 221 200 ! prevent smoothing in ghost cells 222 i1=1 223 i2=jpi 224 j1=1 225 j2=jpj 226 IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 227 IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 228 IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 229 IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 230 231 232 IF((nbondi == -1).OR.(nbondi == 2)) THEN 233 #if defined key_dynspg_flt 234 DO jk=1,jpkm1 201 i1 = 1 ; i2 = jpi 202 j1 = 1 ; j2 = jpj 203 IF( nbondj == -1 .OR. nbondj == 2 ) j1 = 3 204 IF( nbondj == +1 .OR. nbondj == 2 ) j2 = nlcj-2 205 IF( nbondi == -1 .OR. nbondi == 2 ) i1 = 3 206 IF( nbondi == +1 .OR. nbondi == 2 ) i2 = nlci-2 207 208 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 209 ! 210 ! Smoothing 211 ! --------- 212 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 213 ua_b(2,:) = 0._wp 214 DO jk = 1, jpkm1 215 DO jj = 1, jpj 216 ua_b(2,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 217 END DO 218 END DO 219 DO jj = 1, jpj 220 ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj) 221 END DO 222 ENDIF 223 ! 224 DO jk=1,jpkm1 ! Smooth 235 225 DO jj=j1,j2 236 ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 237 END DO 238 END DO 239 240 spgu(2,:)=0. 226 ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 227 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 228 END DO 229 END DO 230 ! 231 zub(2,:) = 0._wp ! Correct transport 232 DO jk = 1, jpkm1 233 DO jj = 1, jpj 234 zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 235 END DO 236 END DO 237 DO jj=1,jpj 238 zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 239 END DO 241 240 242 241 DO jk=1,jpkm1 243 242 DO jj=1,jpj 244 spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 245 END DO 246 END DO 247 248 DO jj=1,jpj 249 IF (umask(2,jj,1).NE.0.) THEN 250 spgu(2,jj)=spgu(2,jj)/hu(2,jj) 251 ENDIF 252 END DO 253 #else 254 spgu(2,:) = ua_b(2,:) 255 #endif 256 257 DO jk=1,jpkm1 258 DO jj=j1,j2 259 ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 260 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 261 END DO 262 END DO 263 264 spgu1(2,:)=0. 265 266 DO jk=1,jpkm1 243 ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 244 END DO 245 END DO 246 247 ! Set tangential velocities to time splitting estimate 248 !----------------------------------------------------- 249 IF( ln_dynspg_ts ) THEN 250 zvb(2,:) = 0._wp 251 DO jk = 1, jpkm1 252 DO jj = 1, jpj 253 zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk) 254 END DO 255 END DO 256 DO jj = 1, jpj 257 zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj) 258 END DO 259 DO jk = 1, jpkm1 260 DO jj = 1, jpj 261 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk) 262 END DO 263 END DO 264 ENDIF 265 ! 266 ! Mask domain edges: 267 !------------------- 268 DO jk = 1, jpkm1 269 DO jj = 1, jpj 270 ua(1,jj,jk) = 0._wp 271 va(1,jj,jk) = 0._wp 272 END DO 273 END DO 274 ! 275 ENDIF 276 277 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 278 279 ! Smoothing 280 ! --------- 281 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 282 ua_b(nlci-2,:) = 0._wp 283 DO jk=1,jpkm1 284 DO jj=1,jpj 285 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 286 END DO 287 END DO 267 288 DO jj=1,jpj 268 spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 269 END DO 270 END DO 271 272 DO jj=1,jpj 273 IF (umask(2,jj,1).NE.0.) THEN 274 spgu1(2,jj)=spgu1(2,jj)/hu(2,jj) 275 ENDIF 276 END DO 277 278 DO jk=1,jpkm1 279 DO jj=j1,j2 280 ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 281 END DO 282 END DO 283 284 #if defined key_dynspg_ts 289 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj) 290 END DO 291 ENDIF 292 293 DO jk = 1, jpkm1 ! Smooth 294 DO jj = j1, j2 295 ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) & 296 & * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) ) 297 END DO 298 END DO 299 300 zub(nlci-2,:) = 0._wp ! Correct transport 301 DO jk = 1, jpkm1 302 DO jj = 1, jpj 303 zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 304 END DO 305 END DO 306 DO jj = 1, jpj 307 zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj) 308 END DO 309 310 DO jk = 1, jpkm1 311 DO jj = 1, jpj 312 ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk) 313 END DO 314 END DO 315 ! 285 316 ! Set tangential velocities to time splitting estimate 286 spgv1(2,:)=0. 287 DO jk=1,jpkm1 317 !----------------------------------------------------- 318 IF( ln_dynspg_ts ) THEN 319 zvb(nlci-1,:) = 0._wp 320 DO jk = 1, jpkm1 321 DO jj = 1, jpj 322 zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 323 END DO 324 END DO 288 325 DO jj=1,jpj 289 spgv1(2,jj)=spgv1(2,jj)+fse3v_a(2,jj,jk)*va(2,jj,jk) 290 END DO 291 END DO 292 DO jj=1,jpj 293 spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 294 END DO 295 DO jk=1,jpkm1 296 DO jj=1,jpj 297 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-spgv1(2,jj))*vmask(2,jj,jk) 298 END DO 299 END DO 300 #endif 301 302 ENDIF 303 304 IF((nbondi == 1).OR.(nbondi == 2)) THEN 305 #if defined key_dynspg_flt 306 DO jk=1,jpkm1 307 DO jj=j1,j2 308 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 309 END DO 310 END DO 311 spgu(nlci-2,:)=0. 312 DO jk=1,jpkm1 313 DO jj=1,jpj 314 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 315 ENDDO 316 ENDDO 317 DO jj=1,jpj 318 IF (umask(nlci-2,jj,1).NE.0.) THEN 319 spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj) 320 ENDIF 321 END DO 322 #else 323 spgu(nlci-2,:) = ua_b(nlci-2,:) 324 #endif 325 DO jk=1,jpkm1 326 DO jj=j1,j2 327 ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 328 329 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 330 331 END DO 332 END DO 333 spgu1(nlci-2,:)=0. 334 DO jk=1,jpkm1 335 DO jj=1,jpj 336 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 337 END DO 338 END DO 339 DO jj=1,jpj 340 IF (umask(nlci-2,jj,1).NE.0.) THEN 341 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj) 342 ENDIF 343 END DO 344 DO jk=1,jpkm1 345 DO jj=j1,j2 346 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 347 END DO 348 END DO 349 350 #if defined key_dynspg_ts 351 ! Set tangential velocities to time splitting estimate 352 spgv1(nlci-1,:)=0._wp 353 DO jk=1,jpkm1 354 DO jj=1,jpj 355 spgv1(nlci-1,jj)=spgv1(nlci-1,jj)+fse3v_a(nlci-1,jj,jk)*va(nlci-1,jj,jk)*vmask(nlci-1,jj,jk) 356 END DO 357 END DO 358 359 DO jj=1,jpj 360 spgv1(nlci-1,jj)=spgv1(nlci-1,jj)*hvr_a(nlci-1,jj) 361 END DO 362 363 DO jk=1,jpkm1 364 DO jj=1,jpj 365 va(nlci-1,jj,jk) = (va(nlci-1,jj,jk)+va_b(nlci-1,jj)-spgv1(nlci-1,jj))*vmask(nlci-1,jj,jk) 366 END DO 367 END DO 368 #endif 369 370 ENDIF 371 372 IF((nbondj == -1).OR.(nbondj == 2)) THEN 373 374 #if defined key_dynspg_flt 326 zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj) 327 END DO 328 DO jk = 1, jpkm1 329 DO jj = 1, jpj 330 va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk) 331 END DO 332 END DO 333 ENDIF 334 ! 335 ! Mask domain edges: 336 !------------------- 337 DO jk = 1, jpkm1 338 DO jj = 1, jpj 339 ua(nlci-1,jj,jk) = 0._wp 340 va(nlci ,jj,jk) = 0._wp 341 END DO 342 END DO 343 ! 344 ENDIF 345 346 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 347 348 ! Smoothing 349 ! --------- 350 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 351 va_b(:,2) = 0._wp 352 DO jk = 1, jpkm1 353 DO ji = 1, jpi 354 va_b(ji,2) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) 355 END DO 356 END DO 357 DO ji=1,jpi 358 va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2) 359 END DO 360 ENDIF 361 ! 362 DO jk = 1, jpkm1 ! Smooth 363 DO ji = i1, i2 364 va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) & 365 & * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) ) 366 END DO 367 END DO 368 ! 369 zvb(:,2) = 0._wp ! Correct transport 375 370 DO jk=1,jpkm1 376 371 DO ji=1,jpi 377 va(ji,2,jk) = (va(ji,2,jk) - z2dt * znugdt * laplacv(ji,2))*vmask(ji,2,jk) 378 END DO 379 END DO 380 381 spgv(:,2)=0. 382 383 DO jk=1,jpkm1 384 DO ji=1,jpi 385 spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk) 386 END DO 387 END DO 388 389 DO ji=1,jpi 390 IF (vmask(ji,2,1).NE.0.) THEN 391 spgv(ji,2)=spgv(ji,2)/hv(ji,2) 392 ENDIF 393 END DO 394 #else 395 spgv(:,2)=va_b(:,2) 396 #endif 397 398 DO jk=1,jpkm1 399 DO ji=i1,i2 400 va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 401 va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 402 END DO 403 END DO 404 405 spgv1(:,2)=0. 406 407 DO jk=1,jpkm1 408 DO ji=1,jpi 409 spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 410 END DO 411 END DO 412 413 DO ji=1,jpi 414 IF (vmask(ji,2,1).NE.0.) THEN 415 spgv1(ji,2)=spgv1(ji,2)/hv(ji,2) 416 ENDIF 417 END DO 418 419 DO jk=1,jpkm1 420 DO ji=1,jpi 421 va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 422 END DO 423 END DO 424 425 #if defined key_dynspg_ts 372 zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 373 END DO 374 END DO 375 DO ji = 1, jpi 376 zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2) 377 END DO 378 DO jk = 1, jpkm1 379 DO ji = 1, jpi 380 va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk) 381 END DO 382 END DO 383 426 384 ! Set tangential velocities to time splitting estimate 427 spgu1(:,2)=0._wp 428 DO jk=1,jpkm1 429 DO ji=1,jpi 430 spgu1(ji,2)=spgu1(ji,2)+fse3u_a(ji,2,jk)*ua(ji,2,jk)*umask(ji,2,jk) 431 END DO 432 END DO 433 434 DO ji=1,jpi 435 spgu1(ji,2)=spgu1(ji,2)*hur_a(ji,2) 436 END DO 437 438 DO jk=1,jpkm1 439 DO ji=1,jpi 440 ua(ji,2,jk) = (ua(ji,2,jk)+ua_b(ji,2)-spgu1(ji,2))*umask(ji,2,jk) 441 END DO 442 END DO 443 #endif 444 ENDIF 445 446 IF((nbondj == 1).OR.(nbondj == 2)) THEN 447 448 #if defined key_dynspg_flt 449 DO jk=1,jpkm1 450 DO ji=1,jpi 451 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)-z2dt * znugdt * laplacv(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 452 END DO 453 END DO 454 455 456 spgv(:,nlcj-2)=0. 457 458 DO jk=1,jpkm1 459 DO ji=1,jpi 460 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 461 END DO 462 END DO 463 464 DO ji=1,jpi 465 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 466 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2) 467 ENDIF 468 END DO 469 470 #else 471 spgv(:,nlcj-2)=va_b(:,nlcj-2) 472 #endif 473 474 DO jk=1,jpkm1 475 DO ji=i1,i2 476 va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 477 va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 478 END DO 479 END DO 480 481 spgv1(:,nlcj-2)=0. 482 483 DO jk=1,jpkm1 484 DO ji=1,jpi 485 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 486 END DO 487 END DO 488 489 DO ji=1,jpi 490 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 491 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2) 492 ENDIF 493 END DO 494 495 DO jk=1,jpkm1 496 DO ji=1,jpi 497 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 498 END DO 499 END DO 500 501 #if defined key_dynspg_ts 385 !----------------------------------------------------- 386 IF( ln_dynspg_ts ) THEN 387 zub(:,2) = 0._wp 388 DO jk = 1, jpkm1 389 DO ji = 1, jpi 390 zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 391 END DO 392 END DO 393 DO ji = 1, jpi 394 zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2) 395 END DO 396 397 DO jk = 1, jpkm1 398 DO ji = 1, jpi 399 ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk) 400 END DO 401 END DO 402 ENDIF 403 404 ! Mask domain edges: 405 !------------------- 406 DO jk = 1, jpkm1 407 DO ji = 1, jpi 408 ua(ji,1,jk) = 0._wp 409 va(ji,1,jk) = 0._wp 410 END DO 411 END DO 412 413 ENDIF 414 415 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 416 ! 417 ! Smoothing 418 ! --------- 419 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 420 va_b(:,nlcj-2) = 0._wp 421 DO jk = 1, jpkm1 422 DO ji = 1, jpi 423 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) 424 END DO 425 END DO 426 DO ji = 1, jpi 427 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 428 END DO 429 ENDIF 430 ! 431 DO jk = 1, jpkm1 ! Smooth 432 DO ji = i1, i2 433 va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) & 434 & * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) ) 435 END DO 436 END DO 437 ! 438 zvb(:,nlcj-2) = 0._wp ! Correct transport 439 DO jk = 1, jpkm1 440 DO ji = 1, jpi 441 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 442 END DO 443 END DO 444 DO ji = 1, jpi 445 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 446 END DO 447 DO jk = 1, jpkm1 448 DO ji = 1, jpi 449 va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk) 450 END DO 451 END DO 452 ! 502 453 ! Set tangential velocities to time splitting estimate 503 spgu1(:,nlcj-1)=0._wp 504 DO jk=1,jpkm1 505 DO ji=1,jpi 506 spgu1(ji,nlcj-1)=spgu1(ji,nlcj-1)+fse3u_a(ji,nlcj-1,jk)*ua(ji,nlcj-1,jk) 507 END DO 508 END DO 509 510 DO ji=1,jpi 511 spgu1(ji,nlcj-1)=spgu1(ji,nlcj-1)*hur_a(ji,nlcj-1) 512 END DO 513 514 DO jk=1,jpkm1 515 DO ji=1,jpi 516 ua(ji,nlcj-1,jk) = (ua(ji,nlcj-1,jk)+ua_b(ji,nlcj-1)-spgu1(ji,nlcj-1))*umask(ji,nlcj-1,jk) 517 END DO 518 END DO 519 #endif 520 521 ENDIF 522 ! 523 CALL wrk_dealloc( jpi, jpj, spgv1, spgu1 ) 454 !----------------------------------------------------- 455 IF( ln_dynspg_ts ) THEN 456 zub(:,nlcj-1) = 0._wp 457 DO jk = 1, jpkm1 458 DO ji = 1, jpi 459 zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 460 END DO 461 END DO 462 DO ji = 1, jpi 463 zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1) 464 END DO 465 ! 466 DO jk = 1, jpkm1 467 DO ji = 1, jpi 468 ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk) 469 END DO 470 END DO 471 ENDIF 472 ! 473 ! Mask domain edges: 474 !------------------- 475 DO jk = 1, jpkm1 476 DO ji = 1, jpi 477 ua(ji,nlcj ,jk) = 0._wp 478 va(ji,nlcj-1,jk) = 0._wp 479 END DO 480 END DO 481 ! 482 ENDIF 483 ! 484 CALL wrk_dealloc( jpi,jpj, zub, zvb ) 524 485 ! 525 486 END SUBROUTINE Agrif_dyn 487 526 488 527 489 SUBROUTINE Agrif_dyn_ts( jn ) … … 534 496 INTEGER :: ji, jj 535 497 !!---------------------------------------------------------------------- 536 498 ! 537 499 IF( Agrif_Root() ) RETURN 538 500 ! 539 501 IF((nbondi == -1).OR.(nbondi == 2)) THEN 540 502 DO jj=1,jpj … … 547 509 END DO 548 510 ENDIF 549 511 ! 550 512 IF((nbondi == 1).OR.(nbondi == 2)) THEN 551 513 DO jj=1,jpj … … 558 520 END DO 559 521 ENDIF 560 522 ! 561 523 IF((nbondj == -1).OR.(nbondj == 2)) THEN 562 524 DO ji=1,jpi … … 569 531 END DO 570 532 ENDIF 571 533 ! 572 534 IF((nbondj == 1).OR.(nbondj == 2)) THEN 573 535 DO ji=1,jpi … … 583 545 END SUBROUTINE Agrif_dyn_ts 584 546 547 585 548 SUBROUTINE Agrif_dta_ts( kt ) 586 549 !!---------------------------------------------------------------------- … … 594 557 REAL(wp) :: zrhot, zt 595 558 !!---------------------------------------------------------------------- 596 559 ! 597 560 IF( Agrif_Root() ) RETURN 598 599 ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 600 ! the forward case only 601 561 ! 562 ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only 563 ! 602 564 zrhot = Agrif_rhot() 603 565 ! 604 566 ! "Central" time index for interpolation: 605 IF (ln_bt_fw) THEN606 zt = REAL( Agrif_NbStepint()+0.5_wp,wp) / zrhot567 IF( ln_bt_fw ) THEN 568 zt = REAL( Agrif_NbStepint()+0.5_wp, wp ) / zrhot 607 569 ELSE 608 zt = REAL( Agrif_NbStepint(),wp) / zrhot609 ENDIF 610 570 zt = REAL( Agrif_NbStepint() , wp ) / zrhot 571 ENDIF 572 ! 611 573 ! Linear interpolation of sea level 612 Agrif_SpecialValue = 0. e0574 Agrif_SpecialValue = 0._wp 613 575 Agrif_UseSpecialValue = .TRUE. 614 CALL Agrif_Bc_variable( sshn_id,calledweight=zt, procname=interpsshn )576 CALL Agrif_Bc_variable( sshn_id, calledweight=zt, procname=interpsshn ) 615 577 Agrif_UseSpecialValue = .FALSE. 616 578 ! 617 579 ! Interpolate barotropic fluxes 618 580 Agrif_SpecialValue=0. 619 581 Agrif_UseSpecialValue = ln_spc_dyn 620 621 IF (ll_int_cons) THEN! Conservative interpolation582 ! 583 IF( ll_int_cons ) THEN ! Conservative interpolation 622 584 ! orders matters here !!!!!! 623 CALL Agrif_Bc_variable( ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated624 CALL Agrif_Bc_variable( vb2b_interp_id,calledweight=1._wp, procname=interpvb2b)585 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 586 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 625 587 bdy_tinterp = 1 626 CALL Agrif_Bc_variable( unb_id ,calledweight=1._wp, procname=interpunb) ! After627 CALL Agrif_Bc_variable( vnb_id ,calledweight=1._wp, procname=interpvnb)588 CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After 589 CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb ) 628 590 bdy_tinterp = 2 629 CALL Agrif_Bc_variable( unb_id ,calledweight=0._wp, procname=interpunb) ! Before630 CALL Agrif_Bc_variable( vnb_id ,calledweight=0._wp, procname=interpvnb)591 CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before 592 CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb ) 631 593 ELSE ! Linear interpolation 632 594 bdy_tinterp = 0 633 ubdy_w(:) = 0. e0 ; vbdy_w(:) = 0.e0634 ubdy_e(:) = 0. e0 ; vbdy_e(:) = 0.e0635 ubdy_n(:) = 0. e0 ; vbdy_n(:) = 0.e0636 ubdy_s(:) = 0. e0 ; vbdy_s(:) = 0.e0637 CALL Agrif_Bc_variable( unb_id,calledweight=zt, procname=interpunb)638 CALL Agrif_Bc_variable( vnb_id,calledweight=zt, procname=interpvnb)595 ubdy_w(:) = 0._wp ; vbdy_w(:) = 0._wp 596 ubdy_e(:) = 0._wp ; vbdy_e(:) = 0._wp 597 ubdy_n(:) = 0._wp ; vbdy_n(:) = 0._wp 598 ubdy_s(:) = 0._wp ; vbdy_s(:) = 0._wp 599 CALL Agrif_Bc_variable( unb_id, calledweight=zt, procname=interpunb ) 600 CALL Agrif_Bc_variable( vnb_id, calledweight=zt, procname=interpvnb ) 639 601 ENDIF 640 602 Agrif_UseSpecialValue = .FALSE. … … 642 604 END SUBROUTINE Agrif_dta_ts 643 605 606 644 607 SUBROUTINE Agrif_ssh( kt ) 645 608 !!---------------------------------------------------------------------- … … 649 612 !! 650 613 !!---------------------------------------------------------------------- 651 614 ! 652 615 IF( Agrif_Root() ) RETURN 653 616 ! 654 617 IF((nbondi == -1).OR.(nbondi == 2)) THEN 655 618 ssha(2,:)=ssha(3,:) 656 619 sshn(2,:)=sshn(3,:) 657 620 ENDIF 658 621 ! 659 622 IF((nbondi == 1).OR.(nbondi == 2)) THEN 660 623 ssha(nlci-1,:)=ssha(nlci-2,:) 661 624 sshn(nlci-1,:)=sshn(nlci-2,:) 662 625 ENDIF 663 626 ! 664 627 IF((nbondj == -1).OR.(nbondj == 2)) THEN 665 628 ssha(:,2)=ssha(:,3) 666 629 sshn(:,2)=sshn(:,3) 667 630 ENDIF 668 631 ! 669 632 IF((nbondj == 1).OR.(nbondj == 2)) THEN 670 633 ssha(:,nlcj-1)=ssha(:,nlcj-2) 671 634 sshn(:,nlcj-1)=sshn(:,nlcj-2) 672 635 ENDIF 673 636 ! 674 637 END SUBROUTINE Agrif_ssh 638 675 639 676 640 SUBROUTINE Agrif_ssh_ts( jn ) … … 682 646 INTEGER :: ji,jj 683 647 !!---------------------------------------------------------------------- 684 648 ! 685 649 IF((nbondi == -1).OR.(nbondi == 2)) THEN 686 DO jj =1,jpj650 DO jj = 1, jpj 687 651 ssha_e(2,jj) = hbdy_w(jj) 688 652 END DO 689 653 ENDIF 690 654 ! 691 655 IF((nbondi == 1).OR.(nbondi == 2)) THEN 692 DO jj =1,jpj656 DO jj = 1, jpj 693 657 ssha_e(nlci-1,jj) = hbdy_e(jj) 694 658 END DO 695 659 ENDIF 696 660 ! 697 661 IF((nbondj == -1).OR.(nbondj == 2)) THEN 698 DO ji =1,jpi662 DO ji = 1, jpi 699 663 ssha_e(ji,2) = hbdy_s(ji) 700 664 END DO 701 665 ENDIF 702 666 ! 703 667 IF((nbondj == 1).OR.(nbondj == 2)) THEN 704 DO ji =1,jpi668 DO ji = 1, jpi 705 669 ssha_e(ji,nlcj-1) = hbdy_n(ji) 706 670 END DO 707 671 ENDIF 708 672 ! 709 673 END SUBROUTINE Agrif_ssh_ts 710 674 711 675 # if defined key_zdftke 676 712 677 SUBROUTINE Agrif_tke 713 678 !!---------------------------------------------------------------------- … … 715 680 !!---------------------------------------------------------------------- 716 681 REAL(wp) :: zalpha 682 !!---------------------------------------------------------------------- 717 683 ! 718 684 return … … 720 686 zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 721 687 IF( zalpha > 1. ) zalpha = 1. 722 688 ! 723 689 Agrif_SpecialValue = 0.e0 724 690 Agrif_UseSpecialValue = .TRUE. 725 691 ! 726 692 CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm) 727 693 ! 728 694 Agrif_UseSpecialValue = .FALSE. 729 695 ! 730 696 END SUBROUTINE Agrif_tke 697 731 698 # endif 732 699 733 SUBROUTINE interptsn( ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir)734 !!--------------------------------------------- 700 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 701 !!---------------------------------------------------------------------- 735 702 !! *** ROUTINE interptsn *** 736 !!--------------------------------------------- 737 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab738 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2739 LOGICAL , INTENT(in) ::before740 INTEGER , INTENT(in) ::nb , ndir703 !!---------------------------------------------------------------------- 704 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 705 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 706 LOGICAL , INTENT(in ) :: before 707 INTEGER , INTENT(in ) :: nb , ndir 741 708 ! 742 709 INTEGER :: ji, jj, jk, jn ! dummy loop indices 743 INTEGER ::imin, imax, jmin, jmax710 INTEGER :: imin, imax, jmin, jmax 744 711 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 745 712 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 … … 762 729 do ji=i1,i2 763 730 h_in(k1:k2) = interp_scales_t(ji,jj,k1:k2) 764 h_out(1:jpk) = fse3t(ji,jj,1:jpk)731 h_out(1:jpk) = e3t_n(ji,jj,1:jpk) 765 732 h_diff = sum(h_out(1:jpk-1))-sum(h_in(k1:k2-1)) 766 733 N_in = k2-1 … … 829 796 DO jk = 1, jpkm1 830 797 DO jj = jmin,jmax 831 IF( umask(nlci-2,jj,jk) == 0. e0) THEN798 IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 832 799 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 833 800 ELSE 834 801 tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 835 IF( un(nlci-2,jj,jk) > 0. e0) THEN802 IF( un(nlci-2,jj,jk) > 0._wp ) THEN 836 803 tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 837 804 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) … … 840 807 END DO 841 808 END DO 842 ENDDO 809 tsa(nlci,j1:j2,k1:k2,jn) = 0._wp 810 END DO 843 811 ENDIF 844 812 ! … … 848 816 DO jk = 1, jpkm1 849 817 DO ji = imin,imax 850 IF( vmask(ji,nlcj-2,jk) == 0. e0) THEN818 IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN 851 819 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 852 820 ELSE 853 821 tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 854 IF (vn(ji,nlcj-2,jk) > 0. e0) THEN822 IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN 855 823 tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn) & 856 824 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) … … 859 827 END DO 860 828 END DO 861 ENDDO 862 ENDIF 863 ! 864 IF( western_side) THEN 829 tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp 830 END DO 831 ENDIF 832 ! 833 IF( western_side ) THEN 865 834 DO jn = 1, jpts 866 835 tsa(1,j1:j2,1:jpk,jn) = zalpha1 * ptab_child(1,j1:j2,1:jpk,jn) + zalpha2 * ptab_child(2,j1:j2,1:jpk,jn) 867 836 DO jk = 1, jpkm1 868 837 DO jj = jmin,jmax 869 IF( umask(2,jj,jk) == 0. e0) THEN838 IF( umask(2,jj,jk) == 0._wp ) THEN 870 839 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 871 840 ELSE 872 841 tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 873 IF( un(2,jj,jk) < 0. e0) THEN842 IF( un(2,jj,jk) < 0._wp ) THEN 874 843 tsa(2,jj,jk,jn)=(zalpha6*tsa(3,jj,jk,jn)+zalpha5*tsa(1,jj,jk,jn)+zalpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 875 844 ENDIF … … 877 846 END DO 878 847 END DO 848 tsa(1,j1:j2,k1:k2,jn) = 0._wp 879 849 END DO 880 850 ENDIF … … 883 853 DO jn = 1, jpts 884 854 tsa(i1:i2,1,1:jpk,jn) = zalpha1 * ptab_child(i1:i2,1,1:jpk,jn) + zalpha2 * ptab_child(i1:i2,2,1:jpk,jn) 885 DO jk =1,jpk855 DO jk = 1, jpk 886 856 DO ji=imin,imax 887 IF( vmask(ji,2,jk) == 0. e0) THEN857 IF( vmask(ji,2,jk) == 0._wp ) THEN 888 858 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 889 859 ELSE 890 860 tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 891 IF( vn(ji,2,jk) < 0. e0) THEN861 IF( vn(ji,2,jk) < 0._wp ) THEN 892 862 tsa(ji,2,jk,jn)=(zalpha6*tsa(ji,3,jk,jn)+zalpha5*tsa(ji,1,jk,jn)+zalpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 893 863 ENDIF … … 895 865 END DO 896 866 END DO 897 ENDDO 867 tsa(i1:i2,1,k1:k2,jn) = 0._wp 868 END DO 898 869 ENDIF 899 870 ! … … 921 892 END SUBROUTINE interptsn 922 893 923 SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 894 895 SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir ) 924 896 !!---------------------------------------------------------------------- 925 897 !! *** ROUTINE interpsshn *** 926 898 !!---------------------------------------------------------------------- 927 INTEGER, INTENT(in) :: i1,i2,j1,j2 928 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 929 LOGICAL, INTENT(in) :: before 930 INTEGER, INTENT(in) :: nb , ndir 899 INTEGER , INTENT(in ) :: i1, i2, j1, j2 900 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 901 LOGICAL , INTENT(in ) :: before 902 INTEGER , INTENT(in ) :: nb , ndir 903 ! 931 904 LOGICAL :: western_side, eastern_side,northern_side,southern_side 932 905 !!---------------------------------------------------------------------- … … 977 950 DO ji=i1,i2 978 951 ptab(ji,jj,jk,1) = e2u(ji,jj) * un(ji,jj,jk) 979 ptab(ji,jj,jk,1) = ptab(ji,jj,jk,1) * fse3u(ji,jj,jk)980 ptab(ji,jj,jk,2) = fse3u(ji,jj,jk)952 ptab(ji,jj,jk,1) = ptab(ji,jj,jk,1) * e3u_n(ji,jj,jk) 953 ptab(ji,jj,jk,2) = e3u_n(ji,jj,jk) 981 954 END DO 982 955 END DO … … 1011 984 if (umask(iref,jj,jk) == 0) EXIT 1012 985 N_out = N_out + 1 1013 h_out(N_out) = fse3u(ji,jj,jk)986 h_out(N_out) = e3u_n(ji,jj,jk) 1014 987 enddo 1015 988 … … 1030 1003 call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ptab_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 1031 1004 1032 ptab_child(ji,jj,N_out) = ptab_child(ji,jj,N_out) * h_out(N_out) / fse3u(ji,jj,N_out)1005 ptab_child(ji,jj,N_out) = ptab_child(ji,jj,N_out) * h_out(N_out) / e3u_n(ji,jj,N_out) 1033 1006 1034 1007 ENDDO … … 1040 1013 1041 1014 zrhoy = Agrif_Rhoy() 1042 DO jk =1,jpkm11015 DO jk = 1, jpkm1 1043 1016 DO jj=j1,j2 1044 1017 ua(i1:i2,jj,jk) = (ptab_child(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) … … 1085 1058 !!--------------------------------------------- 1086 1059 !! *** ROUTINE interpvn *** 1087 !!--------------------------------------------- 1060 !!---------------------------------------------------------------------- 1061 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 1062 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1063 LOGICAL , INTENT(in ) :: before 1088 1064 ! 1089 1065 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2 … … 1113 1089 DO ji=i1,i2 1114 1090 ptab(ji,jj,jk,1) = e1v(ji,jj) * vn(ji,jj,jk) 1115 ptab(ji,jj,jk,1) = ptab(ji,jj,jk,1) * fse3v(ji,jj,jk)1116 ptab(ji,jj,jk,2) = fse3v(ji,jj,jk)1091 ptab(ji,jj,jk,1) = ptab(ji,jj,jk,1) * e3v_n(ji,jj,jk) 1092 ptab(ji,jj,jk,2) = e3v_n(ji,jj,jk) 1117 1093 END DO 1118 1094 END DO … … 1145 1121 if (vmask(ji,jref,jk) == 0) EXIT 1146 1122 N_out = N_out + 1 1147 h_out(N_out) = fse3v(ji,jj,jk)1123 h_out(N_out) = e3v_n(ji,jj,jk) 1148 1124 enddo 1149 1125 IF (N_out == 0) THEN … … 1163 1139 call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ptab_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 1164 1140 1165 ptab_child(ji,jj,N_out) = ptab_child(ji,jj,N_out) * h_out(N_out) / fse3v(ji,jj,N_out)1141 ptab_child(ji,jj,N_out) = ptab_child(ji,jj,N_out) * h_out(N_out) / e3v_n(ji,jj,N_out) 1166 1142 1167 1143 enddo … … 1171 1147 ! VERTICAL REFINEMENT END 1172 1148 zrhox= Agrif_Rhox() 1149 <<<<<<< .working 1173 1150 DO jk=1,jpkm1 1174 1151 DO jj=j1,j2 … … 1179 1156 ! 1180 1157 END SUBROUTINE interpvn 1181 1182 SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 1183 !!--------------------------------------------- 1184 !! *** ROUTINE interpvn *** 1185 !!--------------------------------------------- 1186 ! 1187 INTEGER, INTENT(in) :: i1,i2,j1,j2 1188 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1189 LOGICAL, INTENT(in) :: before 1190 ! 1191 INTEGER :: ji,jj 1192 REAL(wp) :: zrhox 1193 REAL(wp) :: ztref 1194 !!--------------------------------------------- 1195 ! 1196 ztref = 1. 1197 IF (before) THEN 1198 !interpv entre 1 et k2 et interpv2d en jpkp1 1199 DO jj=j1,MIN(j2,nlcj-1) 1200 DO ji=i1,i2 1201 ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 1202 END DO 1203 END DO 1204 ELSE 1205 zrhox = Agrif_Rhox() 1206 DO ji=i1,i2 1207 laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 1208 END DO 1209 ENDIF 1210 ! 1211 END SUBROUTINE interpvn2d 1212 1213 SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 1158 1159 1160 SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir ) 1214 1161 !!---------------------------------------------------------------------- 1215 1162 !! *** ROUTINE interpunb *** 1216 1163 !!---------------------------------------------------------------------- 1217 INTEGER, INTENT(in) :: i1,i2,j1,j2 1218 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1219 LOGICAL, INTENT(in) :: before 1220 INTEGER, INTENT(in) :: nb , ndir 1221 !! 1222 INTEGER :: ji,jj 1223 REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 1224 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1225 !!---------------------------------------------------------------------- 1226 ! 1227 IF (before) THEN 1228 DO jj=j1,j2 1229 DO ji=i1,i2 1230 ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj) 1231 END DO 1232 END DO 1164 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1165 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1166 LOGICAL , INTENT(in ) :: before 1167 INTEGER , INTENT(in ) :: nb , ndir 1168 ! 1169 INTEGER :: ji, jj 1170 REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 1171 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1172 !!---------------------------------------------------------------------- 1173 ! 1174 IF( before ) THEN 1175 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2) 1233 1176 ELSE 1234 1177 western_side = (nb == 1).AND.(ndir == 1) … … 1244 1187 IF( bdy_tinterp == 1 ) THEN 1245 1188 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 1246 &- zt0**2._wp * ( zt0 - 1._wp) )1189 & - zt0**2._wp * ( zt0 - 1._wp) ) 1247 1190 ELSEIF( bdy_tinterp == 2 ) THEN 1248 1191 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 1249 &- zt0 * ( zt0 - 1._wp)**2._wp )1192 & - zt0 * ( zt0 - 1._wp)**2._wp ) 1250 1193 1251 1194 ELSE … … 1268 1211 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 1269 1212 IF(western_side) THEN 1270 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 1271 & * umask(i1,j1:j2,1) 1213 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 1272 1214 ENDIF 1273 1215 IF(eastern_side) THEN 1274 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 1275 & * umask(i1,j1:j2,1) 1216 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 1276 1217 ENDIF 1277 1218 IF(southern_side) THEN 1278 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 1279 & * umask(i1:i2,j1,1) 1219 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 1280 1220 ENDIF 1281 1221 IF(northern_side) THEN 1282 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 1283 & * umask(i1:i2,j1,1) 1222 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 1284 1223 ENDIF 1285 1224 ENDIF … … 1288 1227 END SUBROUTINE interpunb 1289 1228 1290 SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 1229 1230 SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir ) 1291 1231 !!---------------------------------------------------------------------- 1292 1232 !! *** ROUTINE interpvnb *** 1293 1233 !!---------------------------------------------------------------------- 1294 INTEGER , INTENT(in) :: i1,i2,j1,j21295 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab1296 LOGICAL , INTENT(in) ::before1297 INTEGER , INTENT(in) ::nb , ndir1298 ! !1299 INTEGER ::ji,jj1300 REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff1301 LOGICAL ::western_side, eastern_side,northern_side,southern_side1234 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1235 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1236 LOGICAL , INTENT(in ) :: before 1237 INTEGER , INTENT(in ) :: nb , ndir 1238 ! 1239 INTEGER :: ji,jj 1240 REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff 1241 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1302 1242 !!---------------------------------------------------------------------- 1303 1243 ! 1304 IF (before) THEN 1305 DO jj=j1,j2 1306 DO ji=i1,i2 1307 ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 1308 END DO 1309 END DO 1244 IF( before ) THEN 1245 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2) 1310 1246 ELSE 1311 1247 western_side = (nb == 1).AND.(ndir == 1) … … 1320 1256 IF( bdy_tinterp == 1 ) THEN 1321 1257 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 1322 &- zt0**2._wp * ( zt0 - 1._wp) )1258 & - zt0**2._wp * ( zt0 - 1._wp) ) 1323 1259 ELSEIF( bdy_tinterp == 2 ) THEN 1324 1260 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 1325 & - zt0 * ( zt0 - 1._wp)**2._wp ) 1326 1261 & - zt0 * ( zt0 - 1._wp)**2._wp ) 1327 1262 ELSE 1328 1263 ztcoeff = 1 … … 1364 1299 END SUBROUTINE interpvnb 1365 1300 1366 SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 1301 1302 SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir ) 1367 1303 !!---------------------------------------------------------------------- 1368 1304 !! *** ROUTINE interpub2b *** 1369 1305 !!---------------------------------------------------------------------- 1370 INTEGER , INTENT(in) :: i1,i2,j1,j21371 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab1372 LOGICAL , INTENT(in) ::before1373 INTEGER , INTENT(in) ::nb , ndir1374 ! !1375 INTEGER ::ji,jj1376 REAL(wp) :: zrhot, zt0, zt1,zat1377 LOGICAL ::western_side, eastern_side,northern_side,southern_side1306 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1307 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1308 LOGICAL , INTENT(in ) :: before 1309 INTEGER , INTENT(in ) :: nb , ndir 1310 ! 1311 INTEGER :: ji,jj 1312 REAL(wp) :: zrhot, zt0, zt1,zat 1313 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1378 1314 !!---------------------------------------------------------------------- 1379 1315 IF( before ) THEN 1380 DO jj=j1,j2 1381 DO ji=i1,i2 1382 ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 1383 END DO 1384 END DO 1316 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2) 1385 1317 ELSE 1386 1318 western_side = (nb == 1).AND.(ndir == 1) … … 1393 1325 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1394 1326 ! Polynomial interpolation coefficients: 1395 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) 1396 & - zt0**2._wp * (-2._wp*zt0 + 3._wp))1327 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 1328 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1397 1329 ! 1398 1330 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2) … … 1403 1335 ! 1404 1336 END SUBROUTINE interpub2b 1405 1406 SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 1337 1338 1339 SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir ) 1407 1340 !!---------------------------------------------------------------------- 1408 1341 !! *** ROUTINE interpvb2b *** 1409 1342 !!---------------------------------------------------------------------- 1410 INTEGER , INTENT(in) :: i1,i2,j1,j21411 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab1412 LOGICAL , INTENT(in) ::before1413 INTEGER , INTENT(in) ::nb , ndir1414 ! !1415 INTEGER :: ji,jj1416 REAL(wp) :: zrhot, zt0, zt1,zat1417 LOGICAL :: western_side, eastern_side,northern_side,southern_side1343 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1344 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1345 LOGICAL , INTENT(in ) :: before 1346 INTEGER , INTENT(in ) :: nb , ndir 1347 ! 1348 INTEGER :: ji,jj 1349 REAL(wp) :: zrhot, zt0, zt1,zat 1350 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1418 1351 !!---------------------------------------------------------------------- 1419 1352 ! 1420 1353 IF( before ) THEN 1421 DO jj=j1,j2 1422 DO ji=i1,i2 1423 ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 1424 END DO 1425 END DO 1354 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 1426 1355 ELSE 1427 1356 western_side = (nb == 1).AND.(ndir == 1) … … 1434 1363 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1435 1364 ! Polynomial interpolation coefficients: 1436 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) 1437 & - zt0**2._wp * (-2._wp*zt0 + 3._wp))1438 ! 1439 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)1440 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)1441 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)1442 IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)1365 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 1366 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1367 ! 1368 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2) 1369 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1370 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1) 1371 IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1443 1372 ENDIF 1444 1373 ! 1445 1374 END SUBROUTINE interpvb2b 1446 1375 1447 SUBROUTINE interpe3t(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1376 1377 SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 1448 1378 !!---------------------------------------------------------------------- 1449 1379 !! *** ROUTINE interpe3t *** 1450 1380 !!---------------------------------------------------------------------- 1451 ! 1452 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1381 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 1453 1382 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1454 LOGICAL :: before1455 INTEGER , INTENT(in) :: nb , ndir1383 LOGICAL , INTENT(in ) :: before 1384 INTEGER , INTENT(in ) :: nb , ndir 1456 1385 ! 1457 1386 INTEGER :: ji, jj, jk … … 1460 1389 !!---------------------------------------------------------------------- 1461 1390 ! 1462 IF (before) THEN 1463 DO jk=k1,k2 1464 DO jj=j1,j2 1465 DO ji=i1,i2 1466 ptab(ji,jj,jk) = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 1467 END DO 1468 END DO 1469 END DO 1391 IF( before ) THEN 1392 ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2) 1470 1393 ELSE 1471 1394 western_side = (nb == 1).AND.(ndir == 1) … … 1474 1397 northern_side = (nb == 2).AND.(ndir == 2) 1475 1398 1476 DO jk =k1,k21477 DO jj =j1,j21478 DO ji =i1,i21399 DO jk = k1, k2 1400 DO jj = j1, j2 1401 DO ji = i1, i2 1479 1402 ! Get velocity mask at boundary edge points: 1480 IF (western_side)ztmpmsk = umask(ji ,jj ,1)1481 IF (eastern_side)ztmpmsk = umask(nlci-2,jj ,1)1482 IF (northern_side)ztmpmsk = vmask(ji ,nlcj-2,1)1483 IF (southern_side)ztmpmsk = vmask(ji ,2 ,1)1484 1485 IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk))*ztmpmsk > 1.D-2) THEN1403 IF( western_side ) ztmpmsk = umask(ji ,jj ,1) 1404 IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1) 1405 IF( northern_side) ztmpmsk = vmask(ji ,nlcj-2,1) 1406 IF( southern_side) ztmpmsk = vmask(ji ,2 ,1) 1407 ! 1408 IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) )*ztmpmsk > 1.D-2) THEN 1486 1409 IF (western_side) THEN 1487 1410 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk … … 1493 1416 WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 1494 1417 ENDIF 1495 WRITE(numout,*) ' ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)1418 WRITE(numout,*) ' ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk) 1496 1419 kindic_agr = kindic_agr + 1 1497 1420 ENDIF … … 1499 1422 END DO 1500 1423 END DO 1501 1424 ! 1502 1425 ENDIF 1503 1426 ! 1504 1427 END SUBROUTINE interpe3t 1505 1428 1506 SUBROUTINE interpumsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1429 1430 SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 1507 1431 !!---------------------------------------------------------------------- 1508 1432 !! *** ROUTINE interpumsk *** 1509 1433 !!---------------------------------------------------------------------- 1510 ! 1511 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1512 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1513 LOGICAL :: before 1514 INTEGER, INTENT(in) :: nb , ndir 1515 ! 1516 INTEGER :: ji, jj, jk 1517 LOGICAL :: western_side, eastern_side 1434 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 1435 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1436 LOGICAL , INTENT(in ) :: before 1437 INTEGER , INTENT(in ) :: nb , ndir 1438 ! 1439 INTEGER :: ji, jj, jk 1440 LOGICAL :: western_side, eastern_side 1518 1441 !!---------------------------------------------------------------------- 1519 1442 ! 1520 IF (before) THEN 1521 DO jk=k1,k2 1522 DO jj=j1,j2 1523 DO ji=i1,i2 1524 ptab(ji,jj,jk) = umask(ji,jj,jk) 1525 END DO 1526 END DO 1527 END DO 1443 IF( before ) THEN 1444 ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2) 1528 1445 ELSE 1529 1530 western_side = (nb == 1).AND.(ndir == 1) 1531 eastern_side = (nb == 1).AND.(ndir == 2) 1532 DO jk=k1,k2 1533 DO jj=j1,j2 1534 DO ji=i1,i2 1446 western_side = (nb == 1).AND.(ndir == 1) 1447 eastern_side = (nb == 1).AND.(ndir == 2) 1448 DO jk = k1, k2 1449 DO jj = j1, j2 1450 DO ji = i1, i2 1535 1451 ! Velocity mask at boundary edge points: 1536 1452 IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN … … 1548 1464 END DO 1549 1465 END DO 1550 1466 ! 1551 1467 ENDIF 1552 1468 ! 1553 1469 END SUBROUTINE interpumsk 1554 1470 1555 SUBROUTINE interpvmsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1471 1472 SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 1556 1473 !!---------------------------------------------------------------------- 1557 1474 !! *** ROUTINE interpvmsk *** 1558 1475 !!---------------------------------------------------------------------- 1559 ! 1560 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1561 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1562 LOGICAL :: before 1563 INTEGER, INTENT(in) :: nb , ndir 1564 ! 1565 INTEGER :: ji, jj, jk 1566 LOGICAL :: northern_side, southern_side 1476 INTEGER , INTENT(in ) :: i1,i2,j1,j2,k1,k2 1477 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1478 LOGICAL , INTENT(in ) :: before 1479 INTEGER , INTENT(in ) :: nb , ndir 1480 ! 1481 INTEGER :: ji, jj, jk 1482 LOGICAL :: northern_side, southern_side 1567 1483 !!---------------------------------------------------------------------- 1568 1484 ! 1569 IF (before) THEN 1570 DO jk=k1,k2 1571 DO jj=j1,j2 1572 DO ji=i1,i2 1573 ptab(ji,jj,jk) = vmask(ji,jj,jk) 1574 END DO 1575 END DO 1576 END DO 1485 IF( before ) THEN 1486 ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2) 1577 1487 ELSE 1578 1579 1488 southern_side = (nb == 2).AND.(ndir == 1) 1580 1489 northern_side = (nb == 2).AND.(ndir == 2) 1581 DO jk =k1,k21582 DO jj =j1,j21583 DO ji =i1,i21490 DO jk = k1, k2 1491 DO jj = j1, j2 1492 DO ji = i1, i2 1584 1493 ! Velocity mask at boundary edge points: 1585 1494 IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN … … 1597 1506 END DO 1598 1507 END DO 1599 1508 ! 1600 1509 ENDIF 1601 1510 ! … … 1604 1513 # if defined key_zdftke 1605 1514 1606 SUBROUTINE interpavm( ptab,i1,i2,j1,j2,k1,k2,before)1515 SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before ) 1607 1516 !!---------------------------------------------------------------------- 1608 1517 !! *** ROUTINE interavm *** 1609 1518 !!---------------------------------------------------------------------- 1610 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k21611 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab1612 LOGICAL , INTENT(in) ::before1519 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 1520 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1521 LOGICAL , INTENT(in ) :: before 1613 1522 !!---------------------------------------------------------------------- 1614 1523 ! 1615 IF( before ) THEN1524 IF( before ) THEN 1616 1525 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1617 1526 ELSE
Note: See TracChangeset
for help on using the changeset viewer.
