Changeset 6004 for branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
- Timestamp:
- 2015-12-04T17:05:58+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r5845 r6004 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 35 37 INTEGER :: bdy_tinterp = 038 39 36 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 40 PUBLIC interpun, interpvn , interpun2d, interpvn2d37 PUBLIC interpun, interpvn 41 38 PUBLIC interptsn, interpsshn 42 39 PUBLIC interpunb, interpvnb, interpub2b, interpvb2b … … 46 43 # endif 47 44 45 INTEGER :: bdy_tinterp = 0 46 48 47 # include "vectopt_loop_substitute.h90" 49 48 !!---------------------------------------------------------------------- 50 !! NEMO/NST 3. 6 , NEMO Consortium (2010)49 !! NEMO/NST 3.7 , NEMO Consortium (2015) 51 50 !! $Id$ 52 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 53 52 !!---------------------------------------------------------------------- 54 55 53 CONTAINS 56 54 … … 61 59 ! 62 60 IF( Agrif_Root() ) RETURN 63 64 Agrif_SpecialValue = 0. e061 ! 62 Agrif_SpecialValue = 0._wp 65 63 Agrif_UseSpecialValue = .TRUE. 66 64 ! 67 65 CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 66 ! 68 67 Agrif_UseSpecialValue = .FALSE. 69 68 ! … … 77 76 INTEGER, INTENT(in) :: kt 78 77 ! 79 INTEGER :: ji,jj,jk, j1,j2, i1,i2 80 REAL(wp) :: timeref 81 REAL(wp) :: z2dt, znugdt 82 REAL(wp) :: zrhox, zrhoy 83 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 84 !!---------------------------------------------------------------------- 85 78 INTEGER :: ji, jj, jk ! dummy loop indices 79 INTEGER :: j1, j2, i1, i2 80 REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb 81 !!---------------------------------------------------------------------- 82 ! 86 83 IF( Agrif_Root() ) RETURN 87 88 CALL wrk_alloc( jpi, jpj, spgv1, spgu1)89 90 Agrif_SpecialValue =0.84 ! 85 CALL wrk_alloc( jpi,jpj, zub, zvb ) 86 ! 87 Agrif_SpecialValue = 0._wp 91 88 Agrif_UseSpecialValue = ln_spc_dyn 92 93 CALL Agrif_Bc_variable(un_interp_id,procname=interpun) 94 CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 95 96 #if defined key_dynspg_flt 97 CALL Agrif_Bc_variable(e1u_id,calledweight=1., procname=interpun2d) 98 CALL Agrif_Bc_variable(e2v_id,calledweight=1., procname=interpvn2d) 99 #endif 100 89 ! 90 CALL Agrif_Bc_variable( un_interp_id, procname=interpun ) 91 CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn ) 92 ! 101 93 Agrif_UseSpecialValue = .FALSE. 102 103 zrhox = Agrif_Rhox() 104 zrhoy = Agrif_Rhoy() 105 106 timeref = 1. 107 ! time step: leap-frog 108 z2dt = 2. * rdt 109 ! time step: Euler if restart from rest 110 IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt 111 ! coefficients 112 znugdt = grav * z2dt 113 94 ! 114 95 ! prevent smoothing in ghost cells 115 i1=1 116 i2=jpi 117 j1=1 118 j2=jpj 119 IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 120 IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 121 IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 122 IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 123 124 125 IF((nbondi == -1).OR.(nbondi == 2)) THEN 126 #if defined key_dynspg_flt 127 DO jk=1,jpkm1 96 i1 = 1 ; i2 = jpi 97 j1 = 1 ; j2 = jpj 98 IF( nbondj == -1 .OR. nbondj == 2 ) j1 = 3 99 IF( nbondj == +1 .OR. nbondj == 2 ) j2 = nlcj-2 100 IF( nbondi == -1 .OR. nbondi == 2 ) i1 = 3 101 IF( nbondi == +1 .OR. nbondi == 2 ) i2 = nlci-2 102 103 IF( nbondi == -1 .OR. nbondi == 2 ) THEN 104 ! 105 ! Smoothing 106 ! --------- 107 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 108 ua_b(2,:) = 0._wp 109 DO jk = 1, jpkm1 110 DO jj = 1, jpj 111 ua_b(2,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 112 END DO 113 END DO 114 DO jj = 1, jpj 115 ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj) 116 END DO 117 ENDIF 118 ! 119 DO jk=1,jpkm1 ! Smooth 128 120 DO jj=j1,j2 129 ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 130 END DO 131 END DO 132 133 spgu(2,:)=0. 121 ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 122 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 123 END DO 124 END DO 125 ! 126 zub(2,:) = 0._wp ! Correct transport 127 DO jk = 1, jpkm1 128 DO jj = 1, jpj 129 zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 130 END DO 131 END DO 132 DO jj=1,jpj 133 zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 134 END DO 134 135 135 136 DO jk=1,jpkm1 136 137 DO jj=1,jpj 137 spgu(2,jj)=spgu(2,jj)+e3u_n(2,jj,jk)*ua(2,jj,jk) 138 END DO 139 END DO 140 141 DO jj=1,jpj 142 IF (umask(2,jj,1).NE.0.) THEN 143 spgu(2,jj)=spgu(2,jj)*r1_hu_n(2,jj) 144 ENDIF 145 END DO 146 #else 147 spgu(2,:) = ua_b(2,:) 148 #endif 149 150 DO jk=1,jpkm1 151 DO jj=j1,j2 152 ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 153 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 154 END DO 155 END DO 156 157 spgu1(2,:)=0. 158 159 DO jk=1,jpkm1 138 ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 139 END DO 140 END DO 141 142 ! Set tangential velocities to time splitting estimate 143 !----------------------------------------------------- 144 IF( ln_dynspg_ts ) THEN 145 zvb(2,:) = 0._wp 146 DO jk = 1, jpkm1 147 DO jj = 1, jpj 148 zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk) 149 END DO 150 END DO 151 DO jj = 1, jpj 152 zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj) 153 END DO 154 DO jk = 1, jpkm1 155 DO jj = 1, jpj 156 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk) 157 END DO 158 END DO 159 ENDIF 160 ! 161 ! Mask domain edges: 162 !------------------- 163 DO jk = 1, jpkm1 164 DO jj = 1, jpj 165 ua(1,jj,jk) = 0._wp 166 va(1,jj,jk) = 0._wp 167 END DO 168 END DO 169 ! 170 ENDIF 171 172 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 173 174 ! Smoothing 175 ! --------- 176 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 177 ua_b(nlci-2,:) = 0._wp 178 DO jk=1,jpkm1 179 DO jj=1,jpj 180 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 181 END DO 182 END DO 160 183 DO jj=1,jpj 161 spgu1(2,jj)=spgu1(2,jj)+e3u_n(2,jj,jk)*ua(2,jj,jk) 162 END DO 163 END DO 164 165 DO jj=1,jpj 166 IF (umask(2,jj,1).NE.0.) THEN 167 spgu1(2,jj)=spgu1(2,jj)*r1_hu_n(2,jj) 168 ENDIF 169 END DO 170 171 DO jk=1,jpkm1 172 DO jj=j1,j2 173 ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 174 END DO 175 END DO 176 177 #if defined key_dynspg_ts 184 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj) 185 END DO 186 ENDIF 187 188 DO jk = 1, jpkm1 ! Smooth 189 DO jj = j1, j2 190 ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) & 191 & * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) ) 192 END DO 193 END DO 194 195 zub(nlci-2,:) = 0._wp ! Correct transport 196 DO jk = 1, jpkm1 197 DO jj = 1, jpj 198 zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 199 END DO 200 END DO 201 DO jj = 1, jpj 202 zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj) 203 END DO 204 205 DO jk = 1, jpkm1 206 DO jj = 1, jpj 207 ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk) 208 END DO 209 END DO 210 ! 178 211 ! Set tangential velocities to time splitting estimate 179 spgv1(2,:)=0. 180 DO jk=1,jpkm1 212 !----------------------------------------------------- 213 IF( ln_dynspg_ts ) THEN 214 zvb(nlci-1,:) = 0._wp 215 DO jk = 1, jpkm1 216 DO jj = 1, jpj 217 zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 218 END DO 219 END DO 181 220 DO jj=1,jpj 182 spgv1(2,jj)=spgv1(2,jj)+e3v_a(2,jj,jk)*va(2,jj,jk) 183 END DO 184 END DO 185 DO jj=1,jpj 186 spgv1(2,jj)=spgv1(2,jj)*r1_hv_a(2,jj) 187 END DO 188 DO jk=1,jpkm1 189 DO jj=1,jpj 190 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-spgv1(2,jj))*vmask(2,jj,jk) 191 END DO 192 END DO 193 #endif 194 195 ENDIF 196 197 IF((nbondi == 1).OR.(nbondi == 2)) THEN 198 #if defined key_dynspg_flt 199 DO jk=1,jpkm1 200 DO jj=j1,j2 201 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 202 END DO 203 END DO 204 spgu(nlci-2,:)=0. 205 DO jk=1,jpkm1 206 DO jj=1,jpj 207 spgu(nlci-2,jj)=spgu(nlci-2,jj)+e3u_n(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 208 ENDDO 209 ENDDO 210 DO jj=1,jpj 211 IF (umask(nlci-2,jj,1).NE.0.) THEN 212 spgu(nlci-2,jj)=spgu(nlci-2,jj)*r1_hu_n(nlci-2,jj) 213 ENDIF 214 END DO 215 #else 216 spgu(nlci-2,:) = ua_b(nlci-2,:) 217 #endif 218 DO jk=1,jpkm1 219 DO jj=j1,j2 220 ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 221 222 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 223 224 END DO 225 END DO 226 spgu1(nlci-2,:)=0. 227 DO jk=1,jpkm1 228 DO jj=1,jpj 229 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+e3u_n(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 230 END DO 231 END DO 232 DO jj=1,jpj 233 IF (umask(nlci-2,jj,1).NE.0.) THEN 234 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)*r1_hu_n(nlci-2,jj) 235 ENDIF 236 END DO 237 DO jk=1,jpkm1 238 DO jj=j1,j2 239 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 240 END DO 241 END DO 242 243 #if defined key_dynspg_ts 244 ! Set tangential velocities to time splitting estimate 245 spgv1(nlci-1,:)=0._wp 246 DO jk=1,jpkm1 247 DO jj=1,jpj 248 spgv1(nlci-1,jj)=spgv1(nlci-1,jj)+e3v_a(nlci-1,jj,jk)*va(nlci-1,jj,jk)*vmask(nlci-1,jj,jk) 249 END DO 250 END DO 251 252 DO jj=1,jpj 253 spgv1(nlci-1,jj)=spgv1(nlci-1,jj)*r1_hv_a(nlci-1,jj) 254 END DO 255 256 DO jk=1,jpkm1 257 DO jj=1,jpj 258 va(nlci-1,jj,jk) = (va(nlci-1,jj,jk)+va_b(nlci-1,jj)-spgv1(nlci-1,jj))*vmask(nlci-1,jj,jk) 259 END DO 260 END DO 261 #endif 262 263 ENDIF 264 265 IF((nbondj == -1).OR.(nbondj == 2)) THEN 266 267 #if defined key_dynspg_flt 221 zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj) 222 END DO 223 DO jk = 1, jpkm1 224 DO jj = 1, jpj 225 va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk) 226 END DO 227 END DO 228 ENDIF 229 ! 230 ! Mask domain edges: 231 !------------------- 232 DO jk = 1, jpkm1 233 DO jj = 1, jpj 234 ua(nlci-1,jj,jk) = 0._wp 235 va(nlci ,jj,jk) = 0._wp 236 END DO 237 END DO 238 ! 239 ENDIF 240 241 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 242 243 ! Smoothing 244 ! --------- 245 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 246 va_b(:,2) = 0._wp 247 DO jk = 1, jpkm1 248 DO ji = 1, jpi 249 va_b(ji,2) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) 250 END DO 251 END DO 252 DO ji=1,jpi 253 va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2) 254 END DO 255 ENDIF 256 ! 257 DO jk = 1, jpkm1 ! Smooth 258 DO ji = i1, i2 259 va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) & 260 & * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) ) 261 END DO 262 END DO 263 ! 264 zvb(:,2) = 0._wp ! Correct transport 268 265 DO jk=1,jpkm1 269 266 DO ji=1,jpi 270 va(ji,2,jk) = (va(ji,2,jk) - z2dt * znugdt * laplacv(ji,2))*vmask(ji,2,jk) 271 END DO 272 END DO 273 274 spgv(:,2)=0. 275 276 DO jk=1,jpkm1 277 DO ji=1,jpi 278 spgv(ji,2)=spgv(ji,2)+e3v_n(ji,2,jk)*va(ji,2,jk) 279 END DO 280 END DO 281 282 DO ji=1,jpi 283 IF (vmask(ji,2,1).NE.0.) THEN 284 spgv(ji,2)=spgv(ji,2)* r1_hv_n(ji,2) 285 ENDIF 286 END DO 287 #else 288 spgv(:,2)=va_b(:,2) 289 #endif 290 291 DO jk=1,jpkm1 292 DO ji=i1,i2 293 va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 294 va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 295 END DO 296 END DO 297 298 spgv1(:,2)=0. 299 300 DO jk=1,jpkm1 301 DO ji=1,jpi 302 spgv1(ji,2)=spgv1(ji,2)+e3v_n(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 303 END DO 304 END DO 305 306 DO ji=1,jpi 307 IF (vmask(ji,2,1).NE.0.) THEN 308 spgv1(ji,2)=spgv1(ji,2)*r1_hv_n(ji,2) 309 ENDIF 310 END DO 311 312 DO jk=1,jpkm1 313 DO ji=1,jpi 314 va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 315 END DO 316 END DO 317 318 #if defined key_dynspg_ts 267 zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 268 END DO 269 END DO 270 DO ji = 1, jpi 271 zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2) 272 END DO 273 DO jk = 1, jpkm1 274 DO ji = 1, jpi 275 va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk) 276 END DO 277 END DO 278 319 279 ! Set tangential velocities to time splitting estimate 320 spgu1(:,2)=0._wp 321 DO jk=1,jpkm1 322 DO ji=1,jpi 323 spgu1(ji,2)=spgu1(ji,2)+e3u_a(ji,2,jk)*ua(ji,2,jk)*umask(ji,2,jk) 324 END DO 325 END DO 326 327 DO ji=1,jpi 328 spgu1(ji,2)=spgu1(ji,2)*r1_hu_a(ji,2) 329 END DO 330 331 DO jk=1,jpkm1 332 DO ji=1,jpi 333 ua(ji,2,jk) = (ua(ji,2,jk)+ua_b(ji,2)-spgu1(ji,2))*umask(ji,2,jk) 334 END DO 335 END DO 336 #endif 337 ENDIF 338 339 IF((nbondj == 1).OR.(nbondj == 2)) THEN 340 341 #if defined key_dynspg_flt 342 DO jk=1,jpkm1 343 DO ji=1,jpi 344 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)-z2dt * znugdt * laplacv(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 345 END DO 346 END DO 347 348 349 spgv(:,nlcj-2)=0. 350 351 DO jk=1,jpkm1 352 DO ji=1,jpi 353 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+e3v_n(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 354 END DO 355 END DO 356 357 DO ji=1,jpi 358 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 359 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)*r1_hv_n(ji,nlcj-2) 360 ENDIF 361 END DO 362 363 #else 364 spgv(:,nlcj-2)=va_b(:,nlcj-2) 365 #endif 366 367 DO jk=1,jpkm1 368 DO ji=i1,i2 369 va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 370 va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 371 END DO 372 END DO 373 374 spgv1(:,nlcj-2)=0. 375 376 DO jk=1,jpkm1 377 DO ji=1,jpi 378 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+e3v_n(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 379 END DO 380 END DO 381 382 DO ji=1,jpi 383 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 384 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)*r1_hv_n(ji,nlcj-2) 385 ENDIF 386 END DO 387 388 DO jk=1,jpkm1 389 DO ji=1,jpi 390 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 391 END DO 392 END DO 393 394 #if defined key_dynspg_ts 280 !----------------------------------------------------- 281 IF( ln_dynspg_ts ) THEN 282 zub(:,2) = 0._wp 283 DO jk = 1, jpkm1 284 DO ji = 1, jpi 285 zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 286 END DO 287 END DO 288 DO ji = 1, jpi 289 zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2) 290 END DO 291 292 DO jk = 1, jpkm1 293 DO ji = 1, jpi 294 ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk) 295 END DO 296 END DO 297 ENDIF 298 299 ! Mask domain edges: 300 !------------------- 301 DO jk = 1, jpkm1 302 DO ji = 1, jpi 303 ua(ji,1,jk) = 0._wp 304 va(ji,1,jk) = 0._wp 305 END DO 306 END DO 307 308 ENDIF 309 310 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 311 ! 312 ! Smoothing 313 ! --------- 314 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 315 va_b(:,nlcj-2) = 0._wp 316 DO jk = 1, jpkm1 317 DO ji = 1, jpi 318 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) 319 END DO 320 END DO 321 DO ji = 1, jpi 322 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 323 END DO 324 ENDIF 325 ! 326 DO jk = 1, jpkm1 ! Smooth 327 DO ji = i1, i2 328 va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) & 329 & * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) ) 330 END DO 331 END DO 332 ! 333 zvb(:,nlcj-2) = 0._wp ! Correct transport 334 DO jk = 1, jpkm1 335 DO ji = 1, jpi 336 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 337 END DO 338 END DO 339 DO ji = 1, jpi 340 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 341 END DO 342 DO jk = 1, jpkm1 343 DO ji = 1, jpi 344 va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk) 345 END DO 346 END DO 347 ! 395 348 ! Set tangential velocities to time splitting estimate 396 spgu1(:,nlcj-1)=0._wp 397 DO jk=1,jpkm1 398 DO ji=1,jpi 399 spgu1(ji,nlcj-1)=spgu1(ji,nlcj-1)+e3u_a(ji,nlcj-1,jk)*ua(ji,nlcj-1,jk) 400 END DO 401 END DO 402 403 DO ji=1,jpi 404 spgu1(ji,nlcj-1)=spgu1(ji,nlcj-1)*r1_hu_a(ji,nlcj-1) 405 END DO 406 407 DO jk=1,jpkm1 408 DO ji=1,jpi 409 ua(ji,nlcj-1,jk) = (ua(ji,nlcj-1,jk)+ua_b(ji,nlcj-1)-spgu1(ji,nlcj-1))*umask(ji,nlcj-1,jk) 410 END DO 411 END DO 412 #endif 413 414 ENDIF 415 ! 416 CALL wrk_dealloc( jpi, jpj, spgv1, spgu1 ) 349 !----------------------------------------------------- 350 IF( ln_dynspg_ts ) THEN 351 zub(:,nlcj-1) = 0._wp 352 DO jk = 1, jpkm1 353 DO ji = 1, jpi 354 zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 355 END DO 356 END DO 357 DO ji = 1, jpi 358 zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1) 359 END DO 360 ! 361 DO jk = 1, jpkm1 362 DO ji = 1, jpi 363 ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk) 364 END DO 365 END DO 366 ENDIF 367 ! 368 ! Mask domain edges: 369 !------------------- 370 DO jk = 1, jpkm1 371 DO ji = 1, jpi 372 ua(ji,nlcj ,jk) = 0._wp 373 va(ji,nlcj-1,jk) = 0._wp 374 END DO 375 END DO 376 ! 377 ENDIF 378 ! 379 CALL wrk_dealloc( jpi,jpj, zub, zvb ) 417 380 ! 418 381 END SUBROUTINE Agrif_dyn 382 419 383 420 384 SUBROUTINE Agrif_dyn_ts( jn ) … … 427 391 INTEGER :: ji, jj 428 392 !!---------------------------------------------------------------------- 429 393 ! 430 394 IF( Agrif_Root() ) RETURN 431 395 ! 432 396 IF((nbondi == -1).OR.(nbondi == 2)) THEN 433 397 DO jj=1,jpj … … 440 404 END DO 441 405 ENDIF 442 406 ! 443 407 IF((nbondi == 1).OR.(nbondi == 2)) THEN 444 408 DO jj=1,jpj … … 451 415 END DO 452 416 ENDIF 453 417 ! 454 418 IF((nbondj == -1).OR.(nbondj == 2)) THEN 455 419 DO ji=1,jpi … … 462 426 END DO 463 427 ENDIF 464 428 ! 465 429 IF((nbondj == 1).OR.(nbondj == 2)) THEN 466 430 DO ji=1,jpi … … 476 440 END SUBROUTINE Agrif_dyn_ts 477 441 442 478 443 SUBROUTINE Agrif_dta_ts( kt ) 479 444 !!---------------------------------------------------------------------- … … 487 452 REAL(wp) :: zrhot, zt 488 453 !!---------------------------------------------------------------------- 489 454 ! 490 455 IF( Agrif_Root() ) RETURN 491 492 ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 493 ! the forward case only 494 456 ! 457 ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only 458 ! 495 459 zrhot = Agrif_rhot() 496 460 ! 497 461 ! "Central" time index for interpolation: 498 IF (ln_bt_fw) THEN499 zt = REAL( Agrif_NbStepint()+0.5_wp,wp) / zrhot462 IF( ln_bt_fw ) THEN 463 zt = REAL( Agrif_NbStepint()+0.5_wp, wp ) / zrhot 500 464 ELSE 501 zt = REAL( Agrif_NbStepint(),wp) / zrhot502 ENDIF 503 465 zt = REAL( Agrif_NbStepint() , wp ) / zrhot 466 ENDIF 467 ! 504 468 ! Linear interpolation of sea level 505 Agrif_SpecialValue = 0. e0469 Agrif_SpecialValue = 0._wp 506 470 Agrif_UseSpecialValue = .TRUE. 507 CALL Agrif_Bc_variable( sshn_id,calledweight=zt, procname=interpsshn )471 CALL Agrif_Bc_variable( sshn_id, calledweight=zt, procname=interpsshn ) 508 472 Agrif_UseSpecialValue = .FALSE. 509 473 ! 510 474 ! Interpolate barotropic fluxes 511 475 Agrif_SpecialValue=0. 512 476 Agrif_UseSpecialValue = ln_spc_dyn 513 514 IF (ll_int_cons) THEN! Conservative interpolation477 ! 478 IF( ll_int_cons ) THEN ! Conservative interpolation 515 479 ! orders matters here !!!!!! 516 CALL Agrif_Bc_variable( ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated517 CALL Agrif_Bc_variable( vb2b_interp_id,calledweight=1._wp, procname=interpvb2b)480 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 481 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) 518 482 bdy_tinterp = 1 519 CALL Agrif_Bc_variable( unb_id ,calledweight=1._wp, procname=interpunb) ! After520 CALL Agrif_Bc_variable( vnb_id ,calledweight=1._wp, procname=interpvnb)483 CALL Agrif_Bc_variable( unb_id , calledweight=1._wp, procname=interpunb ) ! After 484 CALL Agrif_Bc_variable( vnb_id , calledweight=1._wp, procname=interpvnb ) 521 485 bdy_tinterp = 2 522 CALL Agrif_Bc_variable( unb_id ,calledweight=0._wp, procname=interpunb) ! Before523 CALL Agrif_Bc_variable( vnb_id ,calledweight=0._wp, procname=interpvnb)486 CALL Agrif_Bc_variable( unb_id , calledweight=0._wp, procname=interpunb ) ! Before 487 CALL Agrif_Bc_variable( vnb_id , calledweight=0._wp, procname=interpvnb ) 524 488 ELSE ! Linear interpolation 525 489 bdy_tinterp = 0 526 ubdy_w(:) = 0. e0 ; vbdy_w(:) = 0.e0527 ubdy_e(:) = 0. e0 ; vbdy_e(:) = 0.e0528 ubdy_n(:) = 0. e0 ; vbdy_n(:) = 0.e0529 ubdy_s(:) = 0. e0 ; vbdy_s(:) = 0.e0530 CALL Agrif_Bc_variable( unb_id,calledweight=zt, procname=interpunb)531 CALL Agrif_Bc_variable( vnb_id,calledweight=zt, procname=interpvnb)490 ubdy_w(:) = 0._wp ; vbdy_w(:) = 0._wp 491 ubdy_e(:) = 0._wp ; vbdy_e(:) = 0._wp 492 ubdy_n(:) = 0._wp ; vbdy_n(:) = 0._wp 493 ubdy_s(:) = 0._wp ; vbdy_s(:) = 0._wp 494 CALL Agrif_Bc_variable( unb_id, calledweight=zt, procname=interpunb ) 495 CALL Agrif_Bc_variable( vnb_id, calledweight=zt, procname=interpvnb ) 532 496 ENDIF 533 497 Agrif_UseSpecialValue = .FALSE. … … 535 499 END SUBROUTINE Agrif_dta_ts 536 500 501 537 502 SUBROUTINE Agrif_ssh( kt ) 538 503 !!---------------------------------------------------------------------- … … 542 507 !! 543 508 !!---------------------------------------------------------------------- 544 509 ! 545 510 IF( Agrif_Root() ) RETURN 546 511 ! 547 512 IF((nbondi == -1).OR.(nbondi == 2)) THEN 548 513 ssha(2,:)=ssha(3,:) 549 514 sshn(2,:)=sshn(3,:) 550 515 ENDIF 551 516 ! 552 517 IF((nbondi == 1).OR.(nbondi == 2)) THEN 553 518 ssha(nlci-1,:)=ssha(nlci-2,:) 554 519 sshn(nlci-1,:)=sshn(nlci-2,:) 555 520 ENDIF 556 521 ! 557 522 IF((nbondj == -1).OR.(nbondj == 2)) THEN 558 523 ssha(:,2)=ssha(:,3) 559 524 sshn(:,2)=sshn(:,3) 560 525 ENDIF 561 526 ! 562 527 IF((nbondj == 1).OR.(nbondj == 2)) THEN 563 528 ssha(:,nlcj-1)=ssha(:,nlcj-2) 564 529 sshn(:,nlcj-1)=sshn(:,nlcj-2) 565 530 ENDIF 566 531 ! 567 532 END SUBROUTINE Agrif_ssh 533 568 534 569 535 SUBROUTINE Agrif_ssh_ts( jn ) … … 575 541 INTEGER :: ji,jj 576 542 !!---------------------------------------------------------------------- 577 543 ! 578 544 IF((nbondi == -1).OR.(nbondi == 2)) THEN 579 DO jj =1,jpj545 DO jj = 1, jpj 580 546 ssha_e(2,jj) = hbdy_w(jj) 581 547 END DO 582 548 ENDIF 583 549 ! 584 550 IF((nbondi == 1).OR.(nbondi == 2)) THEN 585 DO jj =1,jpj551 DO jj = 1, jpj 586 552 ssha_e(nlci-1,jj) = hbdy_e(jj) 587 553 END DO 588 554 ENDIF 589 555 ! 590 556 IF((nbondj == -1).OR.(nbondj == 2)) THEN 591 DO ji =1,jpi557 DO ji = 1, jpi 592 558 ssha_e(ji,2) = hbdy_s(ji) 593 559 END DO 594 560 ENDIF 595 561 ! 596 562 IF((nbondj == 1).OR.(nbondj == 2)) THEN 597 DO ji =1,jpi563 DO ji = 1, jpi 598 564 ssha_e(ji,nlcj-1) = hbdy_n(ji) 599 565 END DO 600 566 ENDIF 601 567 ! 602 568 END SUBROUTINE Agrif_ssh_ts 603 569 604 570 # if defined key_zdftke 571 605 572 SUBROUTINE Agrif_tke 606 573 !!---------------------------------------------------------------------- … … 608 575 !!---------------------------------------------------------------------- 609 576 REAL(wp) :: zalpha 577 !!---------------------------------------------------------------------- 610 578 ! 611 579 zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 612 580 IF( zalpha > 1. ) zalpha = 1. 613 581 ! 614 582 Agrif_SpecialValue = 0.e0 615 583 Agrif_UseSpecialValue = .TRUE. 616 584 ! 617 585 CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm) 618 586 ! 619 587 Agrif_UseSpecialValue = .FALSE. 620 588 ! 621 589 END SUBROUTINE Agrif_tke 590 622 591 # endif 623 592 624 SUBROUTINE interptsn( ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir)625 !!--------------------------------------------- 593 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 594 !!---------------------------------------------------------------------- 626 595 !! *** ROUTINE interptsn *** 627 !!--------------------------------------------- 628 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab629 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2630 LOGICAL , INTENT(in) ::before631 INTEGER , INTENT(in) ::nb , ndir596 !!---------------------------------------------------------------------- 597 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 598 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 599 LOGICAL , INTENT(in ) :: before 600 INTEGER , INTENT(in ) :: nb , ndir 632 601 ! 633 602 INTEGER :: ji, jj, jk, jn ! dummy loop indices 634 INTEGER ::imin, imax, jmin, jmax603 INTEGER :: imin, imax, jmin, jmax 635 604 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 636 605 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 637 LOGICAL :: western_side, eastern_side,northern_side,southern_side 638 606 LOGICAL :: western_side, eastern_side,northern_side,southern_side 607 !!---------------------------------------------------------------------- 608 ! 639 609 IF (before) THEN 640 610 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) … … 669 639 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 670 640 ! 671 IF( eastern_side ) THEN641 IF( eastern_side ) THEN 672 642 DO jn = 1, jpts 673 643 tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 674 644 DO jk = 1, jpkm1 675 645 DO jj = jmin,jmax 676 IF( umask(nlci-2,jj,jk) == 0. e0) THEN646 IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 677 647 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 678 648 ELSE 679 649 tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 680 IF( un(nlci-2,jj,jk) > 0. e0) THEN650 IF( un(nlci-2,jj,jk) > 0._wp ) THEN 681 651 tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 682 652 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) … … 685 655 END DO 686 656 END DO 687 ENDDO 657 tsa(nlci,j1:j2,k1:k2,jn) = 0._wp 658 END DO 688 659 ENDIF 689 660 ! … … 693 664 DO jk = 1, jpkm1 694 665 DO ji = imin,imax 695 IF( vmask(ji,nlcj-2,jk) == 0. e0) THEN666 IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN 696 667 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 697 668 ELSE 698 669 tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 699 IF (vn(ji,nlcj-2,jk) > 0. e0) THEN670 IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN 700 671 tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn) & 701 672 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) … … 704 675 END DO 705 676 END DO 706 ENDDO 707 ENDIF 708 ! 709 IF( western_side) THEN 677 tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp 678 END DO 679 ENDIF 680 ! 681 IF( western_side ) THEN 710 682 DO jn = 1, jpts 711 683 tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 712 684 DO jk = 1, jpkm1 713 685 DO jj = jmin,jmax 714 IF( umask(2,jj,jk) == 0. e0) THEN686 IF( umask(2,jj,jk) == 0._wp ) THEN 715 687 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 716 688 ELSE 717 689 tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 718 IF( un(2,jj,jk) < 0. e0) THEN690 IF( un(2,jj,jk) < 0._wp ) THEN 719 691 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) 720 692 ENDIF … … 722 694 END DO 723 695 END DO 696 tsa(1,j1:j2,k1:k2,jn) = 0._wp 724 697 END DO 725 698 ENDIF … … 728 701 DO jn = 1, jpts 729 702 tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 730 DO jk =1,jpk703 DO jk = 1, jpk 731 704 DO ji=imin,imax 732 IF( vmask(ji,2,jk) == 0. e0) THEN705 IF( vmask(ji,2,jk) == 0._wp ) THEN 733 706 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 734 707 ELSE 735 708 tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 736 IF( vn(ji,2,jk) < 0. e0) THEN709 IF( vn(ji,2,jk) < 0._wp ) THEN 737 710 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) 738 711 ENDIF … … 740 713 END DO 741 714 END DO 742 ENDDO 715 tsa(i1:i2,1,k1:k2,jn) = 0._wp 716 END DO 743 717 ENDIF 744 718 ! … … 766 740 END SUBROUTINE interptsn 767 741 768 SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 742 743 SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir ) 769 744 !!---------------------------------------------------------------------- 770 745 !! *** ROUTINE interpsshn *** 771 746 !!---------------------------------------------------------------------- 772 INTEGER, INTENT(in) :: i1,i2,j1,j2 773 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 774 LOGICAL, INTENT(in) :: before 775 INTEGER, INTENT(in) :: nb , ndir 747 INTEGER , INTENT(in ) :: i1, i2, j1, j2 748 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 749 LOGICAL , INTENT(in ) :: before 750 INTEGER , INTENT(in ) :: nb , ndir 751 ! 776 752 LOGICAL :: western_side, eastern_side,northern_side,southern_side 777 753 !!---------------------------------------------------------------------- … … 792 768 END SUBROUTINE interpsshn 793 769 794 SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2, before) 795 !!--------------------------------------------- 770 771 SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, before ) 772 !!---------------------------------------------------------------------- 796 773 !! *** ROUTINE interpun *** 797 !!--------------------------------------------- 798 !! 799 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 800 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 801 LOGICAL, INTENT(in) :: before 802 !! 803 INTEGER :: ji,jj,jk 804 REAL(wp) :: zrhoy 805 !!--------------------------------------------- 806 ! 807 IF (before) THEN 808 DO jk=1,jpk 809 DO jj=j1,j2 810 DO ji=i1,i2 811 ptab(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 812 ptab(ji,jj,jk) = ptab(ji,jj,jk) * e3u_n(ji,jj,jk) 813 END DO 814 END DO 774 !!---------------------------------------------------------------------- 775 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 776 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 777 LOGICAL , INTENT(in ) :: before 778 ! 779 INTEGER :: ji, jj, jk 780 REAL(wp) :: zrhoy 781 !!---------------------------------------------------------------------- 782 ! 783 IF( before ) THEN 784 DO jk = k1, jpk 785 ptab(i1:i2,j1:j2,jk) = e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk) 815 786 END DO 816 787 ELSE 817 788 zrhoy = Agrif_Rhoy() 818 DO jk =1,jpkm1789 DO jk = 1, jpkm1 819 790 DO jj=j1,j2 820 ua(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) 821 ua(i1:i2,jj,jk) = ua(i1:i2,jj,jk) / e3u_n(i1:i2,jj,jk) 791 ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk) / ( zrhoy * e2u(i1:i2,jj) * e3u_n(i1:i2,jj,jk) ) 822 792 END DO 823 793 END DO … … 827 797 828 798 829 SUBROUTINE interpun2d(ptab,i1,i2,j1,j2,before) 830 !!--------------------------------------------- 831 !! *** ROUTINE interpun *** 832 !!--------------------------------------------- 833 ! 834 INTEGER, INTENT(in) :: i1,i2,j1,j2 835 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 836 LOGICAL, INTENT(in) :: before 837 ! 838 INTEGER :: ji,jj 839 REAL(wp) :: ztref 840 REAL(wp) :: zrhoy 841 !!--------------------------------------------- 842 ! 843 ztref = 1. 844 845 IF (before) THEN 846 DO jj=j1,j2 847 DO ji=i1,MIN(i2,nlci-1) 848 ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) 849 END DO 850 END DO 851 ELSE 852 zrhoy = Agrif_Rhoy() 853 DO jj=j1,j2 854 laplacu(i1:i2,jj) = ztref * (ptab(i1:i2,jj)/(zrhoy*e2u(i1:i2,jj))) !*umask(i1:i2,jj,1) 855 END DO 856 ENDIF 857 ! 858 END SUBROUTINE interpun2d 859 860 861 SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 862 !!--------------------------------------------- 799 SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, before ) 800 !!---------------------------------------------------------------------- 863 801 !! *** ROUTINE interpvn *** 864 !!--------------------------------------------- 865 ! 866 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 867 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 868 LOGICAL, INTENT(in) :: before 869 ! 870 INTEGER :: ji,jj,jk 871 REAL(wp) :: zrhox 872 !!--------------------------------------------- 802 !!---------------------------------------------------------------------- 803 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 804 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 805 LOGICAL , INTENT(in ) :: before 806 ! 807 INTEGER :: ji, jj, jk 808 REAL(wp) :: zrhox 809 !!---------------------------------------------------------------------- 873 810 ! 874 IF (before) THEN 875 !interpv entre 1 et k2 et interpv2d en jpkp1 876 DO jk=k1,jpk 877 DO jj=j1,j2 878 DO ji=i1,i2 879 ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 880 ptab(ji,jj,jk) = ptab(ji,jj,jk) * e3v_n(ji,jj,jk) 881 END DO 882 END DO 811 IF( before ) THEN !interpv entre 1 et k2 et interpv2d en jpkp1 812 DO jk = k1, jpk 813 ptab(i1:i2,j1:j2,jk) = e1v(i1:i2,j1:j2) * e3v_n(i1:i2,j1:j2,jk) * vn(i1:i2,j1:j2,jk) 883 814 END DO 884 815 ELSE 885 816 zrhox= Agrif_Rhox() 886 DO jk=1,jpkm1 887 DO jj=j1,j2 888 va(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj))) 889 va(i1:i2,jj,jk) = va(i1:i2,jj,jk) / e3v_n(i1:i2,jj,jk) 890 END DO 817 DO jk = 1, jpkm1 818 va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_n(i1:i2,j1:j2,jk) ) 891 819 END DO 892 820 ENDIF 893 821 ! 894 822 END SUBROUTINE interpvn 895 896 SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 897 !!--------------------------------------------- 898 !! *** ROUTINE interpvn *** 899 !!--------------------------------------------- 900 ! 901 INTEGER, INTENT(in) :: i1,i2,j1,j2 902 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 903 LOGICAL, INTENT(in) :: before 904 ! 905 INTEGER :: ji,jj 906 REAL(wp) :: zrhox 907 REAL(wp) :: ztref 908 !!--------------------------------------------- 909 ! 910 ztref = 1. 911 IF (before) THEN 912 !interpv entre 1 et k2 et interpv2d en jpkp1 913 DO jj=j1,MIN(j2,nlcj-1) 914 DO ji=i1,i2 915 ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 916 END DO 917 END DO 918 ELSE 919 zrhox = Agrif_Rhox() 920 DO ji=i1,i2 921 laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 922 END DO 923 ENDIF 924 ! 925 END SUBROUTINE interpvn2d 926 927 SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 823 824 825 SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir ) 928 826 !!---------------------------------------------------------------------- 929 827 !! *** ROUTINE interpunb *** 930 828 !!---------------------------------------------------------------------- 931 INTEGER, INTENT(in) :: i1,i2,j1,j2 932 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 933 LOGICAL, INTENT(in) :: before 934 INTEGER, INTENT(in) :: nb , ndir 935 !! 936 INTEGER :: ji,jj 937 REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 938 LOGICAL :: western_side, eastern_side,northern_side,southern_side 939 !!---------------------------------------------------------------------- 940 ! 941 IF (before) THEN 942 DO jj=j1,j2 943 DO ji=i1,i2 944 ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu_n(ji,jj) 945 END DO 946 END DO 829 INTEGER , INTENT(in ) :: i1, i2, j1, j2 830 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 831 LOGICAL , INTENT(in ) :: before 832 INTEGER , INTENT(in ) :: nb , ndir 833 ! 834 INTEGER :: ji, jj 835 REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 836 LOGICAL :: western_side, eastern_side,northern_side,southern_side 837 !!---------------------------------------------------------------------- 838 ! 839 IF( before ) THEN 840 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2) 947 841 ELSE 948 842 western_side = (nb == 1).AND.(ndir == 1) … … 958 852 IF( bdy_tinterp == 1 ) THEN 959 853 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 960 &- zt0**2._wp * ( zt0 - 1._wp) )854 & - zt0**2._wp * ( zt0 - 1._wp) ) 961 855 ELSEIF( bdy_tinterp == 2 ) THEN 962 856 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 963 &- zt0 * ( zt0 - 1._wp)**2._wp )857 & - zt0 * ( zt0 - 1._wp)**2._wp ) 964 858 965 859 ELSE … … 982 876 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 983 877 IF(western_side) THEN 984 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 985 & * umask(i1,j1:j2,1) 878 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 986 879 ENDIF 987 880 IF(eastern_side) THEN 988 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 989 & * umask(i1,j1:j2,1) 881 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 990 882 ENDIF 991 883 IF(southern_side) THEN 992 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 993 & * umask(i1:i2,j1,1) 884 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 994 885 ENDIF 995 886 IF(northern_side) THEN 996 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 997 & * umask(i1:i2,j1,1) 887 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 998 888 ENDIF 999 889 ENDIF … … 1002 892 END SUBROUTINE interpunb 1003 893 1004 SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 894 895 SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir ) 1005 896 !!---------------------------------------------------------------------- 1006 897 !! *** ROUTINE interpvnb *** 1007 898 !!---------------------------------------------------------------------- 1008 INTEGER , INTENT(in) :: i1,i2,j1,j21009 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab1010 LOGICAL , INTENT(in) ::before1011 INTEGER , INTENT(in) ::nb , ndir1012 ! !1013 INTEGER ::ji,jj1014 REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff1015 LOGICAL ::western_side, eastern_side,northern_side,southern_side899 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 ! 904 INTEGER :: ji,jj 905 REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff 906 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1016 907 !!---------------------------------------------------------------------- 1017 908 ! 1018 IF (before) THEN 1019 DO jj=j1,j2 1020 DO ji=i1,i2 1021 ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv_n(ji,jj) 1022 END DO 1023 END DO 909 IF( before ) THEN 910 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2) 1024 911 ELSE 1025 912 western_side = (nb == 1).AND.(ndir == 1) … … 1034 921 IF( bdy_tinterp == 1 ) THEN 1035 922 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 1036 &- zt0**2._wp * ( zt0 - 1._wp) )923 & - zt0**2._wp * ( zt0 - 1._wp) ) 1037 924 ELSEIF( bdy_tinterp == 2 ) THEN 1038 925 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 1039 & - zt0 * ( zt0 - 1._wp)**2._wp ) 1040 926 & - zt0 * ( zt0 - 1._wp)**2._wp ) 1041 927 ELSE 1042 928 ztcoeff = 1 … … 1078 964 END SUBROUTINE interpvnb 1079 965 1080 SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 966 967 SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir ) 1081 968 !!---------------------------------------------------------------------- 1082 969 !! *** ROUTINE interpub2b *** 1083 970 !!---------------------------------------------------------------------- 1084 INTEGER , INTENT(in) :: i1,i2,j1,j21085 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab1086 LOGICAL , INTENT(in) ::before1087 INTEGER , INTENT(in) ::nb , ndir1088 ! !1089 INTEGER ::ji,jj1090 REAL(wp) :: zrhot, zt0, zt1,zat1091 LOGICAL ::western_side, eastern_side,northern_side,southern_side971 INTEGER , INTENT(in ) :: i1, i2, j1, j2 972 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 973 LOGICAL , INTENT(in ) :: before 974 INTEGER , INTENT(in ) :: nb , ndir 975 ! 976 INTEGER :: ji,jj 977 REAL(wp) :: zrhot, zt0, zt1,zat 978 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1092 979 !!---------------------------------------------------------------------- 1093 980 IF( before ) THEN 1094 DO jj=j1,j2 1095 DO ji=i1,i2 1096 ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 1097 END DO 1098 END DO 981 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2) 1099 982 ELSE 1100 983 western_side = (nb == 1).AND.(ndir == 1) … … 1107 990 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1108 991 ! Polynomial interpolation coefficients: 1109 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) 1110 & - zt0**2._wp * (-2._wp*zt0 + 3._wp))992 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 993 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1111 994 ! 1112 995 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2) … … 1117 1000 ! 1118 1001 END SUBROUTINE interpub2b 1119 1120 SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 1002 1003 1004 SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir ) 1121 1005 !!---------------------------------------------------------------------- 1122 1006 !! *** ROUTINE interpvb2b *** 1123 1007 !!---------------------------------------------------------------------- 1124 INTEGER , INTENT(in) :: i1,i2,j1,j21125 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab1126 LOGICAL , INTENT(in) ::before1127 INTEGER , INTENT(in) ::nb , ndir1128 ! !1129 INTEGER :: ji,jj1130 REAL(wp) :: zrhot, zt0, zt1,zat1131 LOGICAL :: western_side, eastern_side,northern_side,southern_side1008 INTEGER , INTENT(in ) :: i1, i2, j1, j2 1009 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 1010 LOGICAL , INTENT(in ) :: before 1011 INTEGER , INTENT(in ) :: nb , ndir 1012 ! 1013 INTEGER :: ji,jj 1014 REAL(wp) :: zrhot, zt0, zt1,zat 1015 LOGICAL :: western_side, eastern_side,northern_side,southern_side 1132 1016 !!---------------------------------------------------------------------- 1133 1017 ! 1134 1018 IF( before ) THEN 1135 DO jj=j1,j2 1136 DO ji=i1,i2 1137 ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 1138 END DO 1139 END DO 1019 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 1140 1020 ELSE 1141 1021 western_side = (nb == 1).AND.(ndir == 1) … … 1148 1028 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1149 1029 ! Polynomial interpolation coefficients: 1150 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) 1151 & - zt0**2._wp * (-2._wp*zt0 + 3._wp))1152 ! 1153 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)1154 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)1155 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)1156 IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)1030 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 1031 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1032 ! 1033 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2) 1034 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1035 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1) 1036 IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1157 1037 ENDIF 1158 1038 ! 1159 1039 END SUBROUTINE interpvb2b 1160 1040 1161 SUBROUTINE interpe3t(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1041 1042 SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 1162 1043 !!---------------------------------------------------------------------- 1163 1044 !! *** ROUTINE interpe3t *** 1164 1045 !!---------------------------------------------------------------------- 1165 ! 1166 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1046 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 1167 1047 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1168 LOGICAL :: before1169 INTEGER , INTENT(in) :: nb , ndir1048 LOGICAL , INTENT(in ) :: before 1049 INTEGER , INTENT(in ) :: nb , ndir 1170 1050 ! 1171 1051 INTEGER :: ji, jj, jk … … 1174 1054 !!---------------------------------------------------------------------- 1175 1055 ! 1176 IF (before) THEN 1177 DO jk=k1,k2 1178 DO jj=j1,j2 1179 DO ji=i1,i2 1180 ptab(ji,jj,jk) = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 1181 END DO 1182 END DO 1183 END DO 1056 IF( before ) THEN 1057 ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2) 1184 1058 ELSE 1185 1059 western_side = (nb == 1).AND.(ndir == 1) … … 1188 1062 northern_side = (nb == 2).AND.(ndir == 2) 1189 1063 1190 DO jk =k1,k21191 DO jj =j1,j21192 DO ji =i1,i21064 DO jk = k1, k2 1065 DO jj = j1, j2 1066 DO ji = i1, i2 1193 1067 ! Get velocity mask at boundary edge points: 1194 IF (western_side)ztmpmsk = umask(ji ,jj ,1)1195 IF (eastern_side)ztmpmsk = umask(nlci-2,jj ,1)1196 IF (northern_side)ztmpmsk = vmask(ji ,nlcj-2,1)1197 IF (southern_side)ztmpmsk = vmask(ji ,2 ,1)1198 1199 IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk))*ztmpmsk > 1.D-2) THEN1068 IF( western_side ) ztmpmsk = umask(ji ,jj ,1) 1069 IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1) 1070 IF( northern_side) ztmpmsk = vmask(ji ,nlcj-2,1) 1071 IF( southern_side) ztmpmsk = vmask(ji ,2 ,1) 1072 ! 1073 IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) )*ztmpmsk > 1.D-2) THEN 1200 1074 IF (western_side) THEN 1201 1075 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk … … 1213 1087 END DO 1214 1088 END DO 1215 1089 ! 1216 1090 ENDIF 1217 1091 ! … … 1219 1093 1220 1094 1221 SUBROUTINE interpumsk( ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir)1095 SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 1222 1096 !!---------------------------------------------------------------------- 1223 1097 !! *** ROUTINE interpumsk *** 1224 1098 !!---------------------------------------------------------------------- 1225 ! 1226 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1227 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1228 LOGICAL :: before 1229 INTEGER, INTENT(in) :: nb , ndir 1230 ! 1231 INTEGER :: ji, jj, jk 1232 LOGICAL :: western_side, eastern_side 1099 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 1100 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1101 LOGICAL , , INTENT(in ) :: before 1102 INTEGER , INTENT(in ) :: nb , ndir 1103 ! 1104 INTEGER :: ji, jj, jk 1105 LOGICAL :: western_side, eastern_side 1233 1106 !!---------------------------------------------------------------------- 1234 1107 ! 1235 IF (before) THEN 1236 DO jk=k1,k2 1237 DO jj=j1,j2 1238 DO ji=i1,i2 1239 ptab(ji,jj,jk) = umask(ji,jj,jk) 1240 END DO 1241 END DO 1242 END DO 1108 IF( before ) THEN 1109 ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2) 1243 1110 ELSE 1244 1245 western_side = (nb == 1).AND.(ndir == 1) 1246 eastern_side = (nb == 1).AND.(ndir == 2) 1247 DO jk=k1,k2 1248 DO jj=j1,j2 1249 DO ji=i1,i2 1111 western_side = (nb == 1).AND.(ndir == 1) 1112 eastern_side = (nb == 1).AND.(ndir == 2) 1113 DO jk = k1, k2 1114 DO jj = j1, j2 1115 DO ji = i1, i2 1250 1116 ! Velocity mask at boundary edge points: 1251 1117 IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN … … 1263 1129 END DO 1264 1130 END DO 1265 1131 ! 1266 1132 ENDIF 1267 1133 ! 1268 1134 END SUBROUTINE interpumsk 1269 1135 1270 SUBROUTINE interpvmsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1136 1137 SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 1271 1138 !!---------------------------------------------------------------------- 1272 1139 !! *** ROUTINE interpvmsk *** 1273 1140 !!---------------------------------------------------------------------- 1274 ! 1275 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1276 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1277 LOGICAL :: before 1278 INTEGER, INTENT(in) :: nb , ndir 1279 ! 1280 INTEGER :: ji, jj, jk 1281 LOGICAL :: northern_side, southern_side 1141 INTEGER , INTENT(in ) :: i1,i2,j1,j2,k1,k2 1142 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1143 LOGICAL , INTENT(in ) :: before 1144 INTEGER , INTENT(in ) :: nb , ndir 1145 ! 1146 INTEGER :: ji, jj, jk 1147 LOGICAL :: northern_side, southern_side 1282 1148 !!---------------------------------------------------------------------- 1283 1149 ! 1284 IF (before) THEN 1285 DO jk=k1,k2 1286 DO jj=j1,j2 1287 DO ji=i1,i2 1288 ptab(ji,jj,jk) = vmask(ji,jj,jk) 1289 END DO 1290 END DO 1291 END DO 1150 IF( before ) THEN 1151 ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2) 1292 1152 ELSE 1293 1294 1153 southern_side = (nb == 2).AND.(ndir == 1) 1295 1154 northern_side = (nb == 2).AND.(ndir == 2) 1296 DO jk =k1,k21297 DO jj =j1,j21298 DO ji =i1,i21155 DO jk = k1, k2 1156 DO jj = j1, j2 1157 DO ji = i1, i2 1299 1158 ! Velocity mask at boundary edge points: 1300 1159 IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN … … 1312 1171 END DO 1313 1172 END DO 1314 1173 ! 1315 1174 ENDIF 1316 1175 ! … … 1319 1178 # if defined key_zdftke 1320 1179 1321 SUBROUTINE interpavm( ptab,i1,i2,j1,j2,k1,k2,before)1180 SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before ) 1322 1181 !!---------------------------------------------------------------------- 1323 1182 !! *** ROUTINE interavm *** 1324 1183 !!---------------------------------------------------------------------- 1325 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k21326 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab1327 LOGICAL , INTENT(in) ::before1184 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 1185 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1186 LOGICAL , INTENT(in ) :: before 1328 1187 !!---------------------------------------------------------------------- 1329 1188 ! 1330 IF( before ) THEN1189 IF( before ) THEN 1331 1190 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1332 1191 ELSE
Note: See TracChangeset
for help on using the changeset viewer.
