Changeset 5682 for branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
- Timestamp:
- 2015-08-12T17:46:45+02:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r4486 r5682 7 7 !! - ! 2005-11 (XXX) 8 8 !! 3.2 ! 2009-04 (R. Benshila) 9 !! 3.6 ! 2014-09 (R. Benshila) 9 10 !!---------------------------------------------------------------------- 10 11 #if defined key_agrif && ! defined key_offline … … 29 30 USE wrk_nemo 30 31 USE dynspg_oce 31 32 USE zdf_oce 33 32 34 IMPLICIT NONE 33 35 PRIVATE 34 36 35 ! Barotropic arrays used to store open boundary data during 36 ! time-splitting loop: 37 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_w, vbdy_w, hbdy_w 38 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_e, vbdy_e, hbdy_e 39 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_n, vbdy_n, hbdy_n 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 41 37 INTEGER :: bdy_tinterp = 0 38 42 39 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 43 PUBLIC interpu, interpv, interpunb, interpvnb, interpsshn 40 PUBLIC interpun, interpvn, interpun2d, interpvn2d 41 PUBLIC interptsn, interpsshn 42 PUBLIC interpunb, interpvnb, interpub2b, interpvb2b 43 PUBLIC interpe3t, interpumsk, interpvmsk 44 # if defined key_zdftke 45 PUBLIC Agrif_tke, interpavm 46 # endif 44 47 45 48 # include "domzgr_substitute.h90" 46 49 # include "vectopt_loop_substitute.h90" 47 50 !!---------------------------------------------------------------------- 48 !! NEMO/NST 3. 3, NEMO Consortium (2010)51 !! NEMO/NST 3.6 , NEMO Consortium (2010) 49 52 !! $Id$ 50 53 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 51 54 !!---------------------------------------------------------------------- 52 55 53 54 56 CONTAINS 57 55 58 SUBROUTINE Agrif_tra 56 59 !!---------------------------------------------------------------------- 57 !! *** ROUTINE Agrif_Tra *** 58 !!---------------------------------------------------------------------- 59 !! 60 INTEGER :: ji, jj, jk, jn ! dummy loop indices 61 REAL(wp) :: zrhox , alpha1, alpha2, alpha3 62 REAL(wp) :: alpha4, alpha5, alpha6, alpha7 63 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa 60 !! *** ROUTINE Agrif_tra *** 64 61 !!---------------------------------------------------------------------- 65 62 ! 66 63 IF( Agrif_Root() ) RETURN 67 68 CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa )69 64 70 65 Agrif_SpecialValue = 0.e0 71 66 Agrif_UseSpecialValue = .TRUE. 72 ztsa(:,:,:,:) = 0.e0 73 74 CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 67 68 CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 75 69 Agrif_UseSpecialValue = .FALSE. 76 77 zrhox = Agrif_Rhox()78 79 alpha1 = ( zrhox - 1. ) * 0.580 alpha2 = 1. - alpha181 82 alpha3 = ( zrhox - 1. ) / ( zrhox + 1. )83 alpha4 = 1. - alpha384 85 alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )86 alpha7 = - ( zrhox - 1. ) / ( zrhox + 3. )87 alpha5 = 1. - alpha6 - alpha788 89 IF( nbondi == 1 .OR. nbondi == 2 ) THEN90 91 DO jn = 1, jpts92 tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn)93 DO jk = 1, jpkm194 DO jj = 1, jpj95 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN96 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)97 ELSE98 tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)99 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN100 tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn) &101 & + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk)102 ENDIF103 ENDIF104 END DO105 END DO106 ENDDO107 ENDIF108 109 IF( nbondj == 1 .OR. nbondj == 2 ) THEN110 111 DO jn = 1, jpts112 tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn)113 DO jk = 1, jpkm1114 DO ji = 1, jpi115 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN116 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)117 ELSE118 tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)119 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN120 tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn) &121 & + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)122 ENDIF123 ENDIF124 END DO125 END DO126 ENDDO127 ENDIF128 129 IF( nbondi == -1 .OR. nbondi == 2 ) THEN130 DO jn = 1, jpts131 tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn)132 DO jk = 1, jpkm1133 DO jj = 1, jpj134 IF( umask(2,jj,jk) == 0.e0 ) THEN135 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)136 ELSE137 tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)138 IF( un(2,jj,jk) < 0.e0 ) THEN139 tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk)140 ENDIF141 ENDIF142 END DO143 END DO144 END DO145 ENDIF146 147 IF( nbondj == -1 .OR. nbondj == 2 ) THEN148 DO jn = 1, jpts149 tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn)150 DO jk=1,jpk151 DO ji=1,jpi152 IF( vmask(ji,2,jk) == 0.e0 ) THEN153 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)154 ELSE155 tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk)156 IF( vn(ji,2,jk) < 0.e0 ) THEN157 tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk)158 ENDIF159 ENDIF160 END DO161 END DO162 ENDDO163 ENDIF164 !165 CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztsa )166 70 ! 167 71 END SUBROUTINE Agrif_tra … … 175 79 INTEGER, INTENT(in) :: kt 176 80 !! 177 INTEGER :: ji,jj,jk 81 INTEGER :: ji,jj,jk, j1,j2, i1,i2 178 82 REAL(wp) :: timeref 179 83 REAL(wp) :: z2dt, znugdt 180 84 REAL(wp) :: zrhox, zrhoy 181 REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva 182 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d 85 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 183 86 !!---------------------------------------------------------------------- 184 87 185 88 IF( Agrif_Root() ) RETURN 186 89 187 CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 188 CALL wrk_alloc( jpi, jpj, jpk, zua, zva ) 90 CALL wrk_alloc( jpi, jpj, spgv1, spgu1 ) 91 92 Agrif_SpecialValue=0. 93 Agrif_UseSpecialValue = ln_spc_dyn 94 95 CALL Agrif_Bc_variable(un_interp_id,procname=interpun) 96 CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 97 98 #if defined key_dynspg_flt 99 CALL Agrif_Bc_variable(e1u_id,calledweight=1., procname=interpun2d) 100 CALL Agrif_Bc_variable(e2v_id,calledweight=1., procname=interpvn2d) 101 #endif 102 103 Agrif_UseSpecialValue = .FALSE. 189 104 190 105 zrhox = Agrif_Rhox() … … 192 107 193 108 timeref = 1. 194 195 109 ! time step: leap-frog 196 110 z2dt = 2. * rdt … … 200 114 znugdt = grav * z2dt 201 115 202 Agrif_SpecialValue=0. 203 Agrif_UseSpecialValue = ln_spc_dyn 204 205 zua = 0. 206 zva = 0. 207 CALL Agrif_Bc_variable(zua,un_id,procname=interpu) 208 CALL Agrif_Bc_variable(zva,vn_id,procname=interpv) 209 zua2d = 0. 210 zva2d = 0. 211 116 ! prevent smoothing in ghost cells 117 i1=1 118 i2=jpi 119 j1=1 120 j2=jpj 121 IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 122 IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 123 IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 124 IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 125 126 127 IF((nbondi == -1).OR.(nbondi == 2)) THEN 212 128 #if defined key_dynspg_flt 213 Agrif_SpecialValue=0. 214 Agrif_UseSpecialValue = ln_spc_dyn 215 CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d) 216 CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d) 217 #endif 218 Agrif_UseSpecialValue = .FALSE. 219 220 221 IF((nbondi == -1).OR.(nbondi == 2)) THEN 222 223 #if defined key_dynspg_flt 224 DO jj=1,jpj 225 laplacu(2,jj) = timeref * (zua2d(2,jj)/(zrhoy*e2u(2,jj)))*umask(2,jj,1) 226 END DO 227 #endif 129 DO jk=1,jpkm1 130 DO jj=j1,j2 131 ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 132 END DO 133 END DO 134 135 spgu(2,:)=0. 228 136 229 137 DO jk=1,jpkm1 230 138 DO jj=1,jpj 231 ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj))) 232 ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u_a(1:2,jj,jk) 233 END DO 234 END DO 235 236 #if defined key_dynspg_flt 237 DO jk=1,jpkm1 238 DO jj=1,jpj 239 ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 240 END DO 241 END DO 242 243 spgu(2,:)=0. 244 245 DO jk=1,jpkm1 246 DO jj=1,jpj 247 spgu(2,jj)=spgu(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 139 spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 248 140 END DO 249 141 END DO … … 251 143 DO jj=1,jpj 252 144 IF (umask(2,jj,1).NE.0.) THEN 253 spgu(2,jj)=spgu(2,jj) *hur_a(2,jj)145 spgu(2,jj)=spgu(2,jj)/hu(2,jj) 254 146 ENDIF 255 147 END DO … … 259 151 260 152 DO jk=1,jpkm1 261 DO jj= 1,jpj153 DO jj=j1,j2 262 154 ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 263 155 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) … … 269 161 DO jk=1,jpkm1 270 162 DO jj=1,jpj 271 spgu1(2,jj)=spgu1(2,jj)+fse3u _a(2,jj,jk)*ua(2,jj,jk)163 spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 272 164 END DO 273 165 END DO … … 275 167 DO jj=1,jpj 276 168 IF (umask(2,jj,1).NE.0.) THEN 277 spgu1(2,jj)=spgu1(2,jj) *hur_a(2,jj)278 ENDIF 279 END DO 280 281 DO jk=1,jpkm1 282 DO jj= 1,jpj169 spgu1(2,jj)=spgu1(2,jj)/hu(2,jj) 170 ENDIF 171 END DO 172 173 DO jk=1,jpkm1 174 DO jj=j1,j2 283 175 ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 284 END DO285 END DO286 287 DO jk=1,jpkm1288 DO jj=1,jpj289 va(2,jj,jk) = (zva(2,jj,jk)/(zrhox*e1v(2,jj)))*vmask(2,jj,jk)290 va(2,jj,jk) = va(2,jj,jk) / fse3v_a(2,jj,jk)291 176 END DO 292 177 END DO … … 300 185 END DO 301 186 END DO 302 303 187 DO jj=1,jpj 304 188 spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 305 189 END DO 306 307 190 DO jk=1,jpkm1 308 191 DO jj=1,jpj … … 316 199 IF((nbondi == 1).OR.(nbondi == 2)) THEN 317 200 #if defined key_dynspg_flt 318 DO jj=1,jpj 319 laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))) 320 END DO 321 #endif 322 201 DO jk=1,jpkm1 202 DO jj=j1,j2 203 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 204 END DO 205 END DO 206 spgu(nlci-2,:)=0. 323 207 DO jk=1,jpkm1 324 208 DO jj=1,jpj 325 ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj))) 326 ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u_a(nlci-2:nlci-1,jj,jk) 327 END DO 328 END DO 329 330 #if defined key_dynspg_flt 331 DO jk=1,jpkm1 332 DO jj=1,jpj 333 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 334 END DO 335 END DO 336 337 338 spgu(nlci-2,:)=0. 339 340 do jk=1,jpkm1 341 do jj=1,jpj 342 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 343 enddo 344 enddo 345 209 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 210 ENDDO 211 ENDDO 346 212 DO jj=1,jpj 347 213 IF (umask(nlci-2,jj,1).NE.0.) THEN 348 spgu(nlci-2,jj)=spgu(nlci-2,jj) *hur_a(nlci-2,jj)214 spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj) 349 215 ENDIF 350 216 END DO … … 352 218 spgu(nlci-2,:) = ua_b(nlci-2,:) 353 219 #endif 354 220 DO jk=1,jpkm1 221 DO jj=j1,j2 222 ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 223 224 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 225 226 END DO 227 END DO 228 spgu1(nlci-2,:)=0. 355 229 DO jk=1,jpkm1 356 230 DO jj=1,jpj 357 ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 358 359 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 360 361 END DO 362 END DO 363 364 spgu1(nlci-2,:)=0. 365 366 DO jk=1,jpkm1 367 DO jj=1,jpj 368 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 369 END DO 370 END DO 371 231 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 232 END DO 233 END DO 372 234 DO jj=1,jpj 373 235 IF (umask(nlci-2,jj,1).NE.0.) THEN 374 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)*hur_a(nlci-2,jj) 375 ENDIF 376 END DO 377 378 DO jk=1,jpkm1 379 DO jj=1,jpj 236 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj) 237 ENDIF 238 END DO 239 DO jk=1,jpkm1 240 DO jj=j1,j2 380 241 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 381 END DO382 END DO383 384 DO jk=1,jpkm1385 DO jj=1,jpj-1386 va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk)387 va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v_a(nlci-1,jj,jk)388 242 END DO 389 243 END DO … … 414 268 415 269 #if defined key_dynspg_flt 416 DO ji=1,jpi417 laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2)))418 END DO419 #endif420 421 DO jk=1,jpkm1422 DO ji=1,jpi423 va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2)))424 va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v_a(ji,1:2,jk)425 END DO426 END DO427 428 #if defined key_dynspg_flt429 270 DO jk=1,jpkm1 430 271 DO ji=1,jpi … … 437 278 DO jk=1,jpkm1 438 279 DO ji=1,jpi 439 spgv(ji,2)=spgv(ji,2)+fse3v _a(ji,2,jk)*va(ji,2,jk)280 spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk) 440 281 END DO 441 282 END DO … … 443 284 DO ji=1,jpi 444 285 IF (vmask(ji,2,1).NE.0.) THEN 445 spgv(ji,2)=spgv(ji,2) *hvr_a(ji,2)286 spgv(ji,2)=spgv(ji,2)/hv(ji,2) 446 287 ENDIF 447 288 END DO … … 451 292 452 293 DO jk=1,jpkm1 453 DO ji= 1,jpi294 DO ji=i1,i2 454 295 va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 455 296 va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) … … 461 302 DO jk=1,jpkm1 462 303 DO ji=1,jpi 463 spgv1(ji,2)=spgv1(ji,2)+fse3v _a(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk)304 spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 464 305 END DO 465 306 END DO … … 467 308 DO ji=1,jpi 468 309 IF (vmask(ji,2,1).NE.0.) THEN 469 spgv1(ji,2)=spgv1(ji,2) *hvr_a(ji,2)310 spgv1(ji,2)=spgv1(ji,2)/hv(ji,2) 470 311 ENDIF 471 312 END DO … … 474 315 DO ji=1,jpi 475 316 va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 476 END DO477 END DO478 479 DO jk=1,jpkm1480 DO ji=1,jpi481 ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoy*e2u(ji,2)))*umask(ji,2,jk)482 ua(ji,2,jk) = ua(ji,2,jk) / fse3u_a(ji,2,jk)483 317 END DO 484 318 END DO … … 508 342 509 343 #if defined key_dynspg_flt 510 DO ji=1,jpi511 laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)))512 END DO513 #endif514 515 DO jk=1,jpkm1516 DO ji=1,jpi517 va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1)))518 va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v_a(ji,nlcj-2:nlcj-1,jk)519 END DO520 END DO521 522 #if defined key_dynspg_flt523 344 DO jk=1,jpkm1 524 345 DO ji=1,jpi … … 527 348 END DO 528 349 350 529 351 spgv(:,nlcj-2)=0. 530 352 531 353 DO jk=1,jpkm1 532 354 DO ji=1,jpi 533 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v _a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)355 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 534 356 END DO 535 357 END DO … … 537 359 DO ji=1,jpi 538 360 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 539 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)*hvr_a(ji,nlcj-2) 540 ENDIF 541 END DO 361 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2) 362 ENDIF 363 END DO 364 542 365 #else 543 366 spgv(:,nlcj-2)=va_b(:,nlcj-2) … … 545 368 546 369 DO jk=1,jpkm1 547 DO ji= 1,jpi370 DO ji=i1,i2 548 371 va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 549 372 va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) … … 555 378 DO jk=1,jpkm1 556 379 DO ji=1,jpi 557 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v _a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk)380 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 558 381 END DO 559 382 END DO … … 561 384 DO ji=1,jpi 562 385 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 563 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2) *hvr_a(ji,nlcj-2)386 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2) 564 387 ENDIF 565 388 END DO … … 568 391 DO ji=1,jpi 569 392 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 570 END DO571 END DO572 573 DO jk=1,jpkm1574 DO ji=1,jpi575 ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk)576 ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u_a(ji,nlcj-1,jk)577 393 END DO 578 394 END DO … … 600 416 ENDIF 601 417 ! 602 CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 603 CALL wrk_dealloc( jpi, jpj, jpk, zua, zva ) 418 CALL wrk_dealloc( jpi, jpj, spgv1, spgu1 ) 604 419 ! 605 420 END SUBROUTINE Agrif_dyn … … 620 435 DO jj=1,jpj 621 436 va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 622 ! Specified fluxes:437 ! Specified fluxes: 623 438 ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 624 ! Characteristics method:625 !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &626 !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )439 ! Characteristics method: 440 !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 441 !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 627 442 END DO 628 443 ENDIF … … 631 446 DO jj=1,jpj 632 447 va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 633 ! Specified fluxes:448 ! Specified fluxes: 634 449 ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 635 ! Characteristics method:636 !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &637 !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )450 ! Characteristics method: 451 !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 452 !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 638 453 END DO 639 454 ENDIF … … 642 457 DO ji=1,jpi 643 458 ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 644 ! Specified fluxes:459 ! Specified fluxes: 645 460 va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 646 ! Characteristics method:647 !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &648 !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )461 ! Characteristics method: 462 !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 463 !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 649 464 END DO 650 465 ENDIF … … 653 468 DO ji=1,jpi 654 469 ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 655 ! Specified fluxes:470 ! Specified fluxes: 656 471 va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 657 ! Characteristics method:658 !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) &659 !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )472 ! Characteristics method: 473 !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) & 474 !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 660 475 END DO 661 476 ENDIF … … 672 487 INTEGER :: ji, jj 673 488 LOGICAL :: ll_int_cons 674 REAL(wp) :: zrhox, zrhoy, zrhot, zt 675 REAL(wp) :: zaa, zab, zat 676 REAL(wp) :: zt0, zt1 677 REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn 678 REAL(wp), POINTER, DIMENSION(:,:) :: zuab, zvab, zubb, zvbb, zutn, zvtn 489 REAL(wp) :: zrhot, zt 679 490 !!---------------------------------------------------------------------- 680 491 … … 682 493 683 494 ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 684 ! the forward case only 685 686 zrhox = Agrif_Rhox() 687 zrhoy = Agrif_Rhoy() 495 ! the forward case only 496 688 497 zrhot = Agrif_rhot() 689 690 IF ( kt==nit000 ) THEN ! Allocate boundary data arrays691 ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj))692 ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj))693 ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi))694 ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi))695 ENDIF696 697 CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn )698 498 699 499 ! "Central" time index for interpolation: … … 707 507 Agrif_SpecialValue = 0.e0 708 508 Agrif_UseSpecialValue = .TRUE. 709 CALL Agrif_Bc_variable( zsshn,sshn_id,calledweight=zt, procname=interpsshn )509 CALL Agrif_Bc_variable(sshn_id,calledweight=zt, procname=interpsshn ) 710 510 Agrif_UseSpecialValue = .FALSE. 711 511 … … 715 515 716 516 IF (ll_int_cons) THEN ! Conservative interpolation 717 CALL wrk_alloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 718 zuab(:,:) = 0._wp ; zvab(:,:) = 0._wp 719 zubb(:,:) = 0._wp ; zvbb(:,:) = 0._wp 720 zutn(:,:) = 0._wp ; zvtn(:,:) = 0._wp 721 CALL Agrif_Bc_variable(zubb,unb_id ,calledweight=0._wp, procname=interpunb) ! Before 722 CALL Agrif_Bc_variable(zvbb,vnb_id ,calledweight=0._wp, procname=interpvnb) 723 CALL Agrif_Bc_variable(zuab,unb_id ,calledweight=1._wp, procname=interpunb) ! After 724 CALL Agrif_Bc_variable(zvab,vnb_id ,calledweight=1._wp, procname=interpvnb) 725 CALL Agrif_Bc_variable(zutn,ub2b_id,calledweight=1._wp, procname=interpub2b)! Time integrated 726 CALL Agrif_Bc_variable(zvtn,vb2b_id,calledweight=1._wp, procname=interpvb2b) 727 517 ! orders matters here !!!!!! 518 CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated 519 CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1._wp, procname=interpvb2b) 520 bdy_tinterp = 1 521 CALL Agrif_Bc_variable(unb_id ,calledweight=1._wp, procname=interpunb) ! After 522 CALL Agrif_Bc_variable(vnb_id ,calledweight=1._wp, procname=interpvnb) 523 bdy_tinterp = 2 524 CALL Agrif_Bc_variable(unb_id ,calledweight=0._wp, procname=interpunb) ! Before 525 CALL Agrif_Bc_variable(vnb_id ,calledweight=0._wp, procname=interpvnb) 526 ELSE ! Linear interpolation 527 bdy_tinterp = 0 528 ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0 529 ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0 530 ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0 531 ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0 532 CALL Agrif_Bc_variable(unb_id,calledweight=zt, procname=interpunb) 533 CALL Agrif_Bc_variable(vnb_id,calledweight=zt, procname=interpvnb) 534 ENDIF 535 Agrif_UseSpecialValue = .FALSE. 536 ! 537 END SUBROUTINE Agrif_dta_ts 538 539 SUBROUTINE Agrif_ssh( kt ) 540 !!---------------------------------------------------------------------- 541 !! *** ROUTINE Agrif_DYN *** 542 !!---------------------------------------------------------------------- 543 INTEGER, INTENT(in) :: kt 544 !! 545 !!---------------------------------------------------------------------- 546 547 IF( Agrif_Root() ) RETURN 548 549 IF((nbondi == -1).OR.(nbondi == 2)) THEN 550 ssha(2,:)=ssha(3,:) 551 sshn(2,:)=sshn(3,:) 552 ENDIF 553 554 IF((nbondi == 1).OR.(nbondi == 2)) THEN 555 ssha(nlci-1,:)=ssha(nlci-2,:) 556 sshn(nlci-1,:)=sshn(nlci-2,:) 557 ENDIF 558 559 IF((nbondj == -1).OR.(nbondj == 2)) THEN 560 ssha(:,2)=ssha(:,3) 561 sshn(:,2)=sshn(:,3) 562 ENDIF 563 564 IF((nbondj == 1).OR.(nbondj == 2)) THEN 565 ssha(:,nlcj-1)=ssha(:,nlcj-2) 566 sshn(:,nlcj-1)=sshn(:,nlcj-2) 567 ENDIF 568 569 END SUBROUTINE Agrif_ssh 570 571 SUBROUTINE Agrif_ssh_ts( jn ) 572 !!---------------------------------------------------------------------- 573 !! *** ROUTINE Agrif_ssh_ts *** 574 !!---------------------------------------------------------------------- 575 INTEGER, INTENT(in) :: jn 576 !! 577 INTEGER :: ji,jj 578 !!---------------------------------------------------------------------- 579 580 IF((nbondi == -1).OR.(nbondi == 2)) THEN 581 DO jj=1,jpj 582 ssha_e(2,jj) = hbdy_w(jj) 583 END DO 584 ENDIF 585 586 IF((nbondi == 1).OR.(nbondi == 2)) THEN 587 DO jj=1,jpj 588 ssha_e(nlci-1,jj) = hbdy_e(jj) 589 END DO 590 ENDIF 591 592 IF((nbondj == -1).OR.(nbondj == 2)) THEN 593 DO ji=1,jpi 594 ssha_e(ji,2) = hbdy_s(ji) 595 END DO 596 ENDIF 597 598 IF((nbondj == 1).OR.(nbondj == 2)) THEN 599 DO ji=1,jpi 600 ssha_e(ji,nlcj-1) = hbdy_n(ji) 601 END DO 602 ENDIF 603 604 END SUBROUTINE Agrif_ssh_ts 605 606 # if defined key_zdftke 607 SUBROUTINE Agrif_tke 608 !!---------------------------------------------------------------------- 609 !! *** ROUTINE Agrif_tke *** 610 !!---------------------------------------------------------------------- 611 REAL(wp) :: zalpha 612 ! 613 zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 614 IF( zalpha > 1. ) zalpha = 1. 615 616 Agrif_SpecialValue = 0.e0 617 Agrif_UseSpecialValue = .TRUE. 618 619 CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm) 620 621 Agrif_UseSpecialValue = .FALSE. 622 ! 623 END SUBROUTINE Agrif_tke 624 # endif 625 626 SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 627 !!--------------------------------------------- 628 !! *** ROUTINE interptsn *** 629 !!--------------------------------------------- 630 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 631 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 632 LOGICAL, INTENT(in) :: before 633 INTEGER, INTENT(in) :: nb , ndir 634 ! 635 INTEGER :: ji, jj, jk, jn ! dummy loop indices 636 INTEGER :: imin, imax, jmin, jmax 637 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 638 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 639 LOGICAL :: western_side, eastern_side,northern_side,southern_side 640 641 IF (before) THEN 642 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 643 ELSE 644 ! 645 western_side = (nb == 1).AND.(ndir == 1) 646 eastern_side = (nb == 1).AND.(ndir == 2) 647 southern_side = (nb == 2).AND.(ndir == 1) 648 northern_side = (nb == 2).AND.(ndir == 2) 649 ! 650 zrhox = Agrif_Rhox() 651 ! 652 zalpha1 = ( zrhox - 1. ) * 0.5 653 zalpha2 = 1. - zalpha1 654 ! 655 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 656 zalpha4 = 1. - zalpha3 657 ! 658 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 659 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 660 zalpha5 = 1. - zalpha6 - zalpha7 661 ! 662 imin = i1 663 imax = i2 664 jmin = j1 665 jmax = j2 666 ! 667 ! Remove CORNERS 668 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 669 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 670 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 671 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 672 ! 673 IF( eastern_side) THEN 674 DO jn = 1, jpts 675 tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 676 DO jk = 1, jpkm1 677 DO jj = jmin,jmax 678 IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 679 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 680 ELSE 681 tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 682 IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 683 tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 684 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 685 ENDIF 686 ENDIF 687 END DO 688 END DO 689 ENDDO 690 ENDIF 691 ! 692 IF( northern_side ) THEN 693 DO jn = 1, jpts 694 tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 695 DO jk = 1, jpkm1 696 DO ji = imin,imax 697 IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 698 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 699 ELSE 700 tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 701 IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 702 tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn) & 703 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 704 ENDIF 705 ENDIF 706 END DO 707 END DO 708 ENDDO 709 ENDIF 710 ! 711 IF( western_side) THEN 712 DO jn = 1, jpts 713 tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 714 DO jk = 1, jpkm1 715 DO jj = jmin,jmax 716 IF( umask(2,jj,jk) == 0.e0 ) THEN 717 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 718 ELSE 719 tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 720 IF( un(2,jj,jk) < 0.e0 ) THEN 721 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) 722 ENDIF 723 ENDIF 724 END DO 725 END DO 726 END DO 727 ENDIF 728 ! 729 IF( southern_side ) THEN 730 DO jn = 1, jpts 731 tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 732 DO jk=1,jpk 733 DO ji=imin,imax 734 IF( vmask(ji,2,jk) == 0.e0 ) THEN 735 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 736 ELSE 737 tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 738 IF( vn(ji,2,jk) < 0.e0 ) THEN 739 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) 740 ENDIF 741 ENDIF 742 END DO 743 END DO 744 ENDDO 745 ENDIF 746 ! 747 ! Treatment of corners 748 ! 749 ! East south 750 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 751 tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 752 ENDIF 753 ! East north 754 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 755 tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 756 ENDIF 757 ! West south 758 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 759 tsa(2,2,:,:) = ptab(2,2,:,:) 760 ENDIF 761 ! West north 762 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 763 tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 764 ENDIF 765 ! 766 ENDIF 767 ! 768 END SUBROUTINE interptsn 769 770 SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 771 !!---------------------------------------------------------------------- 772 !! *** ROUTINE interpsshn *** 773 !!---------------------------------------------------------------------- 774 INTEGER, INTENT(in) :: i1,i2,j1,j2 775 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 776 LOGICAL, INTENT(in) :: before 777 INTEGER, INTENT(in) :: nb , ndir 778 LOGICAL :: western_side, eastern_side,northern_side,southern_side 779 !!---------------------------------------------------------------------- 780 ! 781 IF( before) THEN 782 ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 783 ELSE 784 western_side = (nb == 1).AND.(ndir == 1) 785 eastern_side = (nb == 1).AND.(ndir == 2) 786 southern_side = (nb == 2).AND.(ndir == 1) 787 northern_side = (nb == 2).AND.(ndir == 2) 788 IF(western_side) hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 789 IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 790 IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 791 IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 792 ENDIF 793 ! 794 END SUBROUTINE interpsshn 795 796 SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2, before) 797 !!--------------------------------------------- 798 !! *** ROUTINE interpun *** 799 !!--------------------------------------------- 800 !! 801 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 802 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 803 LOGICAL, INTENT(in) :: before 804 !! 805 INTEGER :: ji,jj,jk 806 REAL(wp) :: zrhoy 807 !!--------------------------------------------- 808 ! 809 IF (before) THEN 810 DO jk=1,jpk 811 DO jj=j1,j2 812 DO ji=i1,i2 813 ptab(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 814 ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3u(ji,jj,jk) 815 END DO 816 END DO 817 END DO 818 ELSE 819 zrhoy = Agrif_Rhoy() 820 DO jk=1,jpkm1 821 DO jj=j1,j2 822 ua(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) 823 ua(i1:i2,jj,jk) = ua(i1:i2,jj,jk) / fse3u(i1:i2,jj,jk) 824 END DO 825 END DO 826 ENDIF 827 ! 828 END SUBROUTINE interpun 829 830 831 SUBROUTINE interpun2d(ptab,i1,i2,j1,j2,before) 832 !!--------------------------------------------- 833 !! *** ROUTINE interpun *** 834 !!--------------------------------------------- 835 ! 836 INTEGER, INTENT(in) :: i1,i2,j1,j2 837 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 838 LOGICAL, INTENT(in) :: before 839 ! 840 INTEGER :: ji,jj 841 REAL(wp) :: ztref 842 REAL(wp) :: zrhoy 843 !!--------------------------------------------- 844 ! 845 ztref = 1. 846 847 IF (before) THEN 848 DO jj=j1,j2 849 DO ji=i1,MIN(i2,nlci-1) 850 ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) 851 END DO 852 END DO 853 ELSE 854 zrhoy = Agrif_Rhoy() 855 DO jj=j1,j2 856 laplacu(i1:i2,jj) = ztref * (ptab(i1:i2,jj)/(zrhoy*e2u(i1:i2,jj))) !*umask(i1:i2,jj,1) 857 END DO 858 ENDIF 859 ! 860 END SUBROUTINE interpun2d 861 862 863 SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 864 !!--------------------------------------------- 865 !! *** ROUTINE interpvn *** 866 !!--------------------------------------------- 867 ! 868 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 869 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 870 LOGICAL, INTENT(in) :: before 871 ! 872 INTEGER :: ji,jj,jk 873 REAL(wp) :: zrhox 874 !!--------------------------------------------- 875 ! 876 IF (before) THEN 877 !interpv entre 1 et k2 et interpv2d en jpkp1 878 DO jk=k1,jpk 879 DO jj=j1,j2 880 DO ji=i1,i2 881 ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 882 ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 883 END DO 884 END DO 885 END DO 886 ELSE 887 zrhox= Agrif_Rhox() 888 DO jk=1,jpkm1 889 DO jj=j1,j2 890 va(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj))) 891 va(i1:i2,jj,jk) = va(i1:i2,jj,jk) / fse3v(i1:i2,jj,jk) 892 END DO 893 END DO 894 ENDIF 895 ! 896 END SUBROUTINE interpvn 897 898 SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 899 !!--------------------------------------------- 900 !! *** ROUTINE interpvn *** 901 !!--------------------------------------------- 902 ! 903 INTEGER, INTENT(in) :: i1,i2,j1,j2 904 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 905 LOGICAL, INTENT(in) :: before 906 ! 907 INTEGER :: ji,jj 908 REAL(wp) :: zrhox 909 REAL(wp) :: ztref 910 !!--------------------------------------------- 911 ! 912 ztref = 1. 913 IF (before) THEN 914 !interpv entre 1 et k2 et interpv2d en jpkp1 915 DO jj=j1,MIN(j2,nlcj-1) 916 DO ji=i1,i2 917 ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 918 END DO 919 END DO 920 ELSE 921 zrhox = Agrif_Rhox() 922 DO ji=i1,i2 923 laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 924 END DO 925 ENDIF 926 ! 927 END SUBROUTINE interpvn2d 928 929 SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 930 !!---------------------------------------------------------------------- 931 !! *** ROUTINE interpunb *** 932 !!---------------------------------------------------------------------- 933 INTEGER, INTENT(in) :: i1,i2,j1,j2 934 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 935 LOGICAL, INTENT(in) :: before 936 INTEGER, INTENT(in) :: nb , ndir 937 !! 938 INTEGER :: ji,jj 939 REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 940 LOGICAL :: western_side, eastern_side,northern_side,southern_side 941 !!---------------------------------------------------------------------- 942 ! 943 IF (before) THEN 944 DO jj=j1,j2 945 DO ji=i1,i2 946 ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj) 947 END DO 948 END DO 949 ELSE 950 western_side = (nb == 1).AND.(ndir == 1) 951 eastern_side = (nb == 1).AND.(ndir == 2) 952 southern_side = (nb == 2).AND.(ndir == 1) 953 northern_side = (nb == 2).AND.(ndir == 2) 954 zrhoy = Agrif_Rhoy() 955 zrhot = Agrif_rhot() 956 ! Time indexes bounds for integration 957 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 958 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 959 ! Polynomial interpolation coefficients: 960 IF( bdy_tinterp == 1 ) THEN 961 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 962 & - zt0**2._wp * ( zt0 - 1._wp) ) 963 ELSEIF( bdy_tinterp == 2 ) THEN 964 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 965 & - zt0 * ( zt0 - 1._wp)**2._wp ) 966 967 ELSE 968 ztcoeff = 1 969 ENDIF 970 ! 971 IF(western_side) THEN 972 ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 973 ENDIF 974 IF(eastern_side) THEN 975 ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 976 ENDIF 977 IF(southern_side) THEN 978 ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 979 ENDIF 980 IF(northern_side) THEN 981 ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 982 ENDIF 983 ! 984 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 985 IF(western_side) THEN 986 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 987 & * umask(i1,j1:j2,1) 988 ENDIF 989 IF(eastern_side) THEN 990 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 991 & * umask(i1,j1:j2,1) 992 ENDIF 993 IF(southern_side) THEN 994 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 995 & * umask(i1:i2,j1,1) 996 ENDIF 997 IF(northern_side) THEN 998 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 999 & * umask(i1:i2,j1,1) 1000 ENDIF 1001 ENDIF 1002 ENDIF 1003 ! 1004 END SUBROUTINE interpunb 1005 1006 SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 1007 !!---------------------------------------------------------------------- 1008 !! *** ROUTINE interpvnb *** 1009 !!---------------------------------------------------------------------- 1010 INTEGER, INTENT(in) :: i1,i2,j1,j2 1011 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1012 LOGICAL, INTENT(in) :: before 1013 INTEGER, INTENT(in) :: nb , ndir 1014 !! 1015 INTEGER :: ji,jj 1016 REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff 1017 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1018 !!---------------------------------------------------------------------- 1019 ! 1020 IF (before) THEN 1021 DO jj=j1,j2 1022 DO ji=i1,i2 1023 ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 1024 END DO 1025 END DO 1026 ELSE 1027 western_side = (nb == 1).AND.(ndir == 1) 1028 eastern_side = (nb == 1).AND.(ndir == 2) 1029 southern_side = (nb == 2).AND.(ndir == 1) 1030 northern_side = (nb == 2).AND.(ndir == 2) 1031 zrhox = Agrif_Rhox() 1032 zrhot = Agrif_rhot() 1033 ! Time indexes bounds for integration 1034 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 1035 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1036 IF( bdy_tinterp == 1 ) THEN 1037 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 1038 & - zt0**2._wp * ( zt0 - 1._wp) ) 1039 ELSEIF( bdy_tinterp == 2 ) THEN 1040 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 1041 & - zt0 * ( zt0 - 1._wp)**2._wp ) 1042 1043 ELSE 1044 ztcoeff = 1 1045 ENDIF 1046 ! 1047 IF(western_side) THEN 1048 vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 1049 ENDIF 1050 IF(eastern_side) THEN 1051 vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 1052 ENDIF 1053 IF(southern_side) THEN 1054 vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 1055 ENDIF 1056 IF(northern_side) THEN 1057 vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 1058 ENDIF 1059 ! 1060 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 1061 IF(western_side) THEN 1062 vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 1063 & * vmask(i1,j1:j2,1) 1064 ENDIF 1065 IF(eastern_side) THEN 1066 vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 1067 & * vmask(i1,j1:j2,1) 1068 ENDIF 1069 IF(southern_side) THEN 1070 vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 1071 & * vmask(i1:i2,j1,1) 1072 ENDIF 1073 IF(northern_side) THEN 1074 vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 1075 & * vmask(i1:i2,j1,1) 1076 ENDIF 1077 ENDIF 1078 ENDIF 1079 ! 1080 END SUBROUTINE interpvnb 1081 1082 SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 1083 !!---------------------------------------------------------------------- 1084 !! *** ROUTINE interpub2b *** 1085 !!---------------------------------------------------------------------- 1086 INTEGER, INTENT(in) :: i1,i2,j1,j2 1087 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1088 LOGICAL, INTENT(in) :: before 1089 INTEGER, INTENT(in) :: nb , ndir 1090 !! 1091 INTEGER :: ji,jj 1092 REAL(wp) :: zrhot, zt0, zt1,zat 1093 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1094 !!---------------------------------------------------------------------- 1095 IF( before ) THEN 1096 DO jj=j1,j2 1097 DO ji=i1,i2 1098 ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 1099 END DO 1100 END DO 1101 ELSE 1102 western_side = (nb == 1).AND.(ndir == 1) 1103 eastern_side = (nb == 1).AND.(ndir == 2) 1104 southern_side = (nb == 2).AND.(ndir == 1) 1105 northern_side = (nb == 2).AND.(ndir == 2) 1106 zrhot = Agrif_rhot() 728 1107 ! Time indexes bounds for integration 729 1108 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 730 1109 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 731 732 1110 ! Polynomial interpolation coefficients: 733 zaa = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) &734 & - zt0**2._wp * ( zt0 - 1._wp) )735 zab = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp &736 & - zt0 * ( zt0 - 1._wp)**2._wp )737 1111 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 738 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 739 740 ! Do time interpolation 741 IF((nbondi == -1).OR.(nbondi == 2)) THEN 742 DO jj=1,jpj 743 zunb(2,jj) = zaa * zuab(2,jj) + zab * zubb(2,jj) + zat * zutn(2,jj) 744 zvnb(2,jj) = zaa * zvab(2,jj) + zab * zvbb(2,jj) + zat * zvtn(2,jj) 745 END DO 746 ENDIF 747 IF((nbondi == 1).OR.(nbondi == 2)) THEN 748 DO jj=1,jpj 749 zunb(nlci-2,jj) = zaa * zuab(nlci-2,jj) + zab * zubb(nlci-2,jj) + zat * zutn(nlci-2,jj) 750 zvnb(nlci-1,jj) = zaa * zvab(nlci-1,jj) + zab * zvbb(nlci-1,jj) + zat * zvtn(nlci-1,jj) 751 END DO 752 ENDIF 753 IF((nbondj == -1).OR.(nbondj == 2)) THEN 754 DO ji=1,jpi 755 zunb(ji,2) = zaa * zuab(ji,2) + zab * zubb(ji,2) + zat * zutn(ji,2) 756 zvnb(ji,2) = zaa * zvab(ji,2) + zab * zvbb(ji,2) + zat * zvtn(ji,2) 757 END DO 758 ENDIF 759 IF((nbondj == 1).OR.(nbondj == 2)) THEN 760 DO ji=1,jpi 761 zunb(ji,nlcj-1) = zaa * zuab(ji,nlcj-1) + zab * zubb(ji,nlcj-1) + zat * zutn(ji,nlcj-1) 762 zvnb(ji,nlcj-2) = zaa * zvab(ji,nlcj-2) + zab * zvbb(ji,nlcj-2) + zat * zvtn(ji,nlcj-2) 763 END DO 764 ENDIF 765 CALL wrk_dealloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 766 767 ELSE ! Linear interpolation 768 zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp 769 CALL Agrif_Bc_variable(zunb,unb_id,calledweight=zt, procname=interpunb) 770 CALL Agrif_Bc_variable(zvnb,vnb_id,calledweight=zt, procname=interpvnb) 771 ENDIF 772 Agrif_UseSpecialValue = .FALSE. 773 774 ! Fill boundary data arrays: 775 IF((nbondi == -1).OR.(nbondi == 2)) THEN 776 DO jj=1,jpj 777 ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj))) * umask(2,jj,1) 778 vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj))) * vmask(2,jj,1) 779 hbdy_w(jj) = zsshn(2,jj) * tmask(2,jj,1) 780 END DO 781 ENDIF 782 783 IF((nbondi == 1).OR.(nbondi == 2)) THEN 784 DO jj=1,jpj 785 ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj)) * umask(nlci-2,jj,1) 786 vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj)) * vmask(nlci-1,jj,1) 787 hbdy_e(jj) = zsshn(nlci-1,jj) * tmask(nlci-1,jj,1) 788 END DO 789 ENDIF 790 791 IF((nbondj == -1).OR.(nbondj == 2)) THEN 792 DO ji=1,jpi 793 ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2)) * umask(ji,2,1) 794 vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2)) * vmask(ji,2,1) 795 hbdy_s(ji) = zsshn(ji,2) * tmask(ji,2,1) 796 END DO 797 ENDIF 798 799 IF((nbondj == 1).OR.(nbondj == 2)) THEN 800 DO ji=1,jpi 801 ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1)) * umask(ji,nlcj-1,1) 802 vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)) * vmask(ji,nlcj-2,1) 803 hbdy_n(ji) = zsshn(ji,nlcj-1) * tmask(ji,nlcj-1,1) 804 END DO 805 ENDIF 806 807 CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn ) 808 809 END SUBROUTINE Agrif_dta_ts 810 811 SUBROUTINE Agrif_ssh( kt ) 812 !!---------------------------------------------------------------------- 813 !! *** ROUTINE Agrif_DYN *** 814 !!---------------------------------------------------------------------- 815 INTEGER, INTENT(in) :: kt 816 !! 817 !!---------------------------------------------------------------------- 818 819 IF( Agrif_Root() ) RETURN 820 821 822 IF((nbondi == -1).OR.(nbondi == 2)) THEN 823 ssha(2,:)=ssha(3,:) 824 sshn(2,:)=sshn(3,:) 825 ENDIF 826 827 IF((nbondi == 1).OR.(nbondi == 2)) THEN 828 ssha(nlci-1,:)=ssha(nlci-2,:) 829 sshn(nlci-1,:)=sshn(nlci-2,:) 830 ENDIF 831 832 IF((nbondj == -1).OR.(nbondj == 2)) THEN 833 ssha(:,2)=ssha(:,3) 834 sshn(:,2)=sshn(:,3) 835 ENDIF 836 837 IF((nbondj == 1).OR.(nbondj == 2)) THEN 838 ssha(:,nlcj-1)=ssha(:,nlcj-2) 839 sshn(:,nlcj-1)=sshn(:,nlcj-2) 840 ENDIF 841 842 END SUBROUTINE Agrif_ssh 843 844 SUBROUTINE Agrif_ssh_ts( jn ) 845 !!---------------------------------------------------------------------- 846 !! *** ROUTINE Agrif_ssh_ts *** 847 !!---------------------------------------------------------------------- 848 INTEGER, INTENT(in) :: jn 1112 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1113 ! 1114 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2) 1115 IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1116 IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1) 1117 IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1118 ENDIF 1119 ! 1120 END SUBROUTINE interpub2b 1121 1122 SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 1123 !!---------------------------------------------------------------------- 1124 !! *** ROUTINE interpvb2b *** 1125 !!---------------------------------------------------------------------- 1126 INTEGER, INTENT(in) :: i1,i2,j1,j2 1127 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1128 LOGICAL, INTENT(in) :: before 1129 INTEGER, INTENT(in) :: nb , ndir 849 1130 !! 850 1131 INTEGER :: ji,jj 851 !!---------------------------------------------------------------------- 852 853 IF((nbondi == -1).OR.(nbondi == 2)) THEN 854 DO jj=1,jpj 855 ssha_e(2,jj) = hbdy_w(jj) 856 END DO 857 ENDIF 858 859 IF((nbondi == 1).OR.(nbondi == 2)) THEN 860 DO jj=1,jpj 861 ssha_e(nlci-1,jj) = hbdy_e(jj) 862 END DO 863 ENDIF 864 865 IF((nbondj == -1).OR.(nbondj == 2)) THEN 866 DO ji=1,jpi 867 ssha_e(ji,2) = hbdy_s(ji) 868 END DO 869 ENDIF 870 871 IF((nbondj == 1).OR.(nbondj == 2)) THEN 872 DO ji=1,jpi 873 ssha_e(ji,nlcj-1) = hbdy_n(ji) 874 END DO 875 ENDIF 876 877 END SUBROUTINE Agrif_ssh_ts 878 879 SUBROUTINE interpsshn(tabres,i1,i2,j1,j2) 880 !!---------------------------------------------------------------------- 881 !! *** ROUTINE interpsshn *** 882 !!---------------------------------------------------------------------- 883 INTEGER, INTENT(in) :: i1,i2,j1,j2 884 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 885 !! 886 INTEGER :: ji,jj 887 !!---------------------------------------------------------------------- 888 889 tabres(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 890 891 END SUBROUTINE interpsshn 892 893 SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) 894 !!---------------------------------------------------------------------- 895 !! *** ROUTINE interpu *** 896 !!---------------------------------------------------------------------- 897 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 898 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 899 !! 900 INTEGER :: ji,jj,jk 901 !!---------------------------------------------------------------------- 902 903 DO jk=k1,k2 1132 REAL(wp) :: zrhot, zt0, zt1,zat 1133 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1134 !!---------------------------------------------------------------------- 1135 ! 1136 IF( before ) THEN 904 1137 DO jj=j1,j2 905 1138 DO ji=i1,i2 906 tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 907 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk) 908 END DO 909 END DO 910 END DO 911 END SUBROUTINE interpu 912 913 914 SUBROUTINE interpu2d(tabres,i1,i2,j1,j2) 915 !!---------------------------------------------------------------------- 916 !! *** ROUTINE interpu2d *** 917 !!---------------------------------------------------------------------- 918 INTEGER, INTENT(in) :: i1,i2,j1,j2 919 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 920 !! 921 INTEGER :: ji,jj 922 !!---------------------------------------------------------------------- 923 924 DO jj=j1,j2 925 DO ji=i1,i2 926 tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) & 927 * umask(ji,jj,1) 928 END DO 929 END DO 930 931 END SUBROUTINE interpu2d 932 933 934 SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2) 935 !!---------------------------------------------------------------------- 936 !! *** ROUTINE interpv *** 937 !!---------------------------------------------------------------------- 1139 ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 1140 END DO 1141 END DO 1142 ELSE 1143 western_side = (nb == 1).AND.(ndir == 1) 1144 eastern_side = (nb == 1).AND.(ndir == 2) 1145 southern_side = (nb == 2).AND.(ndir == 1) 1146 northern_side = (nb == 2).AND.(ndir == 2) 1147 zrhot = Agrif_rhot() 1148 ! Time indexes bounds for integration 1149 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 1150 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1151 ! Polynomial interpolation coefficients: 1152 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 1153 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1154 ! 1155 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2) 1156 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1157 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1) 1158 IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1159 ENDIF 1160 ! 1161 END SUBROUTINE interpvb2b 1162 1163 SUBROUTINE interpe3t(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1164 !!---------------------------------------------------------------------- 1165 !! *** ROUTINE interpe3t *** 1166 !!---------------------------------------------------------------------- 1167 ! 938 1168 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 939 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 940 !! 1169 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1170 LOGICAL :: before 1171 INTEGER, INTENT(in) :: nb , ndir 1172 ! 941 1173 INTEGER :: ji, jj, jk 942 !!---------------------------------------------------------------------- 943 944 DO jk=k1,k2 945 DO jj=j1,j2 946 DO ji=i1,i2 947 tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 948 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk) 949 END DO 950 END DO 951 END DO 952 953 END SUBROUTINE interpv 954 955 956 SUBROUTINE interpv2d(tabres,i1,i2,j1,j2) 957 !!---------------------------------------------------------------------- 958 !! *** ROUTINE interpu2d *** 959 !!---------------------------------------------------------------------- 960 INTEGER, INTENT(in) :: i1,i2,j1,j2 961 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 962 !! 963 INTEGER :: ji,jj 964 !!---------------------------------------------------------------------- 965 966 DO jj=j1,j2 967 DO ji=i1,i2 968 tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) & 969 * vmask(ji,jj,1) 970 END DO 971 END DO 972 973 END SUBROUTINE interpv2d 974 975 SUBROUTINE interpunb(tabres,i1,i2,j1,j2) 976 !!---------------------------------------------------------------------- 977 !! *** ROUTINE interpunb *** 978 !!---------------------------------------------------------------------- 979 INTEGER, INTENT(in) :: i1,i2,j1,j2 980 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 981 !! 982 INTEGER :: ji,jj 983 !!---------------------------------------------------------------------- 984 985 DO jj=j1,j2 986 DO ji=i1,i2 987 tabres(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj) 988 END DO 989 END DO 990 991 END SUBROUTINE interpunb 992 993 SUBROUTINE interpvnb(tabres,i1,i2,j1,j2) 994 !!---------------------------------------------------------------------- 995 !! *** ROUTINE interpvnb *** 996 !!---------------------------------------------------------------------- 997 INTEGER, INTENT(in) :: i1,i2,j1,j2 998 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 999 !! 1000 INTEGER :: ji,jj 1001 !!---------------------------------------------------------------------- 1002 1003 DO jj=j1,j2 1004 DO ji=i1,i2 1005 tabres(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 1006 END DO 1007 END DO 1008 1009 END SUBROUTINE interpvnb 1010 1011 SUBROUTINE interpub2b(tabres,i1,i2,j1,j2) 1012 !!---------------------------------------------------------------------- 1013 !! *** ROUTINE interpub2b *** 1014 !!---------------------------------------------------------------------- 1015 INTEGER, INTENT(in) :: i1,i2,j1,j2 1016 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1017 !! 1018 INTEGER :: ji,jj 1019 !!---------------------------------------------------------------------- 1020 1021 DO jj=j1,j2 1022 DO ji=i1,i2 1023 tabres(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 1024 END DO 1025 END DO 1026 1027 END SUBROUTINE interpub2b 1028 1029 SUBROUTINE interpvb2b(tabres,i1,i2,j1,j2) 1030 !!---------------------------------------------------------------------- 1031 !! *** ROUTINE interpvb2b *** 1032 !!---------------------------------------------------------------------- 1033 INTEGER, INTENT(in) :: i1,i2,j1,j2 1034 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1035 !! 1036 INTEGER :: ji,jj 1037 !!---------------------------------------------------------------------- 1038 1039 DO jj=j1,j2 1040 DO ji=i1,i2 1041 tabres(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 1042 END DO 1043 END DO 1044 1045 END SUBROUTINE interpvb2b 1174 LOGICAL :: western_side, eastern_side, northern_side, southern_side 1175 REAL(wp) :: ztmpmsk 1176 !!---------------------------------------------------------------------- 1177 ! 1178 IF (before) THEN 1179 DO jk=k1,k2 1180 DO jj=j1,j2 1181 DO ji=i1,i2 1182 ptab(ji,jj,jk) = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 1183 END DO 1184 END DO 1185 END DO 1186 ELSE 1187 western_side = (nb == 1).AND.(ndir == 1) 1188 eastern_side = (nb == 1).AND.(ndir == 2) 1189 southern_side = (nb == 2).AND.(ndir == 1) 1190 northern_side = (nb == 2).AND.(ndir == 2) 1191 1192 DO jk=k1,k2 1193 DO jj=j1,j2 1194 DO ji=i1,i2 1195 ! Get velocity mask at boundary edge points: 1196 IF (western_side) ztmpmsk = umask(ji ,jj ,1) 1197 IF (eastern_side) ztmpmsk = umask(nlci-2,jj ,1) 1198 IF (northern_side) ztmpmsk = vmask(ji ,nlcj-2,1) 1199 IF (southern_side) ztmpmsk = vmask(ji ,2 ,1) 1200 1201 IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk))*ztmpmsk > 1.D-2) THEN 1202 IF (western_side) THEN 1203 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1204 ELSEIF (eastern_side) THEN 1205 WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1206 ELSEIF (southern_side) THEN 1207 WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 1208 ELSEIF (northern_side) THEN 1209 WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 1210 ENDIF 1211 WRITE(numout,*) ' ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk) 1212 kindic_agr = kindic_agr + 1 1213 ENDIF 1214 END DO 1215 END DO 1216 END DO 1217 1218 ENDIF 1219 ! 1220 END SUBROUTINE interpe3t 1221 1222 SUBROUTINE interpumsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1223 !!---------------------------------------------------------------------- 1224 !! *** ROUTINE interpumsk *** 1225 !!---------------------------------------------------------------------- 1226 ! 1227 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1228 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1229 LOGICAL :: before 1230 INTEGER, INTENT(in) :: nb , ndir 1231 ! 1232 INTEGER :: ji, jj, jk 1233 LOGICAL :: western_side, eastern_side 1234 !!---------------------------------------------------------------------- 1235 ! 1236 IF (before) THEN 1237 DO jk=k1,k2 1238 DO jj=j1,j2 1239 DO ji=i1,i2 1240 ptab(ji,jj,jk) = umask(ji,jj,jk) 1241 END DO 1242 END DO 1243 END DO 1244 ELSE 1245 1246 western_side = (nb == 1).AND.(ndir == 1) 1247 eastern_side = (nb == 1).AND.(ndir == 2) 1248 DO jk=k1,k2 1249 DO jj=j1,j2 1250 DO ji=i1,i2 1251 ! Velocity mask at boundary edge points: 1252 IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN 1253 IF (western_side) THEN 1254 WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1255 WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 1256 kindic_agr = kindic_agr + 1 1257 ELSEIF (eastern_side) THEN 1258 WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1259 WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 1260 kindic_agr = kindic_agr + 1 1261 ENDIF 1262 ENDIF 1263 END DO 1264 END DO 1265 END DO 1266 1267 ENDIF 1268 ! 1269 END SUBROUTINE interpumsk 1270 1271 SUBROUTINE interpvmsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1272 !!---------------------------------------------------------------------- 1273 !! *** ROUTINE interpvmsk *** 1274 !!---------------------------------------------------------------------- 1275 ! 1276 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1277 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1278 LOGICAL :: before 1279 INTEGER, INTENT(in) :: nb , ndir 1280 ! 1281 INTEGER :: ji, jj, jk 1282 LOGICAL :: northern_side, southern_side 1283 !!---------------------------------------------------------------------- 1284 ! 1285 IF (before) THEN 1286 DO jk=k1,k2 1287 DO jj=j1,j2 1288 DO ji=i1,i2 1289 ptab(ji,jj,jk) = vmask(ji,jj,jk) 1290 END DO 1291 END DO 1292 END DO 1293 ELSE 1294 1295 southern_side = (nb == 2).AND.(ndir == 1) 1296 northern_side = (nb == 2).AND.(ndir == 2) 1297 DO jk=k1,k2 1298 DO jj=j1,j2 1299 DO ji=i1,i2 1300 ! Velocity mask at boundary edge points: 1301 IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN 1302 IF (southern_side) THEN 1303 WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1304 WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 1305 kindic_agr = kindic_agr + 1 1306 ELSEIF (northern_side) THEN 1307 WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 1308 WRITE(numout,*) ' masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 1309 kindic_agr = kindic_agr + 1 1310 ENDIF 1311 ENDIF 1312 END DO 1313 END DO 1314 END DO 1315 1316 ENDIF 1317 ! 1318 END SUBROUTINE interpvmsk 1319 1320 # if defined key_zdftke 1321 1322 SUBROUTINE interpavm(ptab,i1,i2,j1,j2,k1,k2,before) 1323 !!---------------------------------------------------------------------- 1324 !! *** ROUTINE interavm *** 1325 !!---------------------------------------------------------------------- 1326 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1327 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1328 LOGICAL, INTENT(in) :: before 1329 !!---------------------------------------------------------------------- 1330 ! 1331 IF( before) THEN 1332 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1333 ELSE 1334 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1335 ENDIF 1336 ! 1337 END SUBROUTINE interpavm 1338 1339 # endif /* key_zdftke */ 1046 1340 1047 1341 #else
Note: See TracChangeset
for help on using the changeset viewer.
