- Timestamp:
- 2015-12-16T10:25:22+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_merge_2015/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r5930 r6060 22 22 USE oce 23 23 USE dom_oce 24 USE zdf_oce 24 25 USE agrif_oce 25 26 USE phycst 27 ! 26 28 USE in_out_manager 27 29 USE agrif_opa_sponge 28 30 USE lib_mpp 29 31 USE wrk_nemo 30 USE zdf_oce31 32 32 33 IMPLICIT NONE 33 34 PRIVATE 34 35 INTEGER :: bdy_tinterp = 036 35 37 36 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts … … 44 43 # endif 45 44 46 # include "domzgr_substitute.h90" 45 INTEGER :: bdy_tinterp = 0 46 47 47 # include "vectopt_loop_substitute.h90" 48 48 !!---------------------------------------------------------------------- 49 !! NEMO/NST 3. 6 , NEMO Consortium (2010)49 !! NEMO/NST 3.7 , NEMO Consortium (2015) 50 50 !! $Id$ 51 51 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 52 52 !!---------------------------------------------------------------------- 53 54 53 CONTAINS 55 54 … … 60 59 ! 61 60 IF( Agrif_Root() ) RETURN 62 63 Agrif_SpecialValue = 0. e061 ! 62 Agrif_SpecialValue = 0._wp 64 63 Agrif_UseSpecialValue = .TRUE. 65 64 ! 66 65 CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 66 ! 67 67 Agrif_UseSpecialValue = .FALSE. 68 68 ! … … 74 74 !! *** ROUTINE Agrif_DYN *** 75 75 !!---------------------------------------------------------------------- 76 !!77 76 INTEGER, INTENT(in) :: kt 78 !! 79 INTEGER :: ji,jj,jk, j1,j2, i1,i2 80 REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb 81 !!---------------------------------------------------------------------- 82 77 ! 78 INTEGER :: ji, jj, jk ! dummy loop indices 79 INTEGER :: j1, j2, i1, i2 80 REAL(wp), POINTER, DIMENSION(:,:) :: zub, zvb 81 !!---------------------------------------------------------------------- 82 ! 83 83 IF( Agrif_Root() ) RETURN 84 85 CALL wrk_alloc( jpi, jpj,zub, zvb )86 87 Agrif_SpecialValue =0.84 ! 85 CALL wrk_alloc( jpi,jpj, zub, zvb ) 86 ! 87 Agrif_SpecialValue = 0._wp 88 88 Agrif_UseSpecialValue = ln_spc_dyn 89 90 CALL Agrif_Bc_variable( un_interp_id,procname=interpun)91 CALL Agrif_Bc_variable( vn_interp_id,procname=interpvn)92 89 ! 90 CALL Agrif_Bc_variable( un_interp_id, procname=interpun ) 91 CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn ) 92 ! 93 93 Agrif_UseSpecialValue = .FALSE. 94 94 ! 95 95 ! prevent smoothing in ghost cells 96 i1=1 97 i2=jpi 98 j1=1 99 j2=jpj 100 IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 101 IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 102 IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 103 IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 104 105 106 IF((nbondi == -1).OR.(nbondi == 2)) THEN 107 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 ! 108 105 ! Smoothing 109 106 ! --------- 110 IF ( .NOT.ln_dynspg_ts ) THEN! Store transport111 ua_b(2,:) =0._wp112 DO jk =1,jpkm1113 DO jj =1,jpj114 ua_b(2,jj) = ua_b(2,jj) + fse3u_a(2,jj,jk) * ua(2,jj,jk)115 END DO 116 END DO 117 DO jj =1,jpj118 ua_b(2,jj) = ua_b(2,jj) * hur_a(2,jj)119 END DO 120 ENDIF 121 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 ! 122 119 DO jk=1,jpkm1 ! Smooth 123 120 DO jj=j1,j2 … … 126 123 END DO 127 124 END DO 128 129 zub(2,:) =0._wp! Correct transport130 DO jk =1,jpkm1131 DO jj =1,jpj132 zub(2,jj) = zub(2,jj) + fse3u_a(2,jj,jk) * ua(2,jj,jk)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) 133 130 END DO 134 131 END DO 135 132 DO jj=1,jpj 136 zub(2,jj) = zub(2,jj) * hur_a(2,jj)133 zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj) 137 134 END DO 138 135 … … 145 142 ! Set tangential velocities to time splitting estimate 146 143 !----------------------------------------------------- 147 IF ( ln_dynspg_ts) THEN 148 zvb(2,:)=0._wp 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 149 178 DO jk=1,jpkm1 150 179 DO jj=1,jpj 151 zvb(2,jj) = zvb(2,jj) + fse3v_a(2,jj,jk) * va(2,jj,jk)180 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 152 181 END DO 153 182 END DO 154 183 DO jj=1,jpj 155 zvb(2,jj) = zvb(2,jj) * hvr_a(2,jj) 156 END DO 157 DO jk=1,jpkm1 158 DO jj=1,jpj 159 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj))*vmask(2,jj,jk) 160 END DO 161 END DO 162 ENDIF 163 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 ! 211 ! Set tangential velocities to time splitting estimate 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 220 DO jj=1,jpj 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 ! 164 230 ! Mask domain edges: 165 231 !------------------- 166 DO jk =1,jpkm1167 DO jj =1,jpj168 ua( 1,jj,jk) = 0._wp169 va( 1,jj,jk) = 0._wp170 END DO 171 END DO 172 173 ENDIF 174 175 IF( (nbondi == 1).OR.(nbondi == 2)) THEN232 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 176 242 177 243 ! Smoothing 178 244 ! --------- 179 IF ( .NOT.ln_dynspg_ts ) THEN! Store transport180 ua_b(nlci-2,:)=0._wp181 DO jk =1,jpkm1182 DO j j=1,jpj183 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + fse3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)184 END DO 185 END DO 186 DO j j=1,jpj187 ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * hur_a(nlci-2,jj)188 END DO 189 ENDIF 190 191 DO jk =1,jpkm1! Smooth192 DO j j=j1,j2193 ua(nlci-2,jj,jk) = 0.25_wp*(ua(nlci-3,jj,jk)+2._wp*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk))194 ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk)195 END DO 196 END DO 197 198 z ub(nlci-2,:)=0._wp! Correct transport245 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 199 265 DO jk=1,jpkm1 200 DO jj=1,jpj 201 zub(nlci-2,jj) = zub(nlci-2,jj) + fse3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk) 202 END DO 203 END DO 204 DO jj=1,jpj 205 zub(nlci-2,jj) = zub(nlci-2,jj) * hur_a(nlci-2,jj) 206 END DO 207 208 DO jk=1,jpkm1 209 DO jj=1,jpj 210 ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+ua_b(nlci-2,jj)-zub(nlci-2,jj))*umask(nlci-2,jj,jk) 266 DO ji=1,jpi 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) 211 276 END DO 212 277 END DO … … 214 279 ! Set tangential velocities to time splitting estimate 215 280 !----------------------------------------------------- 216 IF ( ln_dynspg_ts) THEN 217 zvb(nlci-1,:)=0._wp 218 DO jk=1,jpkm1 219 DO jj=1,jpj 220 zvb(nlci-1,jj) = zvb(nlci-1,jj) + fse3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk) 221 END DO 222 END DO 223 DO jj=1,jpj 224 zvb(nlci-1,jj) = zvb(nlci-1,jj) * hvr_a(nlci-1,jj) 225 END DO 226 DO jk=1,jpkm1 227 DO jj=1,jpj 228 va(nlci-1,jj,jk) = (va(nlci-1,jj,jk)+va_b(nlci-1,jj)-zvb(nlci-1,jj))*vmask(nlci-1,jj,jk) 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) 229 295 END DO 230 296 END DO … … 233 299 ! Mask domain edges: 234 300 !------------------- 235 DO jk =1,jpkm1236 DO j j=1,jpj237 ua( nlci-1,jj,jk) = 0._wp238 va( nlci ,jj,jk) = 0._wp301 DO jk = 1, jpkm1 302 DO ji = 1, jpi 303 ua(ji,1,jk) = 0._wp 304 va(ji,1,jk) = 0._wp 239 305 END DO 240 306 END DO … … 242 308 ENDIF 243 309 244 IF( (nbondj == -1).OR.(nbondj == 2)) THEN245 310 IF( nbondj == 1 .OR. nbondj == 2 ) THEN 311 ! 246 312 ! Smoothing 247 313 ! --------- 248 IF ( .NOT.ln_dynspg_ts ) THEN! Store transport249 va_b(:, 2)=0._wp250 DO jk =1,jpkm1251 DO ji =1,jpi252 va_b(ji, 2) = va_b(ji,2) + fse3v_a(ji,2,jk) * va(ji,2,jk)253 END DO 254 END DO 255 DO ji =1,jpi256 va_b(ji, 2) = va_b(ji,2) * hvr_a(ji,2)257 END DO 258 ENDIF 259 260 DO jk =1,jpkm1! Smooth261 DO ji =i1,i2262 va(ji, 2,jk)=0.25_wp*(va(ji,1,jk)+2._wp*va(ji,2,jk)+va(ji,3,jk))263 va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk)264 END DO 265 END DO 266 267 zvb(:, 2)=0._wp! Correct transport268 DO jk =1,jpkm1269 DO ji =1,jpi270 zvb(ji, 2) = zvb(ji,2) + fse3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk)271 END DO 272 END DO 273 DO ji =1,jpi274 zvb(ji, 2) = zvb(ji,2) * hvr_a(ji,2)275 END DO 276 DO jk =1,jpkm1277 DO ji =1,jpi278 va(ji, 2,jk) = (va(ji,2,jk)+va_b(ji,2)-zvb(ji,2))*vmask(ji,2,jk)279 END DO 280 END DO 281 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 ! 282 348 ! Set tangential velocities to time splitting estimate 283 349 !----------------------------------------------------- 284 IF 285 zub(:, 2)=0._wp286 DO jk =1,jpkm1287 DO ji =1,jpi288 zub(ji, 2) = zub(ji,2) + fse3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk)289 END DO 290 END DO 291 DO ji =1,jpi292 zub(ji, 2) = zub(ji,2) * hur_a(ji,2)293 END DO 294 295 DO jk =1,jpkm1296 DO ji =1,jpi297 ua(ji, 2,jk) = (ua(ji,2,jk)+ua_b(ji,2)-zub(ji,2))*umask(ji,2,jk)298 END DO 299 END DO 300 ENDIF 301 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 ! 302 368 ! Mask domain edges: 303 369 !------------------- 304 DO jk=1,jpkm1 305 DO ji=1,jpi 306 ua(ji,1,jk) = 0._wp 307 va(ji,1,jk) = 0._wp 308 END DO 309 END DO 310 311 ENDIF 312 313 IF((nbondj == 1).OR.(nbondj == 2)) THEN 314 ! Smoothing 315 ! --------- 316 IF ( .NOT.ln_dynspg_ts ) THEN ! Store transport 317 va_b(:,nlcj-2)=0._wp 318 DO jk=1,jpkm1 319 DO ji=1,jpi 320 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + fse3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) 321 END DO 322 END DO 323 DO ji=1,jpi 324 va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * hvr_a(ji,nlcj-2) 325 END DO 326 ENDIF 327 328 DO jk=1,jpkm1 ! Smooth 329 DO ji=i1,i2 330 va(ji,nlcj-2,jk)=0.25_wp*(va(ji,nlcj-3,jk)+2._wp*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 331 va(ji,nlcj-2,jk)=va(ji,nlcj-2,jk)*vmask(ji,nlcj-2,jk) 332 END DO 333 END DO 334 335 zvb(:,nlcj-2)=0._wp ! Correct transport 336 DO jk=1,jpkm1 337 DO ji=1,jpi 338 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + fse3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 339 END DO 340 END DO 341 DO ji=1,jpi 342 zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * hvr_a(ji,nlcj-2) 343 END DO 344 DO jk=1,jpkm1 345 DO ji=1,jpi 346 va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+va_b(ji,nlcj-2)-zvb(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 347 END DO 348 END DO 349 350 ! Set tangential velocities to time splitting estimate 351 !----------------------------------------------------- 352 IF ( ln_dynspg_ts ) THEN 353 zub(:,nlcj-1)=0._wp 354 DO jk=1,jpkm1 355 DO ji=1,jpi 356 zub(ji,nlcj-1) = zub(ji,nlcj-1) + fse3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk) 357 END DO 358 END DO 359 DO ji=1,jpi 360 zub(ji,nlcj-1) = zub(ji,nlcj-1) * hur_a(ji,nlcj-1) 361 END DO 362 363 DO jk=1,jpkm1 364 DO ji=1,jpi 365 ua(ji,nlcj-1,jk) = (ua(ji,nlcj-1,jk)+ua_b(ji,nlcj-1)-zub(ji,nlcj-1))*umask(ji,nlcj-1,jk) 366 END DO 367 END DO 368 ENDIF 369 370 ! Mask domain edges: 371 !------------------- 372 DO jk=1,jpkm1 373 DO ji=1,jpi 370 DO jk = 1, jpkm1 371 DO ji = 1, jpi 374 372 ua(ji,nlcj ,jk) = 0._wp 375 373 va(ji,nlcj-1,jk) = 0._wp 376 374 END DO 377 375 END DO 378 379 ENDIF 380 ! 381 CALL wrk_dealloc( jpi, jpj,zub, zvb )376 ! 377 ENDIF 378 ! 379 CALL wrk_dealloc( jpi,jpj, zub, zvb ) 382 380 ! 383 381 END SUBROUTINE Agrif_dyn 382 384 383 385 384 SUBROUTINE Agrif_dyn_ts( jn ) … … 392 391 INTEGER :: ji, jj 393 392 !!---------------------------------------------------------------------- 394 393 ! 395 394 IF( Agrif_Root() ) RETURN 396 395 ! 397 396 IF((nbondi == -1).OR.(nbondi == 2)) THEN 398 397 DO jj=1,jpj … … 405 404 END DO 406 405 ENDIF 407 406 ! 408 407 IF((nbondi == 1).OR.(nbondi == 2)) THEN 409 408 DO jj=1,jpj … … 416 415 END DO 417 416 ENDIF 418 417 ! 419 418 IF((nbondj == -1).OR.(nbondj == 2)) THEN 420 419 DO ji=1,jpi … … 427 426 END DO 428 427 ENDIF 429 428 ! 430 429 IF((nbondj == 1).OR.(nbondj == 2)) THEN 431 430 DO ji=1,jpi … … 441 440 END SUBROUTINE Agrif_dyn_ts 442 441 442 443 443 SUBROUTINE Agrif_dta_ts( kt ) 444 444 !!---------------------------------------------------------------------- … … 452 452 REAL(wp) :: zrhot, zt 453 453 !!---------------------------------------------------------------------- 454 454 ! 455 455 IF( Agrif_Root() ) RETURN 456 457 ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 458 ! the forward case only 459 456 ! 457 ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only 458 ! 460 459 zrhot = Agrif_rhot() 461 460 ! 462 461 ! "Central" time index for interpolation: 463 IF (ln_bt_fw) THEN464 zt = REAL( Agrif_NbStepint()+0.5_wp,wp) / zrhot462 IF( ln_bt_fw ) THEN 463 zt = REAL( Agrif_NbStepint()+0.5_wp, wp ) / zrhot 465 464 ELSE 466 zt = REAL( Agrif_NbStepint(),wp) / zrhot467 ENDIF 468 465 zt = REAL( Agrif_NbStepint() , wp ) / zrhot 466 ENDIF 467 ! 469 468 ! Linear interpolation of sea level 470 Agrif_SpecialValue = 0. e0469 Agrif_SpecialValue = 0._wp 471 470 Agrif_UseSpecialValue = .TRUE. 472 CALL Agrif_Bc_variable( sshn_id,calledweight=zt, procname=interpsshn )471 CALL Agrif_Bc_variable( sshn_id, calledweight=zt, procname=interpsshn ) 473 472 Agrif_UseSpecialValue = .FALSE. 474 473 ! 475 474 ! Interpolate barotropic fluxes 476 475 Agrif_SpecialValue=0. 477 476 Agrif_UseSpecialValue = ln_spc_dyn 478 479 IF (ll_int_cons) THEN! Conservative interpolation477 ! 478 IF( ll_int_cons ) THEN ! Conservative interpolation 480 479 ! orders matters here !!!!!! 481 CALL Agrif_Bc_variable( ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated482 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 ) 483 482 bdy_tinterp = 1 484 CALL Agrif_Bc_variable( unb_id ,calledweight=1._wp, procname=interpunb) ! After485 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 ) 486 485 bdy_tinterp = 2 487 CALL Agrif_Bc_variable( unb_id ,calledweight=0._wp, procname=interpunb) ! Before488 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 ) 489 488 ELSE ! Linear interpolation 490 489 bdy_tinterp = 0 491 ubdy_w(:) = 0. e0 ; vbdy_w(:) = 0.e0492 ubdy_e(:) = 0. e0 ; vbdy_e(:) = 0.e0493 ubdy_n(:) = 0. e0 ; vbdy_n(:) = 0.e0494 ubdy_s(:) = 0. e0 ; vbdy_s(:) = 0.e0495 CALL Agrif_Bc_variable( unb_id,calledweight=zt, procname=interpunb)496 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 ) 497 496 ENDIF 498 497 Agrif_UseSpecialValue = .FALSE. … … 500 499 END SUBROUTINE Agrif_dta_ts 501 500 501 502 502 SUBROUTINE Agrif_ssh( kt ) 503 503 !!---------------------------------------------------------------------- … … 507 507 !! 508 508 !!---------------------------------------------------------------------- 509 509 ! 510 510 IF( Agrif_Root() ) RETURN 511 511 ! 512 512 IF((nbondi == -1).OR.(nbondi == 2)) THEN 513 513 ssha(2,:)=ssha(3,:) 514 514 sshn(2,:)=sshn(3,:) 515 515 ENDIF 516 516 ! 517 517 IF((nbondi == 1).OR.(nbondi == 2)) THEN 518 518 ssha(nlci-1,:)=ssha(nlci-2,:) 519 519 sshn(nlci-1,:)=sshn(nlci-2,:) 520 520 ENDIF 521 521 ! 522 522 IF((nbondj == -1).OR.(nbondj == 2)) THEN 523 523 ssha(:,2)=ssha(:,3) 524 524 sshn(:,2)=sshn(:,3) 525 525 ENDIF 526 526 ! 527 527 IF((nbondj == 1).OR.(nbondj == 2)) THEN 528 528 ssha(:,nlcj-1)=ssha(:,nlcj-2) 529 529 sshn(:,nlcj-1)=sshn(:,nlcj-2) 530 530 ENDIF 531 531 ! 532 532 END SUBROUTINE Agrif_ssh 533 533 534 534 535 SUBROUTINE Agrif_ssh_ts( jn ) … … 540 541 INTEGER :: ji,jj 541 542 !!---------------------------------------------------------------------- 542 543 ! 543 544 IF((nbondi == -1).OR.(nbondi == 2)) THEN 544 DO jj =1,jpj545 DO jj = 1, jpj 545 546 ssha_e(2,jj) = hbdy_w(jj) 546 547 END DO 547 548 ENDIF 548 549 ! 549 550 IF((nbondi == 1).OR.(nbondi == 2)) THEN 550 DO jj =1,jpj551 DO jj = 1, jpj 551 552 ssha_e(nlci-1,jj) = hbdy_e(jj) 552 553 END DO 553 554 ENDIF 554 555 ! 555 556 IF((nbondj == -1).OR.(nbondj == 2)) THEN 556 DO ji =1,jpi557 DO ji = 1, jpi 557 558 ssha_e(ji,2) = hbdy_s(ji) 558 559 END DO 559 560 ENDIF 560 561 ! 561 562 IF((nbondj == 1).OR.(nbondj == 2)) THEN 562 DO ji =1,jpi563 DO ji = 1, jpi 563 564 ssha_e(ji,nlcj-1) = hbdy_n(ji) 564 565 END DO 565 566 ENDIF 566 567 ! 567 568 END SUBROUTINE Agrif_ssh_ts 568 569 569 570 # if defined key_zdftke 571 570 572 SUBROUTINE Agrif_tke 571 573 !!---------------------------------------------------------------------- … … 573 575 !!---------------------------------------------------------------------- 574 576 REAL(wp) :: zalpha 577 !!---------------------------------------------------------------------- 575 578 ! 576 579 zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 577 580 IF( zalpha > 1. ) zalpha = 1. 578 581 ! 579 582 Agrif_SpecialValue = 0.e0 580 583 Agrif_UseSpecialValue = .TRUE. 581 584 ! 582 585 CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm) 583 586 ! 584 587 Agrif_UseSpecialValue = .FALSE. 585 588 ! 586 589 END SUBROUTINE Agrif_tke 590 587 591 # endif 588 592 589 SUBROUTINE interptsn( ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir)590 !!--------------------------------------------- 593 SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 594 !!---------------------------------------------------------------------- 591 595 !! *** ROUTINE interptsn *** 592 !!--------------------------------------------- 593 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab594 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2595 LOGICAL , INTENT(in) ::before596 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 597 601 ! 598 602 INTEGER :: ji, jj, jk, jn ! dummy loop indices 599 INTEGER ::imin, imax, jmin, jmax603 INTEGER :: imin, imax, jmin, jmax 600 604 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 601 605 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 602 LOGICAL :: western_side, eastern_side,northern_side,southern_side 603 606 LOGICAL :: western_side, eastern_side,northern_side,southern_side 607 !!---------------------------------------------------------------------- 608 ! 604 609 IF (before) THEN 605 610 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) … … 634 639 IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2 635 640 ! 636 IF( eastern_side ) THEN641 IF( eastern_side ) THEN 637 642 DO jn = 1, jpts 638 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) 639 644 DO jk = 1, jpkm1 640 645 DO jj = jmin,jmax 641 IF( umask(nlci-2,jj,jk) == 0. e0) THEN646 IF( umask(nlci-2,jj,jk) == 0._wp ) THEN 642 647 tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 643 648 ELSE 644 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) 645 IF( un(nlci-2,jj,jk) > 0. e0) THEN650 IF( un(nlci-2,jj,jk) > 0._wp ) THEN 646 651 tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 647 652 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) … … 651 656 END DO 652 657 tsa(nlci,j1:j2,k1:k2,jn) = 0._wp 653 END DO658 END DO 654 659 ENDIF 655 660 ! … … 659 664 DO jk = 1, jpkm1 660 665 DO ji = imin,imax 661 IF( vmask(ji,nlcj-2,jk) == 0. e0) THEN666 IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN 662 667 tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 663 668 ELSE 664 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) 665 IF (vn(ji,nlcj-2,jk) > 0. e0) THEN670 IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN 666 671 tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn) & 667 672 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) … … 671 676 END DO 672 677 tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp 673 END DO674 ENDIF 675 ! 676 IF( western_side ) THEN678 END DO 679 ENDIF 680 ! 681 IF( western_side ) THEN 677 682 DO jn = 1, jpts 678 683 tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 679 684 DO jk = 1, jpkm1 680 685 DO jj = jmin,jmax 681 IF( umask(2,jj,jk) == 0. e0) THEN686 IF( umask(2,jj,jk) == 0._wp ) THEN 682 687 tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 683 688 ELSE 684 689 tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk) 685 IF( un(2,jj,jk) < 0. e0) THEN690 IF( un(2,jj,jk) < 0._wp ) THEN 686 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) 687 692 ENDIF … … 696 701 DO jn = 1, jpts 697 702 tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 698 DO jk =1,jpk703 DO jk = 1, jpk 699 704 DO ji=imin,imax 700 IF( vmask(ji,2,jk) == 0. e0) THEN705 IF( vmask(ji,2,jk) == 0._wp ) THEN 701 706 tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 702 707 ELSE 703 708 tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 704 IF( vn(ji,2,jk) < 0. e0) THEN709 IF( vn(ji,2,jk) < 0._wp ) THEN 705 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) 706 711 ENDIF … … 709 714 END DO 710 715 tsa(i1:i2,1,k1:k2,jn) = 0._wp 711 END DO716 END DO 712 717 ENDIF 713 718 ! … … 735 740 END SUBROUTINE interptsn 736 741 737 SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 742 743 SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir ) 738 744 !!---------------------------------------------------------------------- 739 745 !! *** ROUTINE interpsshn *** 740 746 !!---------------------------------------------------------------------- 741 INTEGER, INTENT(in) :: i1,i2,j1,j2 742 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 743 LOGICAL, INTENT(in) :: before 744 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 ! 745 752 LOGICAL :: western_side, eastern_side,northern_side,southern_side 746 753 !!---------------------------------------------------------------------- … … 761 768 END SUBROUTINE interpsshn 762 769 763 SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2, before) 764 !!--------------------------------------------- 770 771 SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, before ) 772 !!---------------------------------------------------------------------- 765 773 !! *** ROUTINE interpun *** 766 !!--------------------------------------------- 767 !! 768 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 769 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 770 LOGICAL, INTENT(in) :: before 771 !! 772 INTEGER :: ji,jj,jk 773 REAL(wp) :: zrhoy 774 !!--------------------------------------------- 775 ! 776 IF (before) THEN 777 DO jk=1,jpk 778 DO jj=j1,j2 779 DO ji=i1,i2 780 ptab(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 781 ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3u(ji,jj,jk) 782 END DO 783 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) 784 786 END DO 785 787 ELSE 786 788 zrhoy = Agrif_Rhoy() 787 DO jk =1,jpkm1789 DO jk = 1, jpkm1 788 790 DO jj=j1,j2 789 ua(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) 790 ua(i1:i2,jj,jk) = ua(i1:i2,jj,jk) / fse3u(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) ) 791 792 END DO 792 793 END DO … … 795 796 END SUBROUTINE interpun 796 797 797 SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 798 !!--------------------------------------------- 798 799 SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, before ) 800 !!---------------------------------------------------------------------- 799 801 !! *** ROUTINE interpvn *** 800 !!--------------------------------------------- 801 ! 802 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 803 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 804 LOGICAL, INTENT(in) :: before 805 ! 806 INTEGER :: ji,jj,jk 807 REAL(wp) :: zrhox 808 !!--------------------------------------------- 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 !!---------------------------------------------------------------------- 809 810 ! 810 IF (before) THEN 811 !interpv entre 1 et k2 et interpv2d en jpkp1 812 DO jk=k1,jpk 813 DO jj=j1,j2 814 DO ji=i1,i2 815 ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 816 ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 817 END DO 818 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) 819 814 END DO 820 815 ELSE 821 816 zrhox= Agrif_Rhox() 822 DO jk=1,jpkm1 823 DO jj=j1,j2 824 va(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj))) 825 va(i1:i2,jj,jk) = va(i1:i2,jj,jk) / fse3v(i1:i2,jj,jk) 826 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) ) 827 819 END DO 828 820 ENDIF 829 821 ! 830 822 END SUBROUTINE interpvn 831 832 SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 823 824 825 SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir ) 833 826 !!---------------------------------------------------------------------- 834 827 !! *** ROUTINE interpunb *** 835 828 !!---------------------------------------------------------------------- 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 INTEGER, INTENT(in) :: nb , ndir 840 !! 841 INTEGER :: ji,jj 842 REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 843 LOGICAL :: western_side, eastern_side,northern_side,southern_side 844 !!---------------------------------------------------------------------- 845 ! 846 IF (before) THEN 847 DO jj=j1,j2 848 DO ji=i1,i2 849 ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj) 850 END DO 851 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) 852 841 ELSE 853 842 western_side = (nb == 1).AND.(ndir == 1) … … 863 852 IF( bdy_tinterp == 1 ) THEN 864 853 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 865 &- zt0**2._wp * ( zt0 - 1._wp) )854 & - zt0**2._wp * ( zt0 - 1._wp) ) 866 855 ELSEIF( bdy_tinterp == 2 ) THEN 867 856 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 868 &- zt0 * ( zt0 - 1._wp)**2._wp )857 & - zt0 * ( zt0 - 1._wp)**2._wp ) 869 858 870 859 ELSE … … 887 876 IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 888 877 IF(western_side) THEN 889 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 890 & * umask(i1,j1:j2,1) 878 ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 891 879 ENDIF 892 880 IF(eastern_side) THEN 893 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) & 894 & * umask(i1,j1:j2,1) 881 ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1) 895 882 ENDIF 896 883 IF(southern_side) THEN 897 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 898 & * umask(i1:i2,j1,1) 884 ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 899 885 ENDIF 900 886 IF(northern_side) THEN 901 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) & 902 & * umask(i1:i2,j1,1) 887 ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1) 903 888 ENDIF 904 889 ENDIF … … 907 892 END SUBROUTINE interpunb 908 893 909 SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 894 895 SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir ) 910 896 !!---------------------------------------------------------------------- 911 897 !! *** ROUTINE interpvnb *** 912 898 !!---------------------------------------------------------------------- 913 INTEGER , INTENT(in) :: i1,i2,j1,j2914 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab915 LOGICAL , INTENT(in) ::before916 INTEGER , INTENT(in) ::nb , ndir917 ! !918 INTEGER ::ji,jj919 REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff920 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 921 907 !!---------------------------------------------------------------------- 922 908 ! 923 IF (before) THEN 924 DO jj=j1,j2 925 DO ji=i1,i2 926 ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 927 END DO 928 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) 929 911 ELSE 930 912 western_side = (nb == 1).AND.(ndir == 1) … … 939 921 IF( bdy_tinterp == 1 ) THEN 940 922 ztcoeff = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 941 &- zt0**2._wp * ( zt0 - 1._wp) )923 & - zt0**2._wp * ( zt0 - 1._wp) ) 942 924 ELSEIF( bdy_tinterp == 2 ) THEN 943 925 ztcoeff = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 944 & - zt0 * ( zt0 - 1._wp)**2._wp ) 945 926 & - zt0 * ( zt0 - 1._wp)**2._wp ) 946 927 ELSE 947 928 ztcoeff = 1 … … 983 964 END SUBROUTINE interpvnb 984 965 985 SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 966 967 SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir ) 986 968 !!---------------------------------------------------------------------- 987 969 !! *** ROUTINE interpub2b *** 988 970 !!---------------------------------------------------------------------- 989 INTEGER , INTENT(in) :: i1,i2,j1,j2990 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab991 LOGICAL , INTENT(in) ::before992 INTEGER , INTENT(in) ::nb , ndir993 ! !994 INTEGER ::ji,jj995 REAL(wp) :: zrhot, zt0, zt1,zat996 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 997 979 !!---------------------------------------------------------------------- 998 980 IF( before ) THEN 999 DO jj=j1,j2 1000 DO ji=i1,i2 1001 ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 1002 END DO 1003 END DO 981 ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2) 1004 982 ELSE 1005 983 western_side = (nb == 1).AND.(ndir == 1) … … 1012 990 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1013 991 ! Polynomial interpolation coefficients: 1014 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) 1015 & - 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) ) 1016 994 ! 1017 995 IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2) … … 1022 1000 ! 1023 1001 END SUBROUTINE interpub2b 1024 1025 SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 1002 1003 1004 SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir ) 1026 1005 !!---------------------------------------------------------------------- 1027 1006 !! *** ROUTINE interpvb2b *** 1028 1007 !!---------------------------------------------------------------------- 1029 INTEGER , INTENT(in) :: i1,i2,j1,j21030 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab1031 LOGICAL , INTENT(in) ::before1032 INTEGER , INTENT(in) ::nb , ndir1033 ! !1034 INTEGER :: ji,jj1035 REAL(wp) :: zrhot, zt0, zt1,zat1036 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 1037 1016 !!---------------------------------------------------------------------- 1038 1017 ! 1039 1018 IF( before ) THEN 1040 DO jj=j1,j2 1041 DO ji=i1,i2 1042 ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 1043 END DO 1044 END DO 1019 ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2) 1045 1020 ELSE 1046 1021 western_side = (nb == 1).AND.(ndir == 1) … … 1053 1028 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 1054 1029 ! Polynomial interpolation coefficients: 1055 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) 1056 & - zt0**2._wp * (-2._wp*zt0 + 3._wp))1057 ! 1058 IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)1059 IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)1060 IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)1061 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) 1062 1037 ENDIF 1063 1038 ! 1064 1039 END SUBROUTINE interpvb2b 1065 1040 1066 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 ) 1067 1043 !!---------------------------------------------------------------------- 1068 1044 !! *** ROUTINE interpe3t *** 1069 1045 !!---------------------------------------------------------------------- 1070 ! 1071 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1046 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 1072 1047 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1073 LOGICAL :: before1074 INTEGER , INTENT(in) :: nb , ndir1048 LOGICAL , INTENT(in ) :: before 1049 INTEGER , INTENT(in ) :: nb , ndir 1075 1050 ! 1076 1051 INTEGER :: ji, jj, jk … … 1079 1054 !!---------------------------------------------------------------------- 1080 1055 ! 1081 IF (before) THEN 1082 DO jk=k1,k2 1083 DO jj=j1,j2 1084 DO ji=i1,i2 1085 ptab(ji,jj,jk) = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 1086 END DO 1087 END DO 1088 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) 1089 1058 ELSE 1090 1059 western_side = (nb == 1).AND.(ndir == 1) … … 1093 1062 northern_side = (nb == 2).AND.(ndir == 2) 1094 1063 1095 DO jk =k1,k21096 DO jj =j1,j21097 DO ji =i1,i21064 DO jk = k1, k2 1065 DO jj = j1, j2 1066 DO ji = i1, i2 1098 1067 ! Get velocity mask at boundary edge points: 1099 IF (western_side)ztmpmsk = umask(ji ,jj ,1)1100 IF (eastern_side)ztmpmsk = umask(nlci-2,jj ,1)1101 IF (northern_side)ztmpmsk = vmask(ji ,nlcj-2,1)1102 IF (southern_side)ztmpmsk = vmask(ji ,2 ,1)1103 1104 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 1105 1074 IF (western_side) THEN 1106 1075 WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk … … 1112 1081 WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 1113 1082 ENDIF 1114 WRITE(numout,*) ' ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)1083 WRITE(numout,*) ' ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk) 1115 1084 kindic_agr = kindic_agr + 1 1116 1085 ENDIF … … 1118 1087 END DO 1119 1088 END DO 1120 1089 ! 1121 1090 ENDIF 1122 1091 ! 1123 1092 END SUBROUTINE interpe3t 1124 1093 1125 SUBROUTINE interpumsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 1094 1095 SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 1126 1096 !!---------------------------------------------------------------------- 1127 1097 !! *** ROUTINE interpumsk *** 1128 1098 !!---------------------------------------------------------------------- 1129 ! 1130 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1131 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1132 LOGICAL :: before 1133 INTEGER, INTENT(in) :: nb , ndir 1134 ! 1135 INTEGER :: ji, jj, jk 1136 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 1137 1106 !!---------------------------------------------------------------------- 1138 1107 ! 1139 IF (before) THEN 1140 DO jk=k1,k2 1141 DO jj=j1,j2 1142 DO ji=i1,i2 1143 ptab(ji,jj,jk) = umask(ji,jj,jk) 1144 END DO 1145 END DO 1146 END DO 1108 IF( before ) THEN 1109 ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2) 1147 1110 ELSE 1148 1149 western_side = (nb == 1).AND.(ndir == 1) 1150 eastern_side = (nb == 1).AND.(ndir == 2) 1151 DO jk=k1,k2 1152 DO jj=j1,j2 1153 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 1154 1116 ! Velocity mask at boundary edge points: 1155 1117 IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN … … 1167 1129 END DO 1168 1130 END DO 1169 1131 ! 1170 1132 ENDIF 1171 1133 ! 1172 1134 END SUBROUTINE interpumsk 1173 1135 1174 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 ) 1175 1138 !!---------------------------------------------------------------------- 1176 1139 !! *** ROUTINE interpvmsk *** 1177 1140 !!---------------------------------------------------------------------- 1178 ! 1179 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 1180 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 1181 LOGICAL :: before 1182 INTEGER, INTENT(in) :: nb , ndir 1183 ! 1184 INTEGER :: ji, jj, jk 1185 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 1186 1148 !!---------------------------------------------------------------------- 1187 1149 ! 1188 IF (before) THEN 1189 DO jk=k1,k2 1190 DO jj=j1,j2 1191 DO ji=i1,i2 1192 ptab(ji,jj,jk) = vmask(ji,jj,jk) 1193 END DO 1194 END DO 1195 END DO 1150 IF( before ) THEN 1151 ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2) 1196 1152 ELSE 1197 1198 1153 southern_side = (nb == 2).AND.(ndir == 1) 1199 1154 northern_side = (nb == 2).AND.(ndir == 2) 1200 DO jk =k1,k21201 DO jj =j1,j21202 DO ji =i1,i21155 DO jk = k1, k2 1156 DO jj = j1, j2 1157 DO ji = i1, i2 1203 1158 ! Velocity mask at boundary edge points: 1204 1159 IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN … … 1216 1171 END DO 1217 1172 END DO 1218 1173 ! 1219 1174 ENDIF 1220 1175 ! … … 1223 1178 # if defined key_zdftke 1224 1179 1225 SUBROUTINE interpavm( ptab,i1,i2,j1,j2,k1,k2,before)1180 SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before ) 1226 1181 !!---------------------------------------------------------------------- 1227 1182 !! *** ROUTINE interavm *** 1228 1183 !!---------------------------------------------------------------------- 1229 INTEGER , INTENT(in) :: i1,i2,j1,j2,k1,k21230 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab1231 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 1232 1187 !!---------------------------------------------------------------------- 1233 1188 ! 1234 IF( before ) THEN1189 IF( before ) THEN 1235 1190 ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 1236 1191 ELSE
Note: See TracChangeset
for help on using the changeset viewer.