- Timestamp:
- 2017-12-01T18:44:09+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r7646 r8882 2 2 !!====================================================================== 3 3 !! *** MODULE agrif_opa_interp *** 4 !! AGRIF: interpolation package 4 !! AGRIF: interpolation package for the ocean dynamics (OPA) 5 5 !!====================================================================== 6 !! History : 2.0 ! 2002-06 (XXX) Original cade 7 !! - ! 2005-11 (XXX) 6 !! History : 2.0 ! 2002-06 (L. Debreu) Original cade 8 7 !! 3.2 ! 2009-04 (R. Benshila) 9 8 !! 3.6 ! 2014-09 (R. Benshila) … … 15 14 !! Agrif_tra : 16 15 !! Agrif_dyn : 16 !! Agrif_ssh : 17 !! Agrif_dyn_ts : 18 !! Agrif_dta_ts : 19 !! Agrif_ssh_ts : 20 !! Agrif_avm : 17 21 !! interpu : 18 22 !! interpv : … … 28 32 USE agrif_opa_sponge 29 33 USE lib_mpp 30 USE wrk_nemo31 34 32 35 IMPLICIT NONE … … 34 37 35 38 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 36 PUBLIC interpun , interpvn37 PUBLIC interptsn, 38 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b39 PUBLIC interpun , interpvn 40 PUBLIC interptsn, interpsshn 41 PUBLIC interpunb, interpvnb , interpub2b, interpvb2b 39 42 PUBLIC interpe3t, interpumsk, interpvmsk 40 # if defined key_zdftke 41 PUBLIC Agrif_tke, interpavm 42 # endif 43 PUBLIC Agrif_avm, interpavm 43 44 44 45 INTEGER :: bdy_tinterp = 0 … … 46 47 # include "vectopt_loop_substitute.h90" 47 48 !!---------------------------------------------------------------------- 48 !! NEMO/NST 3.7 , NEMO Consortium (2015)49 !! NEMO/NST 4.0 , NEMO Consortium (2017) 49 50 !! $Id$ 50 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 77 78 INTEGER :: ji, jj, jk ! dummy loop indices 78 79 INTEGER :: j1, j2, i1, i2 79 REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb80 REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb 80 81 !!---------------------------------------------------------------------- 81 82 ! 82 83 IF( Agrif_Root() ) RETURN 83 !84 CALL wrk_alloc( jpi,jpj, zub, zvb )85 84 ! 86 85 Agrif_SpecialValue = 0._wp … … 105 104 ! --------- 106 105 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 107 ua_b(2 ,:) = 0._wp106 ua_b(2:1+nbghostcells,:) = 0._wp 108 107 DO jk = 1, jpkm1 109 108 DO jj = 1, jpj 110 ua_b(2 ,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)109 ua_b(2:1+nbghostcells,jj) = ua_b(2:1+nbghostcells,jj) + e3u_a(2:1+nbghostcells,jj,jk) * ua(2:1+nbghostcells,jj,jk) 111 110 END DO 112 111 END DO 113 112 DO jj = 1, jpj 114 ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj) 115 END DO 116 ENDIF 117 ! 118 DO jk=1,jpkm1 ! Smooth 119 DO jj=j1,j2 120 ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 121 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 122 END DO 123 END DO 124 ! 125 zub(2,:) = 0._wp ! Correct transport 126 DO jk = 1, jpkm1 127 DO jj = 1, jpj 128 zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 129 END DO 130 END DO 131 DO jj=1,jpj 132 zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 133 END DO 134 135 DO jk=1,jpkm1 136 DO jj=1,jpj 137 ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 138 END DO 139 END DO 140 141 ! Set tangential velocities to time splitting estimate 142 !----------------------------------------------------- 143 IF( ln_dynspg_ts ) THEN 144 zvb(2,:) = 0._wp 113 ua_b(2:1+nbghostcells,jj) = ua_b(2:1+nbghostcells,jj) * r1_hu_a(2:1+nbghostcells,jj) 114 END DO 115 ENDIF 116 ! 117 ! Smoothing if only 1 ghostcell 118 ! ----------------------------- 119 IF( nbghostcells == 1 ) THEN 120 DO jk=1,jpkm1 ! Smooth 121 DO jj=j1,j2 122 ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) 123 ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 124 END DO 125 END DO 126 ! 127 zub(2,:) = 0._wp ! Correct transport 145 128 DO jk = 1, jpkm1 146 129 DO jj = 1, jpj 147 zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk) 148 END DO 149 END DO 150 DO jj = 1, jpj 151 zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj) 152 END DO 130 zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk) 131 END DO 132 END DO 133 DO jj=1,jpj 134 zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 135 END DO 136 153 137 DO jk = 1, jpkm1 154 138 DO jj = 1, jpj 155 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk) 156 END DO 157 END DO 139 ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk) 140 END DO 141 END DO 142 143 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 144 zvb(2,:) = 0._wp 145 DO jk = 1, jpkm1 146 DO jj = 1, jpj 147 zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk) 148 END DO 149 END DO 150 DO jj = 1, jpj 151 zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj) 152 END DO 153 DO jk = 1, jpkm1 154 DO jj = 1, jpj 155 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk) 156 END DO 157 END DO 158 ENDIF 159 ! 158 160 ENDIF 159 161 ! 160 162 ! Mask domain edges: 161 163 !------------------- 162 DO jk = 1, jpkm1 163 DO jj = 1, jpj 164 ua(1,jj,jk) = 0._wp 165 va(1,jj,jk) = 0._wp 166 END DO 167 END DO 168 ! 169 ENDIF 170 164 ! DO jk = 1, jpkm1 165 ! DO jj = 1, jpj 166 ! ua(1,jj,jk) = 0._wp 167 ! va(1,jj,jk) = 0._wp 168 ! END DO 169 ! END DO 170 ! 171 ENDIF 172 173 ! --- East --- ! 171 174 IF( nbondi == 1 .OR. nbondi == 2 ) THEN 172 175 173 ! Smoothing174 ! ---------175 176 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 176 ua_b(nlci- 2,:) = 0._wp177 ua_b(nlci-nbghostcells-1:nlci-2,:) = 0._wp 177 178 DO jk=1,jpkm1 178 179 DO jj=1,jpj 179 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 180 ua_b(nlci-nbghostcells-1:nlci-2,jj) = ua_b(nlci-nbghostcells-1:nlci-2,jj) + e3u_a(nlci-nbghostcells-1:nlci-2,jj,jk) & 181 & * ua(nlci-nbghostcells-1:nlci-2,jj,jk) 180 182 END DO 181 183 END DO 182 184 DO jj=1,jpj 183 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj) 184 END DO 185 ENDIF 186 187 DO jk = 1, jpkm1 ! Smooth 188 DO jj = j1, j2 189 ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) & 190 & * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) ) 191 END DO 192 END DO 193 194 zub(nlci-2,:) = 0._wp ! Correct transport 195 DO jk = 1, jpkm1 196 DO jj = 1, jpj 197 zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 198 END DO 199 END DO 200 DO jj = 1, jpj 201 zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj) 202 END DO 203 204 DO jk = 1, jpkm1 205 DO jj = 1, jpj 206 ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk) 207 END DO 208 END DO 209 ! 210 ! Set tangential velocities to time splitting estimate 211 !----------------------------------------------------- 212 IF( ln_dynspg_ts ) THEN 213 zvb(nlci-1,:) = 0._wp 185 ua_b(nlci-nbghostcells-1:nlci-2,jj) = ua_b(nlci-nbghostcells-1:nlci-2,jj) * r1_hu_a(nlci-nbghostcells-1:nlci-2,jj) 186 END DO 187 ENDIF 188 ! 189 ! Smoothing if only 1 ghostcell 190 ! ----------------------------- 191 IF( nbghostcells == 1 ) THEN 192 DO jk = 1, jpkm1 ! Smooth 193 DO jj = j1, j2 194 ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) & 195 & * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) ) 196 END DO 197 END DO 198 199 zub(nlci-2,:) = 0._wp ! Correct transport 214 200 DO jk = 1, jpkm1 215 201 DO jj = 1, jpj 216 zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 217 END DO 218 END DO 219 DO jj=1,jpj 220 zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj) 221 END DO 202 zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 203 END DO 204 END DO 205 DO jj = 1, jpj 206 zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj) 207 END DO 208 222 209 DO jk = 1, jpkm1 223 210 DO jj = 1, jpj 224 va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk) 225 END DO 226 END DO 211 ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk) 212 END DO 213 END DO 214 ! 215 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 216 zvb(nlci-1,:) = 0._wp 217 DO jk = 1, jpkm1 218 DO jj = 1, jpj 219 zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 220 END DO 221 END DO 222 DO jj=1,jpj 223 zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj) 224 END DO 225 DO jk = 1, jpkm1 226 DO jj = 1, jpj 227 va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk) 228 END DO 229 END DO 230 ENDIF 231 ! 227 232 ENDIF 228 233 ! 229 234 ! Mask domain edges: 230 235 !------------------- 231 DO jk = 1, jpkm1 232 DO jj = 1, jpj 233 ua(nlci-1,jj,jk) = 0._wp 234 va(nlci ,jj,jk) = 0._wp 235 END DO 236 END DO 237 ! 238 ENDIF 239 236 ! DO jk = 1, jpkm1 237 ! DO jj = 1, jpj 238 ! ua(nlci-1,jj,jk) = 0._wp 239 ! va(nlci ,jj,jk) = 0._wp 240 ! END DO 241 ! END DO 242 ! 243 ENDIF 244 245 ! --- South --- ! 240 246 IF( nbondj == -1 .OR. nbondj == 2 ) THEN 241 247 242 ! Smoothing243 ! ---------244 248 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 245 va_b(:,2 ) = 0._wp249 va_b(:,2:nbghostcells+1) = 0._wp 246 250 DO jk = 1, jpkm1 247 251 DO ji = 1, jpi 248 va_b(ji,2 ) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk)252 va_b(ji,2:nbghostcells+1) = va_b(ji,2:nbghostcells+1) + e3v_a(ji,2:nbghostcells+1,jk) * va(ji,2:nbghostcells+1,jk) 249 253 END DO 250 254 END DO 251 255 DO ji=1,jpi 252 va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2) 253 END DO 254 ENDIF 255 ! 256 DO jk = 1, jpkm1 ! Smooth 257 DO ji = i1, i2 258 va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) & 259 & * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) ) 260 END DO 261 END DO 262 ! 263 zvb(:,2) = 0._wp ! Correct transport 264 DO jk=1,jpkm1 265 DO ji=1,jpi 266 zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 267 END DO 268 END DO 269 DO ji = 1, jpi 270 zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2) 271 END DO 272 DO jk = 1, jpkm1 256 va_b(ji,2:nbghostcells+1) = va_b(ji,2:nbghostcells+1) * r1_hv_a(ji,2:nbghostcells+1) 257 END DO 258 ENDIF 259 ! 260 ! Smoothing if only 1 ghostcell 261 ! ----------------------------- 262 IF( nbghostcells == 1 ) THEN 263 DO jk = 1, jpkm1 ! Smooth 264 DO ji = i1, i2 265 va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk) & 266 & * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) ) 267 END DO 268 END DO 269 ! 270 zvb(:,2) = 0._wp ! Correct transport 271 DO jk=1,jpkm1 272 DO ji=1,jpi 273 zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk) 274 END DO 275 END DO 273 276 DO ji = 1, jpi 274 va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk) 275 END DO 276 END DO 277 278 ! Set tangential velocities to time splitting estimate 279 !----------------------------------------------------- 280 IF( ln_dynspg_ts ) THEN 281 zub(:,2) = 0._wp 277 zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2) 278 END DO 282 279 DO jk = 1, jpkm1 283 280 DO ji = 1, jpi 284 zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 285 END DO 286 END DO 287 DO ji = 1, jpi 288 zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2) 289 END DO 290 281 va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk) 282 END DO 283 END DO 284 285 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 286 zub(:,2) = 0._wp 287 DO jk = 1, jpkm1 288 DO ji = 1, jpi 289 zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk) 290 END DO 291 END DO 292 DO ji = 1, jpi 293 zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2) 294 END DO 295 296 DO jk = 1, jpkm1 297 DO ji = 1, jpi 298 ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk) 299 END DO 300 END DO 301 ENDIF 302 ! 303 ENDIF 304 ! 305 ! Mask domain edges: 306 !------------------- 307 ! DO jk = 1, jpkm1 308 ! DO ji = 1, jpi 309 ! ua(ji,1,jk) = 0._wp 310 ! va(ji,1,jk) = 0._wp 311 ! END DO 312 ! END DO 313 ! 314 ENDIF 315 316 ! --- North --- ! 317 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 318 ! 319 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 320 va_b(:,nlcj-nbghostcells-1:nlcj-2) = 0._wp 291 321 DO jk = 1, jpkm1 292 322 DO ji = 1, jpi 293 ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk) 294 END DO 295 END DO 296 ENDIF 297 323 va_b(ji,nlcj-nbghostcells-1:nlcj-2) = va_b(ji,nlcj-nbghostcells-1:nlcj-2) + e3v_a(ji,nlcj-nbghostcells-1:nlcj-2,jk) & 324 & * va(ji,nlcj-nbghostcells-1:nlcj-2,jk) 325 END DO 326 END DO 327 DO ji = 1, jpi 328 va_b(ji,nlcj-nbghostcells-1:nlcj-2) = va_b(ji,nlcj-nbghostcells-1:nlcj-2) * r1_hv_a(ji,nlcj-nbghostcells-1:nlcj-2) 329 END DO 330 ENDIF 331 ! 332 ! Smoothing if only 1 ghostcell 333 ! ----------------------------- 334 IF( nbghostcells == 1 ) THEN 335 DO jk = 1, jpkm1 ! Smooth 336 DO ji = i1, i2 337 va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) & 338 & * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) ) 339 END DO 340 END DO 341 ! 342 zvb(:,nlcj-2) = 0._wp ! Correct transport 343 DO jk = 1, jpkm1 344 DO ji = 1, jpi 345 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 346 END DO 347 END DO 348 DO ji = 1, jpi 349 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 350 END DO 351 DO jk = 1, jpkm1 352 DO ji = 1, jpi 353 va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk) 354 END DO 355 END DO 356 ! 357 IF( ln_dynspg_ts ) THEN ! Set tangential velocities to time splitting estimate 358 zub(:,nlcj-1) = 0._wp 359 DO jk = 1, jpkm1 360 DO ji = 1, jpi 361 zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 362 END DO 363 END DO 364 DO ji = 1, jpi 365 zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1) 366 END DO 367 ! 368 DO jk = 1, jpkm1 369 DO ji = 1, jpi 370 ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk) 371 END DO 372 END DO 373 ENDIF 374 ! 375 ENDIF 376 ! 298 377 ! Mask domain edges: 299 378 !------------------- 300 DO jk = 1, jpkm1 301 DO ji = 1, jpi 302 ua(ji,1,jk) = 0._wp 303 va(ji,1,jk) = 0._wp 304 END DO 305 END DO 306 307 ENDIF 308 309 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 310 ! 311 ! Smoothing 312 ! --------- 313 IF( .NOT.ln_dynspg_ts ) THEN ! Store transport 314 va_b(:,nlcj-2) = 0._wp 315 DO jk = 1, jpkm1 316 DO ji = 1, jpi 317 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) 318 END DO 319 END DO 320 DO ji = 1, jpi 321 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 322 END DO 323 ENDIF 324 ! 325 DO jk = 1, jpkm1 ! Smooth 326 DO ji = i1, i2 327 va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) & 328 & * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) ) 329 END DO 330 END DO 331 ! 332 zvb(:,nlcj-2) = 0._wp ! Correct transport 333 DO jk = 1, jpkm1 334 DO ji = 1, jpi 335 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 336 END DO 337 END DO 338 DO ji = 1, jpi 339 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2) 340 END DO 341 DO jk = 1, jpkm1 342 DO ji = 1, jpi 343 va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk) 344 END DO 345 END DO 346 ! 347 ! Set tangential velocities to time splitting estimate 348 !----------------------------------------------------- 349 IF( ln_dynspg_ts ) THEN 350 zub(:,nlcj-1) = 0._wp 351 DO jk = 1, jpkm1 352 DO ji = 1, jpi 353 zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 354 END DO 355 END DO 356 DO ji = 1, jpi 357 zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1) 358 END DO 359 ! 360 DO jk = 1, jpkm1 361 DO ji = 1, jpi 362 ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk) 363 END DO 364 END DO 365 ENDIF 366 ! 367 ! Mask domain edges: 368 !------------------- 369 DO jk = 1, jpkm1 370 DO ji = 1, jpi 371 ua(ji,nlcj ,jk) = 0._wp 372 va(ji,nlcj-1,jk) = 0._wp 373 END DO 374 END DO 375 ! 376 ENDIF 377 ! 378 CALL wrk_dealloc( jpi,jpj, zub, zvb ) 379 ! DO jk = 1, jpkm1 380 ! DO ji = 1, jpi 381 ! ua(ji,nlcj ,jk) = 0._wp 382 ! va(ji,nlcj-1,jk) = 0._wp 383 ! END DO 384 ! END DO 385 ! 386 ENDIF 379 387 ! 380 388 END SUBROUTINE Agrif_dyn … … 385 393 !! *** ROUTINE Agrif_dyn_ts *** 386 394 !!---------------------------------------------------------------------- 387 !!388 395 INTEGER, INTENT(in) :: jn 389 396 !! … … 392 399 ! 393 400 IF( Agrif_Root() ) RETURN 394 ! 401 !! clem ghost 395 402 IF((nbondi == -1).OR.(nbondi == 2)) THEN 396 403 DO jj=1,jpj 397 va_e(2 ,jj) = vbdy_w(jj) * hvr_e(2,jj)404 va_e(2:nbghostcells+1,jj) = vbdy_w(jj) * hvr_e(2:nbghostcells+1,jj) 398 405 ! Specified fluxes: 399 ua_e(2 ,jj) = ubdy_w(jj) * hur_e(2,jj)400 ! Characteristics method :406 ua_e(2:nbghostcells+1,jj) = ubdy_w(jj) * hur_e(2:nbghostcells+1,jj) 407 ! Characteristics method (only if ghostcells=1): 401 408 !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 402 409 !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) … … 406 413 IF((nbondi == 1).OR.(nbondi == 2)) THEN 407 414 DO jj=1,jpj 408 va_e(nlci- 1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj)415 va_e(nlci-nbghostcells:nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-nbghostcells:nlci-1,jj) 409 416 ! Specified fluxes: 410 ua_e(nlci- 2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj)411 ! Characteristics method :417 ua_e(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-nbghostcells-1:nlci-2,jj) 418 ! Characteristics method (only if ghostcells=1): 412 419 !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 413 420 !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) … … 417 424 IF((nbondj == -1).OR.(nbondj == 2)) THEN 418 425 DO ji=1,jpi 419 ua_e(ji,2 ) = ubdy_s(ji) * hur_e(ji,2)426 ua_e(ji,2:nbghostcells+1) = ubdy_s(ji) * hur_e(ji,2:nbghostcells+1) 420 427 ! Specified fluxes: 421 va_e(ji,2 ) = vbdy_s(ji) * hvr_e(ji,2)422 ! Characteristics method :428 va_e(ji,2:nbghostcells+1) = vbdy_s(ji) * hvr_e(ji,2:nbghostcells+1) 429 ! Characteristics method (only if ghostcells=1): 423 430 !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 424 431 !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) … … 428 435 IF((nbondj == 1).OR.(nbondj == 2)) THEN 429 436 DO ji=1,jpi 430 ua_e(ji,nlcj- 1) = ubdy_n(ji) * hur_e(ji,nlcj-1)437 ua_e(ji,nlcj-nbghostcells:nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-nbghostcells:nlcj-1) 431 438 ! Specified fluxes: 432 va_e(ji,nlcj- 2) = vbdy_n(ji) * hvr_e(ji,nlcj-2)433 ! Characteristics method :439 va_e(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-nbghostcells-1:nlcj-2) 440 ! Characteristics method (only if ghostcells=1): 434 441 !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) & 435 442 !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) … … 444 451 !! *** ROUTINE Agrif_dta_ts *** 445 452 !!---------------------------------------------------------------------- 446 !!447 453 INTEGER, INTENT(in) :: kt 448 454 !! … … 476 482 ! 477 483 IF( ll_int_cons ) THEN ! Conservative interpolation 478 ! order smatters here !!!!!!484 ! order matters here !!!!!! 479 485 CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated 480 486 CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b ) … … 504 510 !!---------------------------------------------------------------------- 505 511 INTEGER, INTENT(in) :: kt 506 !! 512 ! 513 INTEGER :: ji, jj, indx 507 514 !!---------------------------------------------------------------------- 508 515 ! 509 516 IF( Agrif_Root() ) RETURN 510 ! 517 !! clem ghost 518 ! --- West --- ! 511 519 IF((nbondi == -1).OR.(nbondi == 2)) THEN 512 ssha(2,:)=ssha(3,:) 513 sshn(2,:)=sshn(3,:) 514 ENDIF 515 ! 520 indx = 1+nbghostcells 521 DO jj = 1, jpj 522 DO ji = 2, indx 523 ssha(ji,jj)=ssha(indx+1,jj) 524 sshn(ji,jj)=sshn(indx+1,jj) 525 ENDDO 526 ENDDO 527 ENDIF 528 ! 529 ! --- East --- ! 516 530 IF((nbondi == 1).OR.(nbondi == 2)) THEN 517 ssha(nlci-1,:)=ssha(nlci-2,:) 518 sshn(nlci-1,:)=sshn(nlci-2,:) 519 ENDIF 520 ! 531 indx = nlci-nbghostcells 532 DO jj = 1, jpj 533 DO ji = indx, nlci-1 534 ssha(ji,jj)=ssha(indx-1,jj) 535 sshn(ji,jj)=sshn(indx-1,jj) 536 ENDDO 537 ENDDO 538 ENDIF 539 ! 540 ! --- South --- ! 521 541 IF((nbondj == -1).OR.(nbondj == 2)) THEN 522 ssha(:,2)=ssha(:,3) 523 sshn(:,2)=sshn(:,3) 524 ENDIF 525 ! 542 indx = 1+nbghostcells 543 DO jj = 2, indx 544 DO ji = 1, jpi 545 ssha(ji,jj)=ssha(ji,indx+1) 546 sshn(ji,jj)=sshn(ji,indx+1) 547 ENDDO 548 ENDDO 549 ENDIF 550 ! 551 ! --- North --- ! 526 552 IF((nbondj == 1).OR.(nbondj == 2)) THEN 527 ssha(:,nlcj-1)=ssha(:,nlcj-2) 528 sshn(:,nlcj-1)=sshn(:,nlcj-2) 553 indx = nlcj-nbghostcells 554 DO jj = indx, nlcj-1 555 DO ji = 1, jpi 556 ssha(ji,jj)=ssha(ji,indx-1) 557 sshn(ji,jj)=sshn(ji,indx-1) 558 ENDDO 559 ENDDO 529 560 ENDIF 530 561 ! … … 538 569 INTEGER, INTENT(in) :: jn 539 570 !! 540 INTEGER :: ji, jj541 !!---------------------------------------------------------------------- 542 ! 571 INTEGER :: ji, jj 572 !!---------------------------------------------------------------------- 573 !! clem ghost (starting at i,j=1 is important I think otherwise you introduce a grad(ssh)/=0 at point 2) 543 574 IF((nbondi == -1).OR.(nbondi == 2)) THEN 544 575 DO jj = 1, jpj 545 ssha_e(2 ,jj) = hbdy_w(jj)576 ssha_e(2:nbghostcells+1,jj) = hbdy_w(jj) 546 577 END DO 547 578 ENDIF … … 549 580 IF((nbondi == 1).OR.(nbondi == 2)) THEN 550 581 DO jj = 1, jpj 551 ssha_e(nlci- 1,jj) = hbdy_e(jj)582 ssha_e(nlci-nbghostcells:nlci-1,jj) = hbdy_e(jj) 552 583 END DO 553 584 ENDIF … … 555 586 IF((nbondj == -1).OR.(nbondj == 2)) THEN 556 587 DO ji = 1, jpi 557 ssha_e(ji,2 ) = hbdy_s(ji)588 ssha_e(ji,2:nbghostcells+1) = hbdy_s(ji) 558 589 END DO 559 590 ENDIF … … 561 592 IF((nbondj == 1).OR.(nbondj == 2)) THEN 562 593 DO ji = 1, jpi 563 ssha_e(ji,nlcj- 1) = hbdy_n(ji)594 ssha_e(ji,nlcj-nbghostcells:nlcj-1) = hbdy_n(ji) 564 595 END DO 565 596 ENDIF … … 567 598 END SUBROUTINE Agrif_ssh_ts 568 599 569 # if defined key_zdftke 570 571 SUBROUTINE Agrif_tke 572 !!---------------------------------------------------------------------- 573 !! *** ROUTINE Agrif_tke *** 600 601 SUBROUTINE Agrif_avm 602 !!---------------------------------------------------------------------- 603 !! *** ROUTINE Agrif_avm *** 574 604 !!---------------------------------------------------------------------- 575 605 REAL(wp) :: zalpha 576 606 !!---------------------------------------------------------------------- 577 607 ! 578 zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 579 IF( zalpha > 1. ) zalpha = 1. 580 ! 581 Agrif_SpecialValue = 0.e0 608 zalpha = 1._wp ! proper time interpolation impossible ==> use last available value from parent 609 ! 610 Agrif_SpecialValue = 0._wp 582 611 Agrif_UseSpecialValue = .TRUE. 583 612 ! 584 CALL Agrif_Bc_variable( avm_id ,calledweight=zalpha, procname=interpavm)613 CALL Agrif_Bc_variable( avm_id, calledweight=zalpha, procname=interpavm ) 585 614 ! 586 615 Agrif_UseSpecialValue = .FALSE. 587 616 ! 588 END SUBROUTINE Agrif_ tke617 END SUBROUTINE Agrif_avm 589 618 590 # endif591 619 592 620 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 593 621 !!---------------------------------------------------------------------- 594 !! *** ROUTINE interptsn ***622 !! *** ROUTINE interptsn *** 595 623 !!---------------------------------------------------------------------- 596 624 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab … … 601 629 INTEGER :: ji, jj, jk, jn ! dummy loop indices 602 630 INTEGER :: imin, imax, jmin, jmax 603 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 604 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 631 REAL(wp) :: zrhox, z1, z2, z3, z4, z5, z6, z7 605 632 LOGICAL :: western_side, eastern_side,northern_side,southern_side 606 633 !!---------------------------------------------------------------------- 607 634 ! 608 IF (before) THEN635 IF( before ) THEN 609 636 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 610 637 ELSE 611 638 ! 612 western_side = (nb == 1).AND.(ndir == 1) 613 eastern_side = (nb == 1).AND.(ndir == 2) 614 southern_side = (nb == 2).AND.(ndir == 1) 615 northern_side = (nb == 2).AND.(ndir == 2) 616 ! 617 zrhox = Agrif_Rhox() 618 ! 619 zalpha1 = ( zrhox - 1. ) * 0.5 620 zalpha2 = 1. - zalpha1 621 ! 622 zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 623 zalpha4 = 1. - zalpha3 624 ! 625 zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 626 zalpha7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 627 zalpha5 = 1. - zalpha6 - zalpha7 628 ! 629 imin = i1 630 imax = i2 631 jmin = j1 632 jmax = j2 633 ! 634 ! Remove CORNERS 635 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 636 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 637 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 638 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 639 ! 640 IF( eastern_side ) THEN 641 DO jn = 1, jpts 642 tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 643 DO jk = 1, jpkm1 644 DO jj = jmin,jmax 645 IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 646 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 647 ELSE 648 tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 649 IF( un(nlci-2,jj,jk) > 0._wp ) THEN 650 tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 651 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 639 western_side = (nb == 1).AND.(ndir == 1) ; eastern_side = (nb == 1).AND.(ndir == 2) 640 southern_side = (nb == 2).AND.(ndir == 1) ; northern_side = (nb == 2).AND.(ndir == 2) 641 ! 642 IF( nbghostcells > 1 ) THEN ! no smoothing 643 tsa(i1:i2,j1:j2,k1:k2,n1:n2) = ptab(i1:i2,j1:j2,k1:k2,n1:n2) 644 ELSE ! smoothing 645 ! 646 zrhox = Agrif_Rhox() 647 z1 = ( zrhox - 1. ) * 0.5 648 z3 = ( zrhox - 1. ) / ( zrhox + 1. ) 649 z6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 650 z7 = - ( zrhox - 1. ) / ( zrhox + 3. ) 651 ! 652 z2 = 1. - z1 653 z4 = 1. - z3 654 z5 = 1. - z6 - z7 655 ! 656 imin = i1 ; imax = i2 657 jmin = j1 ; jmax = j2 658 ! 659 ! Remove CORNERS 660 IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 661 IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 662 IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 663 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 664 ! 665 IF( eastern_side ) THEN 666 DO jn = 1, jpts 667 tsa(nlci,j1:j2,k1:k2,jn) = z1 * ptab(nlci,j1:j2,k1:k2,jn) + z2 * ptab(nlci-1,j1:j2,k1:k2,jn) 668 DO jk = 1, jpkm1 669 DO jj = jmin,jmax 670 IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 671 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 672 ELSE 673 tsa(nlci-1,jj,jk,jn)=(z4*tsa(nlci,jj,jk,jn)+z3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 674 IF( un(nlci-2,jj,jk) > 0._wp ) THEN 675 tsa(nlci-1,jj,jk,jn)=( z6*tsa(nlci-2,jj,jk,jn)+z5*tsa(nlci,jj,jk,jn) & 676 + z7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 677 ENDIF 652 678 ENDIF 653 END IF679 END DO 654 680 END DO 655 END DO656 tsa(nlci,j1:j2,k1:k2,jn) = 0._wp657 END DO658 ENDIF659 !660 IF( northern_side ) THEN661 DO jn = 1, jpts662 tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn)663 DO jk = 1, jpkm1664 DO ji = imin,imax665 IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN666 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)667 ELSE668 tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)669 IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN670 tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn) &671 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)681 tsa(nlci,j1:j2,k1:k2,jn) = 0._wp 682 END DO 683 ENDIF 684 ! 685 IF( northern_side ) THEN 686 DO jn = 1, jpts 687 tsa(i1:i2,nlcj,k1:k2,jn) = z1 * ptab(i1:i2,nlcj,k1:k2,jn) + z2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 688 DO jk = 1, jpkm1 689 DO ji = imin,imax 690 IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN 691 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 692 ELSE 693 tsa(ji,nlcj-1,jk,jn)=(z4*tsa(ji,nlcj,jk,jn)+z3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 694 IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN 695 tsa(ji,nlcj-1,jk,jn)=( z6*tsa(ji,nlcj-2,jk,jn)+z5*tsa(ji,nlcj,jk,jn) & 696 + z7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 697 ENDIF 672 698 ENDIF 673 END IF699 END DO 674 700 END DO 675 END DO676 tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp677 END DO678 ENDIF679 !680 IF( western_side ) THEN681 DO jn = 1, jpts682 tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn)683 DO jk = 1, jpkm1684 DO jj = jmin,jmax685 IF( umask(2,jj,jk) == 0._wp ) THEN686 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)687 ELSE688 tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)689 IF( un(2,jj,jk) < 0._wp ) THEN690 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)701 tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp 702 END DO 703 ENDIF 704 ! 705 IF( western_side ) THEN 706 DO jn = 1, jpts 707 tsa(1,j1:j2,k1:k2,jn) = z1 * ptab(1,j1:j2,k1:k2,jn) + z2 * ptab(2,j1:j2,k1:k2,jn) 708 DO jk = 1, jpkm1 709 DO jj = jmin,jmax 710 IF( umask(2,jj,jk) == 0._wp ) THEN 711 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 712 ELSE 713 tsa(2,jj,jk,jn)=(z4*tsa(1,jj,jk,jn)+z3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 714 IF( un(2,jj,jk) < 0._wp ) THEN 715 tsa(2,jj,jk,jn)=(z6*tsa(3,jj,jk,jn)+z5*tsa(1,jj,jk,jn)+z7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 716 ENDIF 691 717 ENDIF 692 END IF718 END DO 693 719 END DO 694 END DO695 tsa(1,j1:j2,k1:k2,jn) = 0._wp696 END DO697 ENDIF698 !699 IF( southern_side ) THEN700 DO jn = 1, jpts701 tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn)702 DO jk = 1, jpk703 DO ji=imin,imax704 IF( vmask(ji,2,jk) == 0._wp ) THEN705 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)706 ELSE707 tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk)708 IF( vn(ji,2,jk) < 0._wp ) THEN709 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)720 tsa(1,j1:j2,k1:k2,jn) = 0._wp 721 END DO 722 ENDIF 723 ! 724 IF( southern_side ) THEN 725 DO jn = 1, jpts 726 tsa(i1:i2,1,k1:k2,jn) = z1 * ptab(i1:i2,1,k1:k2,jn) + z2 * ptab(i1:i2,2,k1:k2,jn) 727 DO jk = 1, jpk 728 DO ji=imin,imax 729 IF( vmask(ji,2,jk) == 0._wp ) THEN 730 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 731 ELSE 732 tsa(ji,2,jk,jn)=(z4*tsa(ji,1,jk,jn)+z3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 733 IF( vn(ji,2,jk) < 0._wp ) THEN 734 tsa(ji,2,jk,jn)=(z6*tsa(ji,3,jk,jn)+z5*tsa(ji,1,jk,jn)+z7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 735 ENDIF 710 736 ENDIF 711 END IF737 END DO 712 738 END DO 713 END DO 714 tsa(i1:i2,1,k1:k2,jn) = 0._wp 715 END DO 716 ENDIF 717 ! 718 ! Treatment of corners 719 ! 720 ! East south 721 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 722 tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 723 ENDIF 724 ! East north 725 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 726 tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 727 ENDIF 728 ! West south 729 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 730 tsa(2,2,:,:) = ptab(2,2,:,:) 731 ENDIF 732 ! West north 733 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 734 tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 735 ENDIF 736 ! 739 tsa(i1:i2,1,k1:k2,jn) = 0._wp 740 END DO 741 ENDIF 742 ! 743 ! Treatment of corners 744 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) ! East south 745 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) ! East north 746 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) tsa(2,2,:,:) = ptab(2,2,:,:) ! West south 747 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) ! West north 748 ! 749 ENDIF 737 750 ENDIF 738 751 ! … … 759 772 southern_side = (nb == 2).AND.(ndir == 1) 760 773 northern_side = (nb == 2).AND.(ndir == 2) 761 IF(western_side) hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 762 IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 763 IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 774 !! clem ghost 775 IF(western_side) hbdy_w(j1:j2) = ptab(i2,j1:j2) * tmask(i2,j1:j2,1) 776 IF(eastern_side) hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) !clem previously i1 777 IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j2) * tmask(i1:i2,j2,1) !clem previously j1 764 778 IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 765 779 ENDIF … … 770 784 SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, before ) 771 785 !!---------------------------------------------------------------------- 772 !! *** ROUTINE interpun ***786 !! *** ROUTINE interpun *** 773 787 !!---------------------------------------------------------------------- 774 788 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 … … 798 812 SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, before ) 799 813 !!---------------------------------------------------------------------- 800 !! *** ROUTINE interpvn ***814 !! *** ROUTINE interpvn *** 801 815 !!---------------------------------------------------------------------- 802 816 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 … … 854 868 ELSEIF( bdy_tinterp == 2 ) THEN 855 869 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 856 & - zt0 * ( zt0 - 1._wp)**2._wp ) 857 870 & - zt0 * ( zt0 - 1._wp)**2._wp ) 858 871 ELSE 859 872 ztcoeff = 1 860 873 ENDIF 861 ! 862 IF(western_side) THEN 863 ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 864 ENDIF 865 IF(eastern_side) THEN 866 ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 867 ENDIF 868 IF(southern_side) THEN 869 ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 870 ENDIF 871 IF(northern_side) THEN 872 ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 873 ENDIF 874 !! clem ghost 875 IF(western_side) ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i2,j1:j2) 876 IF(eastern_side) ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) !clem previously i1 877 IF(southern_side) ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j2) !clem previously j1 878 IF(northern_side) ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 874 879 ! 875 880 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 876 IF(western_side) THEN 877 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 878 ENDIF 879 IF(eastern_side) THEN 880 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 881 ENDIF 882 IF(southern_side) THEN 883 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 884 ENDIF 885 IF(northern_side) THEN 886 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 887 ENDIF 881 IF(western_side) ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i2,j1:j2)) * umask(i2,j1:j2,1) 882 IF(eastern_side) ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 883 IF(southern_side) ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j2)) * umask(i1:i2,j2,1) 884 IF(northern_side) ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 888 885 ENDIF 889 886 ENDIF … … 927 924 ztcoeff = 1 928 925 ENDIF 929 ! 930 IF(western_side) THEN 931 vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 932 ENDIF 933 IF(eastern_side) THEN 934 vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 935 ENDIF 936 IF(southern_side) THEN 937 vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 938 ENDIF 939 IF(northern_side) THEN 940 vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 941 ENDIF 926 !! clem ghost 927 IF(western_side) vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i2,j1:j2) 928 IF(eastern_side) vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) !clem previously i1 929 IF(southern_side) vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j2) !clem previously j1 930 IF(northern_side) vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 942 931 ! 943 932 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 944 IF(western_side) THEN 945 vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 946 & * vmask(i1,j1:j2,1) 947 ENDIF 948 IF(eastern_side) THEN 949 vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) & 950 & * vmask(i1,j1:j2,1) 951 ENDIF 952 IF(southern_side) THEN 953 vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 954 & * vmask(i1:i2,j1,1) 955 ENDIF 956 IF(northern_side) THEN 957 vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) & 958 & * vmask(i1:i2,j1,1) 959 ENDIF 933 IF(western_side) vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i2,j1:j2)) * vmask(i2,j1:j2,1) 934 IF(eastern_side) vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2)) * vmask(i1,j1:j2,1) 935 IF(southern_side) vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j2)) * vmask(i1:i2,j2,1) 936 IF(northern_side) vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1)) * vmask(i1:i2,j1,1) 960 937 ENDIF 961 938 ENDIF … … 991 968 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 992 969 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 993 ! 994 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i 1,j1:j2)995 IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) 996 IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j 1)970 !! clem ghost 971 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i2,j1:j2) 972 IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) !clem previously i1 973 IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j2) !clem previously j1 997 974 IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1) 998 975 ENDIF … … 1030 1007 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 1031 1008 ! 1032 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i 1,j1:j2)1033 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 1034 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j 1)1009 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i2,j1:j2) 1010 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) !clem previously i1 1011 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j2) !clem previously j1 1035 1012 IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 1036 1013 ENDIF … … 1050 1027 INTEGER :: ji, jj, jk 1051 1028 LOGICAL :: western_side, eastern_side, northern_side, southern_side 1052 REAL(wp) :: ztmpmsk1053 1029 !!---------------------------------------------------------------------- 1054 1030 ! … … 1060 1036 southern_side = (nb == 2).AND.(ndir == 1) 1061 1037 northern_side = (nb == 2).AND.(ndir == 2) 1062 1038 ! 1063 1039 DO jk = k1, k2 1064 1040 DO jj = j1, j2 1065 1041 DO ji = i1, i2 1066 ! Get velocity mask at boundary edge points:1067 IF( western_side ) ztmpmsk = umask(ji ,jj ,1)1068 IF( eastern_side ) ztmpmsk = umask(nlci-2,jj ,1)1069 IF( northern_side) ztmpmsk = vmask(ji ,nlcj-2,1)1070 IF( southern_side) ztmpmsk = vmask(ji ,2 ,1)1071 1042 ! 1072 IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) *ztmpmsk> 1.D-2) THEN1043 IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) ) > 1.D-2) THEN 1073 1044 IF (western_side) THEN 1074 1045 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk … … 1175 1146 END SUBROUTINE interpvmsk 1176 1147 1177 # if defined key_zdftke1178 1148 1179 1149 SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before ) … … 1186 1156 !!---------------------------------------------------------------------- 1187 1157 ! 1188 IF( before ) THEN 1189 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1190 ELSE 1191 avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1158 IF( before ) THEN ; ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1159 ELSE ; avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 1192 1160 ENDIF 1193 1161 ! 1194 1162 END SUBROUTINE interpavm 1195 1196 # endif /* key_zdftke */1197 1163 1198 1164 #else
Note: See TracChangeset
for help on using the changeset viewer.
