- Timestamp:
- 2013-10-15T19:54:10+02:00 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_r3940_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90
r4015 r4064 51 51 END INTERFACE 52 52 53 REAL(wp) :: r_inf = 1e+36 54 53 55 !! Substitutions 54 56 # include "domzgr_substitute.h90" … … 60 62 61 63 INTEGER :: ji, jj, jk ! dummy loop indices 62 INTEGER :: ijie,ijis,ijje,ijjs 64 INTEGER :: ijie,ijis,ijje,ijjs,ij,je_2 63 65 REAL(wp) :: zmask 64 66 … … 69 71 umask_crs(:,:,:) = 0.0 70 72 fmask_crs(:,:,:) = 0.0 71 73 74 75 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 76 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 77 je_2 = mje_crs(2) ; ij = je_2 78 ENDIF 79 ELSE 80 je_2 = mje_crs(2) ; ij = mjs_crs(2) 81 ENDIF 72 82 DO jk = 1, jpkm1 73 83 DO ji = 2, nlei_crs 74 ijie = mie_crs(ji) 75 ijis = mis_crs(ji) 76 DO jj = nldj_crs, nlej_crs 77 ijje = mje_crs(jj) 78 ijjs = mjs_crs(jj) 79 84 ijis = mis_crs(ji) ; ijie = mie_crs(ji) 85 ! 86 zmask = 0.0 87 zmask = SUM( tmask(ijis:ijie,ij:je_2,jk) ) 88 IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0 89 90 zmask = 0.0 91 zmask = SUM( vmask(ijis:ijie,je_2 ,jk) ) 92 IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0 93 94 zmask = 0.0 95 zmask = SUM(umask(ijie,ij:je_2,jk)) 96 IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0 97 98 fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk) 99 ENDDO 100 ENDDO 101 ! 102 DO jk = 1, jpkm1 103 DO ji = 2, nlei_crs 104 ijis = mis_crs(ji) ; ijie = mie_crs(ji) 105 DO jj = 3, nlej_crs 106 ijjs = mjs_crs(jj) ; ijje = mje_crs(jj) 107 80 108 zmask = 0.0 81 109 zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) … … 91 119 92 120 fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) 93 94 121 ENDDO 95 122 ENDDO 96 123 ENDDO 124 97 125 ! 98 126 CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 ) … … 195 223 ENDDO 196 224 END SELECT 197 198 ! ! Fill i=1, i=jpi at j=1 199 p_gphi_crs(1 ,1) = p_gphi(jpi_crsm1,1) 200 p_glam_crs(1 ,1) = p_glam(jpi_crsm1,1) 201 ! ! Fill upper-right corner i=1, j=jpj_crs 202 p_gphi_crs(jpi_crs,1) = p_gphi(2 ,1) 203 p_glam_crs(jpi_crs,1) = p_glam(2 ,1) 204 ! 225 ! 205 226 END SUBROUTINE crs_dom_coordinates 206 227 … … 233 254 !! Local variables 234 255 INTEGER :: ji, jj, jk ! dummy loop indices 235 INTEGER :: ijie,ij is,ijje,ijjs,ijrs256 INTEGER :: ijie,ijje,ijrs 236 257 237 258 !!---------------------------------------------------------------- … … 241 262 DO ji = 2, nlei_crs 242 263 ijie = mie_crs(ji) 243 ijis = mis_crs(ji)244 264 DO jj = nldj_crs, nlej_crs 245 ijje = mje_crs(jj) 246 ijjs = mjs_crs(jj) 247 ijrs = mje_crs(jj) - mjs_crs(jj) 265 ijje = mje_crs(jj) ; ijrs = mje_crs(jj) - mjs_crs(jj) 248 266 ! Only for a factro 3 coarsening 249 267 SELECT CASE ( cd_type ) … … 335 353 !! Local variables 336 354 REAL(wp) :: zdAm 337 INTEGER :: ji, jj, jk ! dummy loop indices 338 INTEGER :: ii, ij, ijie,ijje 339 340 REAL(wp), DIMENSION(:,:,:), POINTER :: zvol 355 INTEGER :: ji, jj, jk , ii, ij, je_2 356 357 REAL(wp), DIMENSION(:,:,:), POINTER :: zvol, zmask 341 358 !!---------------------------------------------------------------- 342 359 343 CALL wrk_alloc( jpi, jpj, jpk, zvol ) 360 CALL wrk_alloc( jpi, jpj, jpk, zvol, zmask ) 361 362 p_fld1_crs(:,:,:) = 0.0 363 p_fld2_crs(:,:,:) = 0.0 344 364 345 365 DO jk = 1, jpk … … 347 367 ENDDO 348 368 369 zmask(:,:,:) = 0.0 370 IF( cd_type == 'W' ) THEN 371 zmask(:,:,1) = p_mask(:,:,1) 372 DO jk = 2, jpk 373 zmask(:,:,jk) = p_mask(:,:,jk-1) 374 ENDDO 375 ELSE 376 DO jk = 1, jpk 377 zmask(:,:,jk) = p_mask(:,:,jk) 378 ENDDO 379 ENDIF 380 381 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 382 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 383 je_2 = mje_crs(2) 384 DO jk = 1, jpk 385 DO ji = nistr, niend, nn_factx 386 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 387 p_fld1_crs(ii,2,jk) = zvol(ji,je_2 ,jk) + zvol(ji+1,je_2 ,jk) + zvol(ji+2,je_2 ,jk) & 388 & + zvol(ji,je_2-1,jk) + zvol(ji+1,je_2-1,jk) + zvol(ji+2,je_2-1,jk) 389 ! 390 zdAm = zvol(ji ,je_2,jk) * zmask(ji ,je_2,jk) & 391 & + zvol(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) & 392 & + zvol(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) 393 ! 394 p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) 395 ENDDO 396 ENDDO 397 ENDIF 398 ELSE 399 je_2 = mjs_crs(2) 400 DO jk = 1, jpk 401 DO ji = nistr, niend, nn_factx 402 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 403 p_fld1_crs(ii,2,jk) = zvol(ji,je_2 ,jk) + zvol(ji+1,je_2 ,jk) + zvol(ji+2,je_2 ,jk) & 404 & + zvol(ji,je_2+1,jk) + zvol(ji+1,je_2+1,jk) + zvol(ji+2,je_2+1,jk) & 405 & + zvol(ji,je_2+2,jk) + zvol(ji+1,je_2+2,jk) + zvol(ji+2,je_2+2,jk) 406 ! 407 zdAm = zvol(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) & 408 & + zvol(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) & 409 & + zvol(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) & 410 & + zvol(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) & 411 & + zvol(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) & 412 & + zvol(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) & 413 & + zvol(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) & 414 & + zvol(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) & 415 & + zvol(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) 416 ! 417 p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) 418 ENDDO 419 ENDDO 420 ENDIF 421 349 422 DO jk = 1, jpk 350 DO ji = nistr, niend, nn_factx 351 DO jj = njstr, njend, nn_facty 352 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 353 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 354 ijje = mje_crs(ij) 355 ijie = mie_crs(ii) 423 DO jj = njstr, njend, nn_facty 424 DO ji = nistr, niend, nn_factx 425 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 426 ij = ( jj - njstr ) * rfacty_r + 3 356 427 ! 357 428 p_fld1_crs(ii,ij,jk) = zvol(ji,jj ,jk) + zvol(ji+1,jj ,jk) + zvol(ji+2,jj ,jk) & 358 429 & + zvol(ji,jj+1,jk) + zvol(ji+1,jj+1,jk) + zvol(ji+2,jj+1,jk) & 359 & + zvol(ji,jj+2,jk) + zvol(ji+1,jj+2,jk) + zvol(ji+2,jj+2,jk) 430 & + zvol(ji,jj+2,jk) + zvol(ji+1,jj+2,jk) + zvol(ji+2,jj+2,jk) 431 ! 432 zdAm = zvol(ji ,jj ,jk) * zmask(ji ,jj ,jk) & 433 & + zvol(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) & 434 & + zvol(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) & 435 & + zvol(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) & 436 & + zvol(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) & 437 & + zvol(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) & 438 & + zvol(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) & 439 & + zvol(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) & 440 & + zvol(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) 441 ! 442 p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk) 360 443 ENDDO 361 444 ENDDO 362 445 ENDDO 363 364 IF( cd_type == 'T' ) THEN365 DO jk = 1, jpk366 DO ji = nistr, niend, nn_factx367 DO jj = njstr, njend, nn_facty368 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid369 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2370 ijje = mje_crs(ij)371 ijie = mie_crs(ii)372 !373 zdAm = zvol(ji ,jj ,jk) * p_mask(ji ,jj ,jk) &374 & + zvol(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk) &375 & + zvol(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk) &376 & + zvol(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk) &377 & + zvol(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk) &378 & + zvol(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk) &379 & + zvol(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk) &380 & + zvol(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk) &381 & + zvol(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk)382 !383 IF( p_fld1_crs(ii,ij,jk) /= 0._wp ) p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk)384 !385 ENDDO386 ENDDO387 ENDDO388 ENDIF389 !390 IF( cd_type == 'W' ) THEN391 DO jk = 2, jpk392 DO ji = nistr, niend, nn_factx393 DO jj = njstr, njend, nn_facty394 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid395 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2396 ijje = mje_crs(ij)397 ijie = mie_crs(ii)398 !399 zdAm = zvol(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1) &400 & + zvol(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1) &401 & + zvol(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1) &402 & + zvol(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk-1) &403 & + zvol(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1) &404 & + zvol(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1) &405 & + zvol(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk-1) &406 & + zvol(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1) &407 & + zvol(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1)408 !409 IF( p_fld1_crs(ii,ij,jk) /= 0._wp ) p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk)410 !411 ENDDO412 ENDDO413 ENDDO414 DO ji = nistr, niend, nn_factx415 DO jj = njstr, njend, nn_facty416 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid417 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2418 ijje = mje_crs(ij)419 ijie = mie_crs(ii)420 !421 zdAm = zvol(ji ,jj ,1) * p_mask(ji ,jj ,1) &422 & + zvol(ji+1,jj ,1) * p_mask(ji+1,jj ,1) &423 & + zvol(ji+2,jj ,1) * p_mask(ji+2,jj ,1) &424 & + zvol(ji ,jj+1,1) * p_mask(ji ,jj+1,1) &425 & + zvol(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1) &426 & + zvol(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1) &427 & + zvol(ji ,jj+2,1) * p_mask(ji ,jj+2,1) &428 & + zvol(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1) &429 & + zvol(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1)430 !431 IF( p_fld1_crs(ii,ij,1) /= 0._wp ) p_fld2_crs(ii,ij,1) = zdAm / p_fld2_crs(ii,ij,1)432 !433 ENDDO434 ENDDO435 ENDIF436 437 446 ! ! Retroactively add back the boundary halo cells. 438 447 CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 ) 439 448 CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 ) 440 449 ! 441 CALL wrk_dealloc( jpi, jpj, jpk, zvol )450 CALL wrk_dealloc( jpi, jpj, jpk, zvol, zmask ) 442 451 ! 443 452 END SUBROUTINE crs_dom_facvol 444 453 445 454 446 SUBROUTINE crs_dom_ope_3d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs )455 SUBROUTINE crs_dom_ope_3d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn ) 447 456 !!---------------------------------------------------------------- 448 457 !! *** SUBROUTINE crsfun_UV *** … … 476 485 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (fse3u, fse3v) 477 486 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator 478 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V mask 487 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska 488 REAL(wp), INTENT(in) :: psgn ! sign 489 479 490 480 491 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity 481 492 482 493 !! Local variables 483 INTEGER :: ji, jj, jk ! dummy loop indices484 INTEGER :: i jie, ijje, ii, ij494 INTEGER :: ji, jj, jk 495 INTEGER :: ii, ij, ijie, ijje, je_2 485 496 REAL(wp) :: zflcrs, zsfcrs 486 REAL(wp) :: zeps = 1.e20 487 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf 488 497 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask 489 498 !!---------------------------------------------------------------- 490 499 500 p_fld_crs(:,:,:) = 0.0 491 501 492 502 SELECT CASE ( cd_op ) … … 494 504 CASE ( 'VOL' ) 495 505 496 CALL wrk_alloc( jpi, jpj, jpk, zsurf ) 497 DO jk = 1, jpk 498 zsurf(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) 499 ENDDO 506 CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 500 507 501 508 SELECT CASE ( cd_type ) 502 509 503 CASE( 'T' ) 510 CASE( 'T', 'W' ) 511 IF( cd_type == 'T' ) THEN 512 DO jk = 1, jpk 513 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 514 zsurfmsk(:,:,jk) = zsurf(:,:,jk) 515 ENDDO 516 ELSE 517 zsurf (:,:,1) = p_e12(:,:) * p_e3(:,:,1) 518 zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) 519 DO jk = 2, jpk 520 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) 521 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) 522 ENDDO 523 ENDIF 504 524 505 DO jk = 1, jpk 506 507 DO ji = nistr, niend, nn_factx 508 DO jj = njstr, njend, nn_facty 509 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 510 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 511 ijje = mje_crs(ij) 512 ijie = mie_crs(ii) 525 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 526 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 527 je_2 = mje_crs(2) 528 DO jk = 1, jpk 529 DO ji = nistr, niend, nn_factx 530 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 531 zflcrs = p_fld(ji ,je_2,jk) * zsurfmsk(ji ,je_2,jk) & 532 & + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & 533 & + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 513 534 514 zflcrs = p_fld(ji ,jj ,jk) * zsurf(ji ,jj ,jk) * p_mask(ji ,jj ,jk) & 515 & + p_fld(ji+1,jj ,jk) * zsurf(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk) & 516 & + p_fld(ji+2,jj ,jk) * zsurf(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk) & 517 & + p_fld(ji ,jj+1,jk) * zsurf(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk) & 518 & + p_fld(ji+1,jj+1,jk) * zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk) & 519 & + p_fld(ji+2,jj+1,jk) * zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk) & 520 & + p_fld(ji ,jj+2,jk) * zsurf(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk) & 521 & + p_fld(ji+1,jj+2,jk) * zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk) & 522 & + p_fld(ji+2,jj+2,jk) * zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) 523 524 zsfcrs = zsurf(ji ,jj ,jk) * p_mask(ji ,jj ,jk) & 525 & + zsurf(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk) & 526 & + zsurf(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk) & 527 & + zsurf(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk) & 528 & + zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk) & 529 & + zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk) & 530 & + zsurf(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk) & 531 & + zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk) & 532 & + zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) 533 ! 535 zsfcrs = zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk) 536 ! 537 p_fld_crs(ii,2,jk) = zflcrs 538 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 539 ENDDO 540 ENDDO 541 ENDIF 542 ELSE 543 je_2 = mjs_crs(2) 544 DO jk = 1, jpk 545 DO ji = nistr, niend, nn_factx 546 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 547 zflcrs = p_fld(ji ,je_2 ,jk) * zsurfmsk(ji ,je_2 ,jk) & 548 & + p_fld(ji+1,je_2 ,jk) * zsurfmsk(ji+1,je_2 ,jk) & 549 & + p_fld(ji+2,je_2 ,jk) * zsurfmsk(ji+2,je_2 ,jk) & 550 & + p_fld(ji ,je_2+1,jk) * zsurfmsk(ji ,je_2+1,jk) & 551 & + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & 552 & + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & 553 & + p_fld(ji ,je_2+2,jk) * zsurfmsk(ji ,je_2+2,jk) & 554 & + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & 555 & + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 556 557 zsfcrs = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & 558 & + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & 559 & + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 560 ! 561 p_fld_crs(ii,2,jk) = zflcrs 562 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2,jk) = zflcrs / zsfcrs 563 ENDDO 564 ENDDO 565 ENDIF 566 ! 567 DO jk = 1, jpk 568 DO jj = njstr, njend, nn_facty 569 DO ji = nistr, niend, nn_factx 570 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 571 ij = ( jj - njstr ) * rfacty_r + 3 572 zflcrs = p_fld(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & 573 & + p_fld(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & 574 & + p_fld(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) & 575 & + p_fld(ji ,jj+1,jk) * zsurfmsk(ji ,jj+1,jk) & 576 & + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & 577 & + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & 578 & + p_fld(ji ,jj+2,jk) * zsurfmsk(ji ,jj+2,jk) & 579 & + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & 580 & + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 581 582 zsfcrs = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & 583 & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & 584 & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 585 ! 534 586 p_fld_crs(ii,ij,jk) = zflcrs 535 587 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 536 588 ENDDO 589 ENDDO 590 ENDDO 591 CASE DEFAULT 592 STOP 593 END SELECT 594 595 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 596 597 CASE ( 'SUM' ) 598 599 CALL wrk_alloc( jpi, jpj, jpk, zsurfmsk ) 600 601 SELECT CASE ( cd_type ) 602 CASE( 'W' ) 603 IF( PRESENT( p_e3 ) ) THEN 604 zsurfmsk(:,:,1) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 605 DO jk = 2, jpk 606 zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk-1) 607 ENDDO 608 ELSE 609 zsurfmsk(:,:,1) = p_e12(:,:) * p_mask(:,:,1) 610 DO jk = 2, jpk 611 zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk-1) 612 ENDDO 613 ENDIF 614 CASE DEFAULT 615 IF( PRESENT( p_e3 ) ) THEN 616 DO jk = 1, jpk 617 zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 618 ENDDO 619 ELSE 620 DO jk = 1, jpk 621 zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk) 622 ENDDO 623 ENDIF 624 END SELECT 625 626 SELECT CASE ( cd_type ) 627 628 CASE( 'T', 'W' ) 629 630 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 631 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 632 je_2 = mje_crs(2) 633 DO jk = 1, jpk 634 DO ji = nistr, niend, nn_factx 635 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 636 zflcrs = p_fld(ji ,je_2,jk) * zsurfmsk(ji ,je_2,jk) & 637 & + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) & 638 & + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 639 ! 640 p_fld_crs(ii,2,jk) = zflcrs 641 ENDDO 642 ENDDO 643 ENDIF 644 ELSE 645 je_2 = mjs_crs(2) 646 DO jk = 1, jpk 647 DO ji = nistr, niend, nn_factx 648 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 649 zflcrs = p_fld(ji ,je_2 ,jk) * zsurfmsk(ji ,je_2 ,jk) & 650 & + p_fld(ji+1,je_2 ,jk) * zsurfmsk(ji+1,je_2 ,jk) & 651 & + p_fld(ji+2,je_2 ,jk) * zsurfmsk(ji+2,je_2 ,jk) & 652 & + p_fld(ji ,je_2+1,jk) * zsurfmsk(ji ,je_2+1,jk) & 653 & + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) & 654 & + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) & 655 & + p_fld(ji ,je_2+2,jk) * zsurfmsk(ji ,je_2+2,jk) & 656 & + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) & 657 & + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 658 ! 659 p_fld_crs(ii,2,jk) = zflcrs 660 ENDDO 661 ENDDO 662 ENDIF 663 ! 664 DO jk = 1, jpk 665 DO jj = njstr, njend, nn_facty 666 DO ji = nistr, niend, nn_factx 667 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 668 ij = ( jj - njstr ) * rfacty_r + 3 669 zflcrs = p_fld(ji ,jj ,jk) * zsurfmsk(ji ,jj ,jk) & 670 & + p_fld(ji+1,jj ,jk) * zsurfmsk(ji+1,jj ,jk) & 671 & + p_fld(ji+2,jj ,jk) * zsurfmsk(ji+2,jj ,jk) & 672 & + p_fld(ji ,jj+1,jk) * zsurfmsk(ji ,jj+1,jk) & 673 & + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) & 674 & + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) & 675 & + p_fld(ji ,jj+2,jk) * zsurfmsk(ji ,jj+2,jk) & 676 & + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) & 677 & + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 678 ! 679 p_fld_crs(ii,ij,jk) = zflcrs 680 ! 537 681 ENDDO 538 682 ENDDO 539 683 ENDDO 540 684 541 CASE( 'W' ) 542 543 DO jk = 2, jpk 544 685 CASE( 'V' ) 686 687 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 688 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 689 ijje = mje_crs(2) 690 ENDIF 691 ELSE 692 ijje = mjs_crs(2) 693 ENDIF 694 ! 695 DO jk = 1, jpk 545 696 DO ji = nistr, niend, nn_factx 546 DO jj = njstr, njend, nn_facty 547 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 548 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 697 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 698 zflcrs = p_fld(ji ,ijje,jk) * zsurfmsk(ji ,ijje,jk) & 699 & + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) & 700 & + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 701 ! 702 p_fld_crs(ii,2,jk) = zflcrs 703 ENDDO 704 ENDDO 705 ! 706 DO jk = 1, jpk 707 DO jj = njstr, njend, nn_facty 708 DO ji = nistr, niend, nn_factx 709 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 710 ij = ( jj - njstr ) * rfacty_r + 3 549 711 ijje = mje_crs(ij) 550 ijie = mie_crs(ii) 551 552 zflcrs = p_fld(ji ,jj ,jk) * zsurf(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1) & 553 & + p_fld(ji+1,jj ,jk) * zsurf(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1) & 554 & + p_fld(ji+2,jj ,jk) * zsurf(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1) & 555 & + p_fld(ji ,jj+1,jk) * zsurf(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk-1) & 556 & + p_fld(ji+1,jj+1,jk) * zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1) & 557 & + p_fld(ji+2,jj+1,jk) * zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1) & 558 & + p_fld(ji ,jj+2,jk) * zsurf(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk-1) & 559 & + p_fld(ji+1,jj+2,jk) * zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1) & 560 & + p_fld(ji+2,jj+2,jk) * zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) 561 562 zsfcrs = zsurf(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1) & 563 & + zsurf(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1) & 564 & + zsurf(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1) & 565 & + zsurf(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk-1) & 566 & + zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1) & 567 & + zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1) & 568 & + zsurf(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk-1) & 569 & + zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1) & 570 & + zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) 571 ! 712 zflcrs = p_fld(ji ,ijje,jk) * zsurfmsk(ji ,ijje,jk) & 713 & + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) & 714 & + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 715 ! 572 716 p_fld_crs(ii,ij,jk) = zflcrs 573 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs 574 717 ! 575 718 ENDDO 576 719 ENDDO 577 720 ENDDO 578 579 DO ji = nistr, niend, nn_factx 580 DO jj = njstr, njend, nn_facty 581 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 582 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 583 ijje = mje_crs(ij) 584 ijie = mie_crs(ii) 585 586 zflcrs = p_fld(ji ,jj ,1) * zsurf(ji ,jj ,1) * p_mask(ji ,jj ,1) & 587 & + p_fld(ji+1,jj ,1) * zsurf(ji+1,jj ,1) * p_mask(ji+1,jj ,1) & 588 & + p_fld(ji+2,jj ,1) * zsurf(ji+2,jj ,1) * p_mask(ji+2,jj ,1) & 589 & + p_fld(ji ,jj+1,1) * zsurf(ji ,jj+1,1) * p_mask(ji ,jj+1,1) & 590 & + p_fld(ji+1,jj+1,1) * zsurf(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1) & 591 & + p_fld(ji+2,jj+1,1) * zsurf(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1) & 592 & + p_fld(ji ,jj+2,1) * zsurf(ji ,jj+2,1) * p_mask(ji ,jj+2,1) & 593 & + p_fld(ji+1,jj+2,1) * zsurf(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1) & 594 & + p_fld(ji+2,jj+2,1) * zsurf(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) 595 596 zsfcrs = zsurf(ji ,jj ,1) * p_mask(ji ,jj ,1) & 597 & + zsurf(ji+1,jj ,1) * p_mask(ji+1,jj ,1) & 598 & + zsurf(ji+2,jj ,1) * p_mask(ji+2,jj ,1) & 599 & + zsurf(ji ,jj+1,1) * p_mask(ji ,jj+1,1) & 600 & + zsurf(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1) & 601 & + zsurf(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1) & 602 & + zsurf(ji ,jj+2,1) * p_mask(ji ,jj+2,1) & 603 & + zsurf(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1) & 604 & + zsurf(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) 605 606 p_fld_crs(ii,ij,1) = zflcrs 607 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij,1) = zflcrs / zsfcrs 608 609 ENDDO 721 722 CASE( 'U' ) 723 724 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 725 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 726 je_2 = mje_crs(2) 727 DO jk = 1, jpk 728 DO ji = nistr, niend, nn_factx 729 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 730 ijie = mie_crs(ii) 731 zflcrs = p_fld(ijie,je_2,jk) * zsurfmsk(ijie,je_2,jk) 732 p_fld_crs(ii,2,jk) = zflcrs 733 ENDDO 734 ENDDO 735 ENDIF 736 ELSE 737 je_2 = mjs_crs(2) 738 DO jk = 1, jpk 739 DO ji = nistr, niend, nn_factx 740 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 741 ijie = mie_crs(ii) 742 zflcrs = p_fld(ijie,je_2 ,jk) * zsurfmsk(ijie,je_2 ,jk) & 743 & + p_fld(ijie,je_2+1,jk) * zsurfmsk(ijie,je_2+1,jk) & 744 & + p_fld(ijie,je_2+2,jk) * zsurfmsk(ijie,je_2+2,jk) 745 746 p_fld_crs(ii,2,jk) = zflcrs 747 ENDDO 748 ENDDO 749 ENDIF 750 ! 751 DO jk = 1, jpk 752 DO jj = njstr, njend, nn_facty 753 DO ji = nistr, niend, nn_factx 754 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 755 ij = ( jj - njstr ) * rfacty_r + 3 756 ijie = mie_crs(ii) 757 zflcrs = p_fld(ijie,jj ,jk) * zsurfmsk(ijie,jj ,jk) & 758 & + p_fld(ijie,jj+1,jk) * zsurfmsk(ijie,jj+1,jk) & 759 & + p_fld(ijie,jj+2,jk) * zsurfmsk(ijie,jj+2,jk) 760 ! 761 p_fld_crs(ii,ij,jk) = zflcrs 762 ! 763 ENDDO 764 ENDDO 765 ENDDO 766 767 END SELECT 768 769 IF( PRESENT( p_surf_crs ) ) THEN 770 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:) 771 ENDIF 772 773 CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk ) 774 775 CASE ( 'MAX' ) ! search the max of unmasked grid cells 776 777 CALL wrk_alloc( jpi, jpj, jpk, zmask ) 778 779 SELECT CASE ( cd_type ) 780 CASE( 'W' ) 781 zmask(:,:,1) = p_mask(:,:,1) 782 DO jk = 2, jpk 783 zmask(:,:,jk) = p_mask(:,:,jk-1) 610 784 ENDDO 611 612 END SELECT 613 614 CALL wrk_dealloc( jpi, jpj, jpk, zsurf ) 615 616 CASE ( 'SUM' ) 617 618 CALL wrk_alloc( jpi, jpj, jpk, zsurf ) 619 620 IF( PRESENT( p_e3 ) ) THEN 621 DO jk = 1, jpk 622 zsurf(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) 623 ENDDO 624 ELSE 625 DO jk = 1, jpk 626 zsurf(:,:,jk) = p_e12(:,:) 627 ENDDO 628 ENDIF 785 CASE ( 'T' ) 786 DO jk = 1, jpk 787 zmask(:,:,jk) = p_mask(:,:,jk) 788 ENDDO 789 END SELECT 629 790 630 791 SELECT CASE ( cd_type ) 631 792 632 CASE( 'T' )793 CASE( 'T', 'W' ) 633 794 634 DO jk = 1, jpk 635 DO ji = nistr, niend, nn_factx 636 DO jj = njstr, njend, nn_facty 637 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 638 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 639 ijje = mje_crs(ij) 640 ijie = mie_crs(ii) 641 642 zflcrs = p_fld(ji ,jj ,jk) * zsurf(ji ,jj ,jk) * p_mask(ji ,jj ,jk) & 643 & + p_fld(ji+1,jj ,jk) * zsurf(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk) & 644 & + p_fld(ji+2,jj ,jk) * zsurf(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk) & 645 & + p_fld(ji ,jj+1,jk) * zsurf(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk) & 646 & + p_fld(ji+1,jj+1,jk) * zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk) & 647 & + p_fld(ji+2,jj+1,jk) * zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk) & 648 & + p_fld(ji ,jj+2,jk) * zsurf(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk) & 649 & + p_fld(ji+1,jj+2,jk) * zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk) & 650 & + p_fld(ji+2,jj+2,jk) * zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) 795 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 796 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 797 je_2 = mje_crs(2) 798 DO jk = 1, jpk 799 DO ji = nistr, niend, nn_factx 800 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 801 zflcrs = & 802 & MAX( p_fld(ji ,je_2,jk) * zmask(ji ,je_2,jk) - ( 1.- zmask(ji ,je_2,jk) ) * r_inf , & 803 & p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) - ( 1.- zmask(ji+1,je_2,jk) ) * r_inf , & 804 & p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) - ( 1.- zmask(ji+2,je_2,jk) ) * r_inf ) 805 ! 806 p_fld_crs(ii,2,jk) = zflcrs 807 ENDDO 808 ENDDO 809 ENDIF 810 ELSE 811 je_2 = mjs_crs(2) 812 DO jk = 1, jpk 813 DO ji = nistr, niend, nn_factx 814 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 815 zflcrs = & 816 & MAX( p_fld(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) - ( 1.- zmask(ji ,je_2 ,jk) ) * r_inf , & 817 & p_fld(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) - ( 1.- zmask(ji+1,je_2 ,jk) ) * r_inf , & 818 & p_fld(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) - ( 1.- zmask(ji+2,je_2 ,jk) ) * r_inf , & 819 & p_fld(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) - ( 1.- zmask(ji ,je_2+1,jk) ) * r_inf , & 820 & p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) - ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf , & 821 & p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) - ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf , & 822 & p_fld(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) - ( 1.- zmask(ji ,je_2+2,jk) ) * r_inf , & 823 & p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) - ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf , & 824 & p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) - ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf ) 825 ! 826 p_fld_crs(ii,2,jk) = zflcrs 827 ENDDO 828 ENDDO 829 ENDIF 830 ! 831 DO jk = 1, jpk 832 DO jj = njstr, njend, nn_facty 833 DO ji = nistr, niend, nn_factx 834 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 835 ij = ( jj - njstr ) * rfacty_r + 3 836 zflcrs = & 837 & MAX( p_fld(ji ,jj ,jk) * zmask(ji ,jj ,jk) - ( 1.- zmask(ji ,jj ,jk) ) * r_inf , & 838 & p_fld(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) - ( 1.- zmask(ji+1,jj ,jk) ) * r_inf , & 839 & p_fld(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) - ( 1.- zmask(ji+2,jj ,jk) ) * r_inf , & 840 & p_fld(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) - ( 1.- zmask(ji ,jj+1,jk) ) * r_inf , & 841 & p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) - ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf , & 842 & p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) - ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf , & 843 & p_fld(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) - ( 1.- zmask(ji ,jj+2,jk) ) * r_inf , & 844 & p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) - ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf , & 845 & p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) - ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf ) 651 846 ! 652 847 p_fld_crs(ii,ij,jk) = zflcrs … … 656 851 ENDDO 657 852 658 CASE( 'W' ) 659 660 DO jk = 2, jpk 853 CASE( 'V' ) 854 855 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 856 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 857 ijje = mje_crs(2) 858 ENDIF 859 ELSE 860 ijje = mjs_crs(2) 861 ENDIF 862 863 DO jk = 1, jpk 661 864 DO ji = nistr, niend, nn_factx 662 DO jj = njstr, njend, nn_facty 663 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 664 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 865 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 866 zflcrs = & 867 & MAX( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & 868 & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & 869 & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) 870 ! 871 p_fld_crs(ii,2,jk) = zflcrs 872 ENDDO 873 ENDDO 874 ! 875 DO jk = 1, jpk 876 DO jj = njstr, njend, nn_facty 877 DO ji = nistr, niend, nn_factx 878 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 879 ij = ( jj - njstr ) * rfacty_r + 3 665 880 ijje = mje_crs(ij) 666 ijie = mie_crs(ii)667 881 ! 668 zflcrs = p_fld(ji ,jj ,jk) * zsurf(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1) & 669 & + p_fld(ji+1,jj ,jk) * zsurf(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1) & 670 & + p_fld(ji+2,jj ,jk) * zsurf(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1) & 671 & + p_fld(ji ,jj+1,jk) * zsurf(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk-1) & 672 & + p_fld(ji+1,jj+1,jk) * zsurf(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1) & 673 & + p_fld(ji+2,jj+1,jk) * zsurf(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1) & 674 & + p_fld(ji ,jj+2,jk) * zsurf(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk-1) & 675 & + p_fld(ji+1,jj+2,jk) * zsurf(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1) & 676 & + p_fld(ji+2,jj+2,jk) * zsurf(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) 882 zflcrs = & 883 & MAX( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & 884 & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & 885 & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) 677 886 ! 678 887 p_fld_crs(ii,ij,jk) = zflcrs … … 682 891 ENDDO 683 892 684 DO ji = nistr, niend, nn_factx685 DO jj = njstr, njend, nn_facty686 ii = ( ji - mis_crs(2) ) * rfactx_r + 2687 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2688 ijje = mje_crs(ij)689 ijie = mie_crs(ii)690 !691 zflcrs = p_fld(ji ,jj ,1) * zsurf(ji ,jj ,1) * p_mask(ji ,jj ,1) &692 & + p_fld(ji+1,jj ,1) * zsurf(ji+1,jj ,1) * p_mask(ji+1,jj ,1) &693 & + p_fld(ji+2,jj ,1) * zsurf(ji+2,jj ,1) * p_mask(ji+2,jj ,1) &694 & + p_fld(ji ,jj+1,1) * zsurf(ji ,jj+1,1) * p_mask(ji ,jj+1,1) &695 & + p_fld(ji+1,jj+1,1) * zsurf(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1) &696 & + p_fld(ji+2,jj+1,1) * zsurf(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1) &697 & + p_fld(ji ,jj+2,1) * zsurf(ji ,jj+2,1) * p_mask(ji ,jj+2,1) &698 & + p_fld(ji+1,jj+2,1) * zsurf(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1) &699 & + p_fld(ji+2,jj+2,1) * zsurf(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1)700 !701 p_fld_crs(ii,ij,1) = zflcrs702 !703 ENDDO704 ENDDO705 706 CASE( 'V' )707 708 DO jk = 1, jpk709 DO ji = nistr, niend, nn_factx710 DO jj = njstr, njend, nn_facty711 ii = ( ji - mis_crs(2) ) * rfactx_r + 2712 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2713 ijje = mje_crs(ij)714 ijie = mie_crs(ii)715 !716 zflcrs = p_fld(ji ,ijje,jk) * zsurf(ji ,ijje,jk) * p_mask(ji ,ijje,jk) &717 & + p_fld(ji+1,ijje,jk) * zsurf(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) &718 & + p_fld(ji+2,ijje,jk) * zsurf(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk)719 !720 p_fld_crs(ii,ij,jk) = zflcrs721 !722 ENDDO723 ENDDO724 ENDDO725 726 893 727 894 CASE( 'U' ) 728 729 DO jk = 1, jpk 730 DO ji = nistr, niend, nn_factx 731 DO jj = njstr, njend, nn_facty 895 896 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 897 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 898 je_2 = mje_crs(2) 899 DO jk = 1, jpk 900 DO ji = nistr, niend, nn_factx 901 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 902 ijie = mie_crs(ii) 903 zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf 904 ! 905 p_fld_crs(ii,2,jk) = zflcrs 906 ENDDO 907 ENDDO 908 ENDIF 909 ELSE 910 je_2 = mjs_crs(2) 911 DO jk = 1, jpk 912 DO ji = nistr, niend, nn_factx 913 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 914 ijie = mie_crs(ii) 915 zflcrs = & 916 & MAX( p_fld(ijie,je_2 ,jk) * p_mask(ijie,je_2 ,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & 917 & p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & 918 & p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ) 919 ! 920 p_fld_crs(ii,2,jk) = zflcrs 921 ENDDO 922 ENDDO 923 ENDIF 924 ! 925 DO jk = 1, jpk 926 DO jj = njstr, njend, nn_facty 927 DO ji = nistr, niend, nn_factx 732 928 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 733 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 734 ijje = mje_crs(ij) 929 ij = ( jj - njstr ) * rfacty_r + 3 735 930 ijie = mie_crs(ii) 736 !737 zflcrs = p_fld(ijie,jj ,jk) * zsurf(ijie,jj ,jk) * p_mask(ijie,jj ,jk)&738 & + p_fld(ijie,jj+1,jk) * zsurf(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk)&739 & + p_fld(ijie,jj+2,jk) * zsurf(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk)740 ! 931 zflcrs = & 932 & MAX( p_fld(ijie,jj ,jk) * p_mask(ijie,jj ,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & 933 & p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & 934 & p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ) 935 ! 741 936 p_fld_crs(ii,ij,jk) = zflcrs 742 ! 937 ! 743 938 ENDDO 744 939 ENDDO … … 747 942 END SELECT 748 943 749 IF( PRESENT( p_surf_crs ) ) THEN 750 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:) 751 ENDIF 752 753 CALL wrk_dealloc( jpi, jpj, jpk, zsurf ) 754 755 CASE ( 'MAX' ) 944 CALL wrk_dealloc( jpi, jpj, jpk, zmask ) 945 946 CASE ( 'MIN' ) ! Search the min of unmasked grid cells 947 948 CALL wrk_alloc( jpi, jpj, jpk, zmask ) 949 950 SELECT CASE ( cd_type ) 951 CASE( 'W' ) 952 zmask(:,:,1) = p_mask(:,:,1) 953 DO jk = 2, jpk 954 zmask(:,:,jk) = p_mask(:,:,jk-1) 955 ENDDO 956 CASE ( 'T' ) 957 DO jk = 1, jpk 958 zmask(:,:,jk) = p_mask(:,:,jk) 959 ENDDO 960 END SELECT 961 962 SELECT CASE ( cd_type ) 963 964 CASE( 'T', 'W' ) 756 965 757 SELECT CASE ( cd_type ) 758 759 CASE( 'T' ) 760 761 DO jk = 1, jpk 762 DO ji = nistr, niend, nn_factx 763 DO jj = njstr, njend, nn_facty 764 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 765 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 766 ijje = mje_crs(ij) 767 ijie = mie_crs(ii) 768 769 zflcrs = MAX( p_fld(ji ,jj ,jk) * p_mask(ji ,jj ,jk), & 770 & p_fld(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk), & 771 & p_fld(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk), & 772 & p_fld(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk), & 773 & p_fld(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk), & 774 & p_fld(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk), & 775 & p_fld(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk), & 776 & p_fld(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk), & 777 & p_fld(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 966 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 967 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 968 je_2 = mje_crs(2) 969 DO jk = 1, jpk 970 DO ji = nistr, niend, nn_factx 971 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 972 zflcrs = & 973 & MIN( p_fld(ji ,je_2,jk) * zmask(ji ,je_2,jk) + ( 1.- zmask(ji ,je_2,jk) ) * r_inf , & 974 & p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) + ( 1.- zmask(ji+1,je_2,jk) ) * r_inf , & 975 & p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + ( 1.- zmask(ji+2,je_2,jk) ) * r_inf ) 976 ! 977 p_fld_crs(ii,2,jk) = zflcrs 978 ENDDO 979 ENDDO 980 ENDIF 981 ELSE 982 je_2 = mjs_crs(2) 983 DO jk = 1, jpk 984 DO ji = nistr, niend, nn_factx 985 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 986 zflcrs = & 987 & MIN( p_fld(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) + ( 1.- zmask(ji ,je_2 ,jk) ) * r_inf , & 988 & p_fld(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) + ( 1.- zmask(ji+1,je_2 ,jk) ) * r_inf , & 989 & p_fld(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) + ( 1.- zmask(ji+2,je_2 ,jk) ) * r_inf , & 990 & p_fld(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) + ( 1.- zmask(ji ,je_2+1,jk) ) * r_inf , & 991 & p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) + ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf , & 992 & p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) + ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf , & 993 & p_fld(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) + ( 1.- zmask(ji ,je_2+2,jk) ) * r_inf , & 994 & p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) + ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf , & 995 & p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf ) 996 ! 997 p_fld_crs(ii,2,jk) = zflcrs 998 ENDDO 999 ENDDO 1000 ENDIF 1001 ! 1002 DO jk = 1, jpk 1003 DO jj = njstr, njend, nn_facty 1004 DO ji = nistr, niend, nn_factx 1005 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1006 ij = ( jj - njstr ) * rfacty_r + 3 1007 zflcrs = & 1008 & MIN( p_fld(ji ,jj ,jk) * zmask(ji ,jj ,jk) + ( 1.- zmask(ji ,jj ,jk) ) * r_inf , & 1009 & p_fld(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) + ( 1.- zmask(ji+1,jj ,jk) ) * r_inf , & 1010 & p_fld(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) + ( 1.- zmask(ji+2,jj ,jk) ) * r_inf , & 1011 & p_fld(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) + ( 1.- zmask(ji ,jj+1,jk) ) * r_inf , & 1012 & p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) + ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf , & 1013 & p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) + ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf , & 1014 & p_fld(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) + ( 1.- zmask(ji ,jj+2,jk) ) * r_inf , & 1015 & p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) + ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf , & 1016 & p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf ) 778 1017 ! 779 1018 p_fld_crs(ii,ij,jk) = zflcrs … … 783 1022 ENDDO 784 1023 785 CASE( 'W' ) 786 787 DO jk = 2, jpk 1024 CASE( 'V' ) 1025 1026 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1027 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1028 ijje = mje_crs(2) 1029 ENDIF 1030 ELSE 1031 ijje = mjs_crs(2) 1032 ENDIF 1033 1034 DO jk = 1, jpk 788 1035 DO ji = nistr, niend, nn_factx 789 DO jj = njstr, njend, nn_facty 790 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 791 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1036 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1037 zflcrs = & 1038 & MIN( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & 1039 & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & 1040 & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) 1041 ! 1042 p_fld_crs(ii,2,jk) = zflcrs 1043 ENDDO 1044 ENDDO 1045 ! 1046 DO jk = 1, jpk 1047 DO jj = njstr, njend, nn_facty 1048 DO ji = nistr, niend, nn_factx 1049 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1050 ij = ( jj - njstr ) * rfacty_r + 3 792 1051 ijje = mje_crs(ij) 793 ijie = mie_crs(ii) 794 ! 795 zflcrs = MAX( p_fld(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1), & 796 & p_fld(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1), & 797 & p_fld(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1), & 798 & p_fld(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk-1), & 799 & p_fld(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1), & 800 & p_fld(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1), & 801 & p_fld(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk-1), & 802 & p_fld(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1), & 803 & p_fld(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) ) 1052 zflcrs = & 1053 & MIN( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & 1054 & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf , & 1055 & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ) 804 1056 ! 805 1057 p_fld_crs(ii,ij,jk) = zflcrs … … 809 1061 ENDDO 810 1062 811 DO ji = nistr, niend, nn_factx 812 DO jj = njstr, njend, nn_facty 813 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 814 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 815 ijje = mje_crs(ij) 816 ijie = mie_crs(ii) 817 ! 818 zflcrs = MAX( p_fld(ji ,jj ,1) * p_mask(ji ,jj ,1), & 819 & p_fld(ji+1,jj ,1) * p_mask(ji+1,jj ,1), & 820 & p_fld(ji+2,jj ,1) * p_mask(ji+2,jj ,1), & 821 & p_fld(ji ,jj+1,1) * p_mask(ji ,jj+1,1), & 822 & p_fld(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1), & 823 & p_fld(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1), & 824 & p_fld(ji ,jj+2,1) * p_mask(ji ,jj+2,1), & 825 & p_fld(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1), & 826 & p_fld(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) ) 827 ! 828 p_fld_crs(ii,ij,1) = zflcrs 829 ! 830 ENDDO 831 ENDDO 832 833 CASE( 'V' ) 834 835 DO jk = 1, jpk 836 DO ji = nistr, niend, nn_factx 837 DO jj = njstr, njend, nn_facty 1063 1064 CASE( 'U' ) 1065 1066 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1067 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1068 je_2 = mje_crs(2) 1069 DO jk = 1, jpk 1070 DO ji = nistr, niend, nn_factx 1071 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1072 ijie = mie_crs(ii) 1073 zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf 1074 ! 1075 p_fld_crs(ii,2,jk) = zflcrs 1076 ENDDO 1077 ENDDO 1078 ENDIF 1079 ELSE 1080 je_2 = mjs_crs(2) 1081 DO jk = 1, jpk 1082 DO ji = nistr, niend, nn_factx 1083 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1084 ijie = mie_crs(ii) 1085 zflcrs = & 1086 & MIN( p_fld(ijie,je_2 ,jk) * p_mask(ijie,je_2 ,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & 1087 & p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf , & 1088 & p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ) 1089 ! 1090 p_fld_crs(ii,2,jk) = zflcrs 1091 ENDDO 1092 ENDDO 1093 ENDIF 1094 ! 1095 DO jk = 1, jpk 1096 DO jj = njstr, njend, nn_facty 1097 DO ji = nistr, niend, nn_factx 838 1098 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 839 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 840 ijje = mje_crs(ij) 1099 ij = ( jj - njstr ) * rfacty_r + 3 841 1100 ijie = mie_crs(ii) 842 !843 zflcrs = MAX( p_fld(ji ,ijje,jk) * p_mask(ji ,ijje,jk), &844 & p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk), &845 & p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk))846 ! 1101 zflcrs = & 1102 & MIN( p_fld(ijie,jj ,jk) * p_mask(ijie,jj ,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & 1103 & p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf , & 1104 & p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ) 1105 ! 847 1106 p_fld_crs(ii,ij,jk) = zflcrs 848 ! 1107 ! 849 1108 ENDDO 850 1109 ENDDO 851 1110 ENDDO 852 853 854 CASE( 'U' ) 855 856 DO jk = 1, jpk 857 DO ji = nistr, niend, nn_factx 858 DO jj = njstr, njend, nn_facty 859 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 860 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 861 ijje = mje_crs(ij) 862 ijie = mie_crs(ii) 863 ! 864 Zflcrs = MAX( p_fld(ijie,jj ,jk) * p_mask(ijie,jj ,jk), & 865 & p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk), & 866 & p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) ) 867 ! 868 p_fld_crs(ii,ij,jk) = zflcrs 869 ! 870 ENDDO 871 ENDDO 872 ENDDO 873 874 END SELECT 875 876 CASE ( 'MIN' ) 877 ! Search the min of masked grid cells 878 SELECT CASE ( cd_type ) 879 880 CASE( 'T' ) 881 882 DO jk = 1, jpk 883 DO ji = nistr, niend, nn_factx 884 DO jj = njstr, njend, nn_facty 885 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 886 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 887 ijje = mje_crs(ij) 888 ijie = mie_crs(ii) 889 890 zflcrs = MIN( p_fld(ji ,jj ,jk) * ( 1. + ( 1. - p_mask(ji ,jj ,jk) ) * zeps ), & 891 & p_fld(ji+1,jj ,jk) * ( 1. + ( 1. - p_mask(ji+1,jj ,jk) ) * zeps ), & 892 & p_fld(ji+2,jj ,jk) * ( 1. + ( 1. - p_mask(ji+2,jj ,jk) ) * zeps ), & 893 & p_fld(ji ,jj+1,jk) * ( 1. + ( 1. - p_mask(ji ,jj ,jk) ) * zeps ), & 894 & p_fld(ji+1,jj+1,jk) * ( 1. + ( 1. - p_mask(ji+1,jj+1,jk) ) * zeps ), & 895 & p_fld(ji+2,jj+1,jk) * ( 1. + ( 1. - p_mask(ji+2,jj+2,jk) ) * zeps ), & 896 & p_fld(ji ,jj+2,jk) * ( 1. + ( 1. - p_mask(ji ,jj ,jk) ) * zeps ), & 897 & p_fld(ji+1,jj+2,jk) * ( 1. + ( 1. - p_mask(ji+1,jj+1,jk) ) * zeps ), & 898 & p_fld(ji+2,jj+2,jk) * ( 1. + ( 1. - p_mask(ji+2,jj+2,jk) ) * zeps ) ) 899 ! 900 p_fld_crs(ii,ij,jk) = zflcrs * p_mask_crs(ii,ij,jk) 901 ! 902 ENDDO 903 ENDDO 904 ENDDO 905 906 CASE( 'W' ) 907 908 DO jk = 2, jpk 909 DO ji = nistr, niend, nn_factx 910 DO jj = njstr, njend, nn_facty 911 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 912 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 913 ijje = mje_crs(ij) 914 ijie = mie_crs(ii) 915 916 zflcrs = MIN( p_fld(ji ,jj ,jk) * ( 1. + ( 1. - p_mask(ji ,jj ,jk-1) ) * zeps ), & 917 & p_fld(ji+1,jj ,jk) * ( 1. + ( 1. - p_mask(ji+1,jj ,jk-1) ) * zeps ), & 918 & p_fld(ji+2,jj ,jk) * ( 1. + ( 1. - p_mask(ji+2,jj ,jk-1) ) * zeps ), & 919 & p_fld(ji ,jj+1,jk) * ( 1. + ( 1. - p_mask(ji ,jj ,jk-1) ) * zeps ), & 920 & p_fld(ji+1,jj+1,jk) * ( 1. + ( 1. - p_mask(ji+1,jj+1,jk-1) ) * zeps ), & 921 & p_fld(ji+2,jj+1,jk) * ( 1. + ( 1. - p_mask(ji+2,jj+2,jk-1) ) * zeps ), & 922 & p_fld(ji ,jj+2,jk) * ( 1. + ( 1. - p_mask(ji ,jj ,jk-1) ) * zeps ), & 923 & p_fld(ji+1,jj+2,jk) * ( 1. + ( 1. - p_mask(ji+1,jj+1,jk-1) ) * zeps ), & 924 & p_fld(ji+2,jj+2,jk) * ( 1. + ( 1. - p_mask(ji+2,jj+2,jk-1) ) * zeps ) ) 925 ! 926 p_fld_crs(ii,ij,jk) = zflcrs * p_mask_crs(ii,ij,jk) 927 ! 928 ENDDO 929 ENDDO 930 ENDDO 931 932 DO ji = nistr, niend, nn_factx 933 DO jj = njstr, njend, nn_facty 934 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 935 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 936 ijje = mje_crs(ij) 937 ijie = mie_crs(ii) 938 939 zflcrs = MIN( p_fld(ji ,jj ,1) * ( 1. + ( 1. - p_mask(ji ,jj ,1) ) * zeps ), & 940 & p_fld(ji+1,jj ,1) * ( 1. + ( 1. - p_mask(ji+1,jj ,1) ) * zeps ), & 941 & p_fld(ji+2,jj ,1) * ( 1. + ( 1. - p_mask(ji+2,jj ,1) ) * zeps ), & 942 & p_fld(ji ,jj+1,1) * ( 1. + ( 1. - p_mask(ji ,jj ,1) ) * zeps ), & 943 & p_fld(ji+1,jj+1,1) * ( 1. + ( 1. - p_mask(ji+1,jj+1,1) ) * zeps ), & 944 & p_fld(ji+2,jj+1,1) * ( 1. + ( 1. - p_mask(ji+2,jj+2,1) ) * zeps ), & 945 & p_fld(ji ,jj+2,1) * ( 1. + ( 1. - p_mask(ji ,jj ,1) ) * zeps ), & 946 & p_fld(ji+1,jj+2,1) * ( 1. + ( 1. - p_mask(ji+1,jj+1,1) ) * zeps ), & 947 & p_fld(ji+2,jj+2,1) * ( 1. + ( 1. - p_mask(ji+2,jj+2,1) ) * zeps ) ) 948 ! 949 p_fld_crs(ii,ij,1) = zflcrs * p_mask_crs(ii,ij,1) 950 ! 951 ENDDO 952 ENDDO 953 954 CASE( 'V' ) 955 956 DO jk = 1, jpk 957 DO ji = nistr, niend, nn_factx 958 DO jj = njstr, njend, nn_facty 959 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 960 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 961 ijje = mje_crs(ij) 962 ijie = mie_crs(ii) 963 964 zflcrs = MIN( p_fld(ji ,ijje,jk) * ( 1. + ( 1. - p_mask(ji ,ijje,jk) ) * zeps ), & 965 & p_fld(ji+1,ijje,jk) * ( 1. + ( 1. - p_mask(ji+1,ijje,jk) ) * zeps ), & 966 & p_fld(ji+2,ijje,jk) * ( 1. + ( 1. - p_mask(ji+2,ijje,jk) ) * zeps ) ) 967 ! 968 p_fld_crs(ii,ij,jk) = zflcrs * p_mask_crs(ii,ij,jk) 969 ! 970 ENDDO 971 ENDDO 972 ENDDO 973 974 975 CASE( 'U' ) 976 977 DO jk = 1, jpk 978 DO ji = nistr, niend, nn_factx 979 DO jj = njstr, njend, nn_facty 980 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 981 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 982 ijje = mje_crs(ij) 983 ijie = mie_crs(ii) 984 985 zflcrs = MIN( p_fld(ijie,jj ,jk) * ( 1. + ( 1. - p_mask(ijie,jj ,jk) ) * zeps ), & 986 & p_fld(ijie,jj+1,jk) * ( 1. + ( 1. - p_mask(ijie,jj+1,jk) ) * zeps ), & 987 & p_fld(ijie,jj+2,jk) * ( 1. + ( 1. - p_mask(ijie,jj+2,jk) ) * zeps ) ) 988 ! 989 p_fld_crs(ii,ij,jk) = zflcrs * p_mask_crs(ii,ij,jk) 990 ! 991 ENDDO 992 ENDDO 993 ENDDO 1111 994 1112 END SELECT 1113 ! 1114 CALL wrk_dealloc( jpi, jpj, jpk, zmask ) 995 1115 ! 996 1116 END SELECT 997 1117 ! 998 CALL crs_lbc_lnk( p_fld_crs, cd_type, 1.0)1118 CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) 999 1119 ! 1000 1120 END SUBROUTINE crs_dom_ope_3d 1001 1121 1002 SUBROUTINE crs_dom_ope_2d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs )1122 SUBROUTINE crs_dom_ope_2d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn ) 1003 1123 !!---------------------------------------------------------------- 1004 1124 !! *** SUBROUTINE crsfun_UV *** … … 1033 1153 REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator 1034 1154 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V mask 1155 REAL(wp), INTENT(in) :: psgn 1035 1156 1036 1157 REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity … … 1038 1159 !! Local variables 1039 1160 INTEGER :: ji, jj, jk ! dummy loop indices 1040 INTEGER :: ijie, ijje, ii, ij 1161 INTEGER :: ijie, ijje, ii, ij, je_2 1041 1162 REAL(wp) :: zflcrs, zsfcrs 1042 REAL(wp) :: zeps = 1.e20 1043 REAL(wp), DIMENSION(:,:), POINTER :: zsurf 1163 REAL(wp), DIMENSION(:,:), POINTER :: zsurfmsk 1044 1164 1045 1165 !!---------------------------------------------------------------- 1046 1166 1167 p_fld_crs(:,:) = 0.0 1047 1168 1048 1169 SELECT CASE ( cd_op ) 1049 1170 1050 1171 CASE ( 'VOL' ) 1051 1172 1052 CALL wrk_alloc( jpi, jpj, zsurf ) 1053 zsurf(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 1054 1055 DO ji = nistr, niend, nn_factx 1056 DO jj = njstr, njend, nn_facty 1057 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1058 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1059 ijje = mje_crs(ij) 1060 ijie = mie_crs(ii) 1061 1062 zflcrs = p_fld(ji ,jj ) * zsurf(ji ,jj ) & 1063 & + p_fld(ji+1,jj ) * zsurf(ji+1,jj ) & 1064 & + p_fld(ji+2,jj ) * zsurf(ji+2,jj ) & 1065 & + p_fld(ji ,jj+1) * zsurf(ji ,jj+1) & 1066 & + p_fld(ji+1,jj+1) * zsurf(ji+1,jj+1) & 1067 & + p_fld(ji+2,jj+1) * zsurf(ji+2,jj+1) & 1068 & + p_fld(ji ,jj+2) * zsurf(ji ,jj+2) & 1069 & + p_fld(ji+1,jj+2) * zsurf(ji+1,jj+2) & 1070 & + p_fld(ji+2,jj+2) * zsurf(ji+2,jj+2) 1071 1072 zsfcrs = zsurf(ji,jj ) + zsurf(ji+1,jj ) + zsurf(ji+2,jj ) & 1073 & + zsurf(ji,jj+1) + zsurf(ji+1,jj+1) + zsurf(ji+2,jj+1) & 1074 & + zsurf(ji,jj+2) + zsurf(ji+1,jj+2) + zsurf(ji+2,jj+2) 1075 ! 1076 p_fld_crs(ii,ij) = zflcrs 1077 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij) = zflcrs / zsfcrs 1078 1079 ENDDO 1080 ENDDO 1081 1082 CALL wrk_dealloc( jpi, jpj, zsurf ) 1173 CALL wrk_alloc( jpi, jpj, zsurfmsk ) 1174 zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 1175 1176 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1177 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1178 je_2 = mje_crs(2) 1179 DO ji = nistr, niend, nn_factx 1180 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1181 zflcrs = p_fld(ji ,je_2) * zsurfmsk(ji ,je_2) & 1182 & + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) & 1183 & + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) 1184 1185 zsfcrs = zsurfmsk(ji,je_2) + zsurfmsk(ji+1,je_2) + zsurfmsk(ji+2,je_2) 1186 ! 1187 p_fld_crs(ii,2) = zflcrs 1188 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2) = zflcrs / zsfcrs 1189 ENDDO 1190 ENDIF 1191 ELSE 1192 je_2 = mjs_crs(2) 1193 DO ji = nistr, niend, nn_factx 1194 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1195 zflcrs = p_fld(ji ,je_2 ) * zsurfmsk(ji ,je_2 ) & 1196 & + p_fld(ji+1,je_2 ) * zsurfmsk(ji+1,je_2 ) & 1197 & + p_fld(ji+2,je_2 ) * zsurfmsk(ji+2,je_2 ) & 1198 & + p_fld(ji ,je_2+1) * zsurfmsk(ji ,je_2+1) & 1199 & + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) & 1200 & + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) & 1201 & + p_fld(ji ,je_2+2) * zsurfmsk(ji ,je_2+2) & 1202 & + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) & 1203 & + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) 1204 1205 zsfcrs = zsurfmsk(ji,je_2 ) + zsurfmsk(ji+1,je_2 ) + zsurfmsk(ji+2,je_2 ) & 1206 & + zsurfmsk(ji,je_2+1) + zsurfmsk(ji+1,je_2+1) + zsurfmsk(ji+2,je_2+1) & 1207 & + zsurfmsk(ji,je_2+2) + zsurfmsk(ji+1,je_2+2) + zsurfmsk(ji+2,je_2+2) 1208 ! 1209 p_fld_crs(ii,2) = zflcrs 1210 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,2) = zflcrs / zsfcrs 1211 ENDDO 1212 ENDIF 1213 ! 1214 DO jj = njstr, njend, nn_facty 1215 DO ji = nistr, niend, nn_factx 1216 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1217 ij = ( jj - njstr ) * rfacty_r + 3 1218 zflcrs = p_fld(ji ,jj ) * zsurfmsk(ji ,jj ) & 1219 & + p_fld(ji+1,jj ) * zsurfmsk(ji+1,jj ) & 1220 & + p_fld(ji+2,jj ) * zsurfmsk(ji+2,jj ) & 1221 & + p_fld(ji ,jj+1) * zsurfmsk(ji ,jj+1) & 1222 & + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) & 1223 & + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) & 1224 & + p_fld(ji ,jj+2) * zsurfmsk(ji ,jj+2) & 1225 & + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) & 1226 & + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) 1227 1228 zsfcrs = zsurfmsk(ji,jj ) + zsurfmsk(ji+1,jj ) + zsurfmsk(ji+2,jj ) & 1229 & + zsurfmsk(ji,jj+1) + zsurfmsk(ji+1,jj+1) + zsurfmsk(ji+2,jj+1) & 1230 & + zsurfmsk(ji,jj+2) + zsurfmsk(ji+1,jj+2) + zsurfmsk(ji+2,jj+2) 1231 ! 1232 p_fld_crs(ii,ij) = zflcrs 1233 IF( zsfcrs /= 0.0 ) p_fld_crs(ii,ij) = zflcrs / zsfcrs 1234 ENDDO 1235 ENDDO 1236 1237 CALL wrk_dealloc( jpi, jpj, zsurfmsk ) 1083 1238 1084 1239 CASE ( 'SUM' ) 1085 1240 1086 CALL wrk_alloc( jpi, jpj, zsurf )1241 CALL wrk_alloc( jpi, jpj, zsurfmsk ) 1087 1242 IF( PRESENT( p_e3 ) ) THEN 1088 zsurf (:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)1243 zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 1089 1244 ELSE 1090 zsurf (:,:) = p_e12(:,:) * p_mask(:,:,1)1245 zsurfmsk(:,:) = p_e12(:,:) * p_mask(:,:,1) 1091 1246 ENDIF 1247 1248 SELECT CASE ( cd_type ) 1249 1250 CASE( 'T', 'W' ) 1251 1252 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1253 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1254 je_2 = mje_crs(2) 1255 DO ji = nistr, niend, nn_factx 1256 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1257 zflcrs = p_fld(ji ,je_2) * zsurfmsk(ji ,je_2) & 1258 & + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) & 1259 & + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) 1260 ! 1261 p_fld_crs(ii,2) = zflcrs 1262 ENDDO 1263 ENDIF 1264 ELSE 1265 je_2 = mjs_crs(2) 1266 DO ji = nistr, niend, nn_factx 1267 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1268 zflcrs = p_fld(ji ,je_2 ) * zsurfmsk(ji ,je_2 ) & 1269 & + p_fld(ji+1,je_2 ) * zsurfmsk(ji+1,je_2 ) & 1270 & + p_fld(ji+2,je_2 ) * zsurfmsk(ji+2,je_2 ) & 1271 & + p_fld(ji ,je_2+1) * zsurfmsk(ji ,je_2+1) & 1272 & + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) & 1273 & + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) & 1274 & + p_fld(ji ,je_2+2) * zsurfmsk(ji ,je_2+2) & 1275 & + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) & 1276 & + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) 1277 ! 1278 p_fld_crs(ii,2) = zflcrs 1279 ENDDO 1280 ENDIF 1281 ! 1282 DO jj = njstr, njend, nn_facty 1283 DO ji = nistr, niend, nn_factx 1284 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1285 ij = ( jj - njstr ) * rfacty_r + 3 1286 zflcrs = p_fld(ji ,jj ) * zsurfmsk(ji ,jj ) & 1287 & + p_fld(ji+1,jj ) * zsurfmsk(ji+1,jj ) & 1288 & + p_fld(ji+2,jj ) * zsurfmsk(ji+2,jj ) & 1289 & + p_fld(ji ,jj+1) * zsurfmsk(ji ,jj+1) & 1290 & + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) & 1291 & + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) & 1292 & + p_fld(ji ,jj+2) * zsurfmsk(ji ,jj+2) & 1293 & + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) & 1294 & + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) 1295 ! 1296 p_fld_crs(ii,ij) = zflcrs 1297 ! 1298 ENDDO 1299 ENDDO 1300 1301 CASE( 'V' ) 1302 1303 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1304 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1305 ijje = mje_crs(2) 1306 ENDIF 1307 ELSE 1308 ijje = mjs_crs(2) 1309 ENDIF 1310 1311 DO ji = nistr, niend, nn_factx 1312 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1313 zflcrs = p_fld(ji ,ijje) * zsurfmsk(ji ,ijje) & 1314 & + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) & 1315 & + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) 1316 ! 1317 p_fld_crs(ii,2) = zflcrs 1318 ENDDO 1319 1320 DO jj = njstr, njend, nn_facty 1321 DO ji = nistr, niend, nn_factx 1322 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1323 ij = ( jj - njstr ) * rfacty_r + 3 1324 ijje = mje_crs(ij) 1325 zflcrs = p_fld(ji ,ijje) * zsurfmsk(ji ,ijje) & 1326 & + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) & 1327 & + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) 1328 ! 1329 p_fld_crs(ii,ij) = zflcrs 1330 ! 1331 ENDDO 1332 ENDDO 1333 1334 CASE( 'U' ) 1335 1336 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1337 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1338 je_2 = mje_crs(2) 1339 DO ji = nistr, niend, nn_factx 1340 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1341 ijie = mie_crs(ii) 1342 zflcrs = p_fld(ijie,je_2) * zsurfmsk(ijie,je_2) 1343 p_fld_crs(ii,2) = zflcrs 1344 ENDDO 1345 ENDIF 1346 ELSE 1347 je_2 = mjs_crs(2) 1348 DO ji = nistr, niend, nn_factx 1349 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1350 ijie = mie_crs(ii) 1351 zflcrs = p_fld(ijie,je_2 ) * zsurfmsk(ijie,je_2 ) & 1352 & + p_fld(ijie,je_2+1) * zsurfmsk(ijie,je_2+1) & 1353 & + p_fld(ijie,je_2+2) * zsurfmsk(ijie,je_2+2) 1354 1355 p_fld_crs(ii,2) = zflcrs 1356 ENDDO 1357 ENDIF 1358 1359 DO jj = njstr, njend, nn_facty 1360 DO ji = nistr, niend, nn_factx 1361 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1362 ij = ( jj - njstr ) * rfacty_r + 3 1363 ijie = mie_crs(ii) 1364 zflcrs = p_fld(ijie,jj ) * zsurfmsk(ijie,jj ) & 1365 & + p_fld(ijie,jj+1) * zsurfmsk(ijie,jj+1) & 1366 & + p_fld(ijie,jj+2) * zsurfmsk(ijie,jj+2) 1367 ! 1368 p_fld_crs(ii,ij) = zflcrs 1369 ! 1370 ENDDO 1371 ENDDO 1372 1373 END SELECT 1374 1375 IF( PRESENT( p_surf_crs ) ) THEN 1376 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:) 1377 ENDIF 1378 1379 CALL wrk_dealloc( jpi, jpj, zsurfmsk ) 1380 1381 CASE ( 'MAX' ) 1092 1382 1093 1383 SELECT CASE ( cd_type ) 1094 1384 1095 1385 CASE( 'T', 'W' ) 1096 1097 DO ji = nistr, niend, nn_factx 1098 DO jj = njstr, njend, nn_facty 1099 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1100 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1101 ijje = mje_crs(ij) 1102 ijie = mie_crs(ii) 1103 1104 zflcrs = p_fld(ji ,jj ) * zsurf(ji ,jj ) & 1105 & + p_fld(ji+1,jj ) * zsurf(ji+1,jj ) & 1106 & + p_fld(ji+2,jj ) * zsurf(ji+2,jj ) & 1107 & + p_fld(ji ,jj+1) * zsurf(ji ,jj+1) & 1108 & + p_fld(ji+1,jj+1) * zsurf(ji+1,jj+1) & 1109 & + p_fld(ji+2,jj+1) * zsurf(ji+2,jj+1) & 1110 & + p_fld(ji ,jj+2) * zsurf(ji ,jj+2) & 1111 & + p_fld(ji+1,jj+2) * zsurf(ji+1,jj+2) & 1112 & + p_fld(ji+2,jj+2) * zsurf(ji+2,jj+2) 1113 ! 1114 p_fld_crs(ii,ij) = zflcrs 1115 ! 1116 ENDDO 1117 ENDDO 1386 1387 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1388 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1389 je_2 = mje_crs(2) 1390 DO ji = nistr, niend, nn_factx 1391 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1392 zflcrs = & 1393 & MAX( p_fld(ji ,je_2) * p_mask(ji ,je_2,1) - ( 1.- p_mask(ji ,je_2,1) ) * r_inf , & 1394 & p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) - ( 1.- p_mask(ji+1,je_2,1) ) * r_inf , & 1395 & p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) - ( 1.- p_mask(ji+2,je_2,1) ) * r_inf ) 1396 ! 1397 p_fld_crs(ii,2) = zflcrs 1398 ENDDO 1399 ENDIF 1400 ELSE 1401 je_2 = mjs_crs(2) 1402 zflcrs = & 1403 & MAX( p_fld(ji ,je_2 ) * p_mask(ji ,je_2 ,1) - ( 1.- p_mask(ji ,je_2 ,1) ) * r_inf , & 1404 & p_fld(ji+1,je_2 ) * p_mask(ji+1,je_2 ,1) - ( 1.- p_mask(ji+1,je_2 ,1) ) * r_inf , & 1405 & p_fld(ji+2,je_2 ) * p_mask(ji+2,je_2 ,1) - ( 1.- p_mask(ji+2,je_2 ,1) ) * r_inf , & 1406 & p_fld(ji ,je_2+1) * p_mask(ji ,je_2+1,1) - ( 1.- p_mask(ji ,je_2+1,1) ) * r_inf , & 1407 & p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) - ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf , & 1408 & p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) - ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf , & 1409 & p_fld(ji ,je_2+2) * p_mask(ji ,je_2+2,1) - ( 1.- p_mask(ji ,je_2+2,1) ) * r_inf , & 1410 & p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) - ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf , & 1411 & p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) - ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf ) 1412 ! 1413 p_fld_crs(ii,2) = zflcrs 1414 ENDIF 1415 1416 DO jj = njstr, njend, nn_facty 1417 DO ji = nistr, niend, nn_factx 1418 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1419 ij = ( jj - njstr ) * rfacty_r + 3 1420 zflcrs = & 1421 & MAX( p_fld(ji ,jj ) * p_mask(ji ,jj ,1) - ( 1.- p_mask(ji ,jj ,1) ) * r_inf , & 1422 & p_fld(ji+1,jj ) * p_mask(ji+1,jj ,1) - ( 1.- p_mask(ji+1,jj ,1) ) * r_inf , & 1423 & p_fld(ji+2,jj ) * p_mask(ji+2,jj ,1) - ( 1.- p_mask(ji+2,jj ,1) ) * r_inf , & 1424 & p_fld(ji ,jj+1) * p_mask(ji ,jj+1,1) - ( 1.- p_mask(ji ,jj+1,1) ) * r_inf , & 1425 & p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) - ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf , & 1426 & p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) - ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf , & 1427 & p_fld(ji ,jj+2) * p_mask(ji ,jj+2,1) - ( 1.- p_mask(ji ,jj+2,1) ) * r_inf , & 1428 & p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) - ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf , & 1429 & p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) - ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf ) 1430 ! 1431 p_fld_crs(ii,ij) = zflcrs 1432 ! 1433 ENDDO 1434 ENDDO 1118 1435 1119 1436 CASE( 'V' ) 1120 1121 DO jk = 1, jpk 1437 1438 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1439 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1440 ijje = mje_crs(2) 1441 ENDIF 1442 ELSE 1443 ijje = mjs_crs(2) 1444 ENDIF 1445 1446 DO ji = nistr, niend, nn_factx 1447 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1448 zflcrs = MAX( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & 1449 & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & 1450 & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ) 1451 ! 1452 p_fld_crs(ii,2) = zflcrs 1453 ENDDO 1454 DO jj = njstr, njend, nn_facty 1122 1455 DO ji = nistr, niend, nn_factx 1123 DO jj = njstr, njend, nn_facty 1124 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1125 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1126 ijje = mje_crs(ij) 1127 ijie = mie_crs(ii) 1128 ! 1129 zflcrs = p_fld(ji ,ijje) * zsurf(ji ,ijje) & 1130 & + p_fld(ji+1,ijje) * zsurf(ji+1,ijje) & 1131 & + p_fld(ji+2,ijje) * zsurf(ji+2,ijje) 1132 ! 1133 p_fld_crs(ii,ij) = zflcrs 1134 ! 1135 ENDDO 1136 ENDDO 1137 ENDDO 1138 1139 1140 CASE( 'U' ) 1141 1142 DO jk = 1, jpk 1143 DO ji = nistr, niend, nn_factx 1144 DO jj = njstr, njend, nn_facty 1145 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1146 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1147 ijje = mje_crs(ij) 1148 ijie = mie_crs(ii) 1149 ! 1150 zflcrs = p_fld(ijie,jj ) * zsurf(ijie,jj ) & 1151 & + p_fld(ijie,jj+1) * zsurf(ijie,jj+1) & 1152 & + p_fld(ijie,jj+2) * zsurf(ijie,jj+2) 1153 ! 1154 p_fld_crs(ii,ij) = zflcrs 1155 ! 1156 ENDDO 1157 ENDDO 1158 ENDDO 1159 1160 END SELECT 1161 1162 IF( PRESENT( p_surf_crs ) ) THEN 1163 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:) 1164 ENDIF 1165 1166 CALL wrk_dealloc( jpi, jpj, zsurf ) 1167 1168 CASE ( 'MAX' ) 1169 1170 SELECT CASE ( cd_type ) 1171 1172 CASE( 'T', 'W' ) 1173 1174 DO ji = nistr, niend, nn_factx 1175 DO jj = njstr, njend, nn_facty 1176 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1177 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1178 ijje = mje_crs(ij) 1179 ijie = mie_crs(ii) 1180 1181 zflcrs = MAX( p_fld(ji ,jj ) * p_mask(ji ,jj ,1), & 1182 & p_fld(ji+1,jj ) * p_mask(ji+1,jj ,1), & 1183 & p_fld(ji+2,jj ) * p_mask(ji+2,jj ,1), & 1184 & p_fld(ji ,jj+1) * p_mask(ji ,jj+1,1), & 1185 & p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1), & 1186 & p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1), & 1187 & p_fld(ji ,jj+2) * p_mask(ji ,jj+2,1), & 1188 & p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1), & 1189 & p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) ) 1190 ! 1191 p_fld_crs(ii,ij) = zflcrs 1192 ! 1193 ENDDO 1194 ENDDO 1195 1196 CASE( 'V' ) 1197 1198 DO ji = nistr, niend, nn_factx 1199 DO jj = njstr, njend, nn_facty 1200 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1201 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1202 ijje = mje_crs(ij) 1203 ijie = mie_crs(ii) 1456 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1457 ij = ( jj - njstr ) * rfacty_r + 3 1458 ijje = mje_crs(ij) 1204 1459 ! 1205 zflcrs = MAX( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) , &1206 & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) , &1207 & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) )1460 zflcrs = MAX( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & 1461 & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf , & 1462 & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ) 1208 1463 ! 1209 1464 p_fld_crs(ii,ij) = zflcrs … … 1213 1468 1214 1469 CASE( 'U' ) 1215 1470 1471 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1472 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1473 je_2 = mje_crs(2) 1474 DO ji = nistr, niend, nn_factx 1475 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1476 ijie = mie_crs(ii) 1477 zflcrs = p_fld(ijie,je_2) * p_mask(ijie,je_2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf 1478 p_fld_crs(ii,2) = zflcrs 1479 ENDDO 1480 ENDIF 1481 ELSE 1482 je_2 = mjs_crs(2) 1483 DO ji = nistr, niend, nn_factx 1484 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1485 ijie = mie_crs(ii) 1486 zflcrs = & 1487 & MAX( p_fld(ijie,je_2 ) * p_mask(ijie,je_2 ,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & 1488 & p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & 1489 & p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ) 1490 p_fld_crs(ii,2) = zflcrs 1491 ENDDO 1492 ENDIF 1493 DO jj = njstr, njend, nn_facty 1494 DO ji = nistr, niend, nn_factx 1495 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1496 ij = ( jj - njstr ) * rfacty_r + 3 1497 ijie = mie_crs(ii) 1498 zflcrs = & 1499 & MAX( p_fld(ijie,jj ) * p_mask(ijie,jj ,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf , & 1500 & p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf , & 1501 & p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ) 1502 p_fld_crs(ii,ij) = zflcrs 1503 ! 1504 ENDDO 1505 ENDDO 1506 1507 END SELECT 1508 1509 CASE ( 'MIN' ) ! Search the min of unmasked grid cells 1510 1511 SELECT CASE ( cd_type ) 1512 1513 CASE( 'T', 'W' ) 1514 1515 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1516 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1517 je_2 = mje_crs(2) 1518 DO ji = nistr, niend, nn_factx 1519 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1520 zflcrs = & 1521 & MIN( p_fld(ji ,je_2) * p_mask(ji ,je_2,1) + ( 1.- p_mask(ji ,je_2,1) ) * r_inf , & 1522 & p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) + ( 1.- p_mask(ji+1,je_2,1) ) * r_inf , & 1523 & p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) + ( 1.- p_mask(ji+2,je_2,1) ) * r_inf ) 1524 ! 1525 p_fld_crs(ii,2) = zflcrs 1526 ENDDO 1527 ENDIF 1528 ELSE 1529 je_2 = mjs_crs(2) 1530 zflcrs = & 1531 & MIN( p_fld(ji ,je_2 ) * p_mask(ji ,je_2 ,1) + ( 1.- p_mask(ji ,je_2 ,1) ) * r_inf , & 1532 & p_fld(ji+1,je_2 ) * p_mask(ji+1,je_2 ,1) + ( 1.- p_mask(ji+1,je_2 ,1) ) * r_inf , & 1533 & p_fld(ji+2,je_2 ) * p_mask(ji+2,je_2 ,1) + ( 1.- p_mask(ji+2,je_2 ,1) ) * r_inf , & 1534 & p_fld(ji ,je_2+1) * p_mask(ji ,je_2+1,1) + ( 1.- p_mask(ji ,je_2+1,1) ) * r_inf , & 1535 & p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) + ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf , & 1536 & p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) + ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf , & 1537 & p_fld(ji ,je_2+2) * p_mask(ji ,je_2+2,1) + ( 1.- p_mask(ji ,je_2+2,1) ) * r_inf , & 1538 & p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) + ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf , & 1539 & p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) + ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf ) 1540 ! 1541 p_fld_crs(ii,2) = zflcrs 1542 ENDIF 1543 1544 DO jj = njstr, njend, nn_facty 1545 DO ji = nistr, niend, nn_factx 1546 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1547 ij = ( jj - njstr ) * rfacty_r + 3 1548 zflcrs = & 1549 & MIN( p_fld(ji ,jj ) * p_mask(ji ,jj ,1) + ( 1.- p_mask(ji ,jj ,1) ) * r_inf , & 1550 & p_fld(ji+1,jj ) * p_mask(ji+1,jj ,1) + ( 1.- p_mask(ji+1,jj ,1) ) * r_inf , & 1551 & p_fld(ji+2,jj ) * p_mask(ji+2,jj ,1) + ( 1.- p_mask(ji+2,jj ,1) ) * r_inf , & 1552 & p_fld(ji ,jj+1) * p_mask(ji ,jj+1,1) + ( 1.- p_mask(ji ,jj+1,1) ) * r_inf , & 1553 & p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf , & 1554 & p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf , & 1555 & p_fld(ji ,jj+2) * p_mask(ji ,jj+2,1) + ( 1.- p_mask(ji ,jj+2,1) ) * r_inf , & 1556 & p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf , & 1557 & p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) + ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf ) 1558 ! 1559 p_fld_crs(ii,ij) = zflcrs 1560 ! 1561 ENDDO 1562 ENDDO 1563 1564 CASE( 'V' ) 1565 1566 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1567 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1568 ijje = mje_crs(2) 1569 ENDIF 1570 ELSE 1571 ijje = mjs_crs(2) 1572 ENDIF 1573 1216 1574 DO ji = nistr, niend, nn_factx 1217 DO jj = njstr, njend, nn_facty 1218 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1219 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1220 ijje = mje_crs(ij) 1221 ijie = mie_crs(ii) 1575 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1576 zflcrs = MIN( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & 1577 & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & 1578 & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ) 1579 ! 1580 p_fld_crs(ii,2) = zflcrs 1581 ENDDO 1582 DO jj = njstr, njend, nn_facty 1583 DO ji = nistr, niend, nn_factx 1584 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1585 ij = ( jj - njstr ) * rfacty_r + 3 1586 ijje = mje_crs(ij) 1222 1587 ! 1223 zflcrs = M AX( p_fld(ijie,jj ) * p_mask(ijie,jj ,1), &1224 & p_fld( ijie,jj+1) * p_mask(ijie,jj+1,1), &1225 & p_fld( ijie,jj+2) * p_mask(ijie,jj+2,1))1588 zflcrs = MIN( p_fld(ji ,ijje) * p_mask(ji ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & 1589 & p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf , & 1590 & p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ) 1226 1591 ! 1227 1592 p_fld_crs(ii,ij) = zflcrs … … 1229 1594 ENDDO 1230 1595 ENDDO 1231 1232 END SELECT1233 1234 CASE ( 'MIN' )1235 ! Search the min of masked grid cells1236 SELECT CASE ( cd_type )1237 1596 1238 CASE( 'T', 'W' ) 1239 1240 DO ji = nistr, niend, nn_factx 1241 DO jj = njstr, njend, nn_facty 1242 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1243 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1244 ijje = mje_crs(ij) 1245 ijie = mie_crs(ii) 1246 1247 zflcrs = MIN( p_fld(ji ,jj ) * ( 1. + ( 1. - p_mask(ji ,jj ,1) ) * zeps ), & 1248 & p_fld(ji+1,jj ) * ( 1. + ( 1. - p_mask(ji+1,jj ,1) ) * zeps ), & 1249 & p_fld(ji+2,jj ) * ( 1. + ( 1. - p_mask(ji+2,jj ,1) ) * zeps ), & 1250 & p_fld(ji ,jj+1) * ( 1. + ( 1. - p_mask(ji ,jj ,1) ) * zeps ), & 1251 & p_fld(ji+1,jj+1) * ( 1. + ( 1. - p_mask(ji+1,jj+1,1) ) * zeps ), & 1252 & p_fld(ji+2,jj+1) * ( 1. + ( 1. - p_mask(ji+2,jj+2,1) ) * zeps ), & 1253 & p_fld(ji ,jj+2) * ( 1. + ( 1. - p_mask(ji ,jj ,1) ) * zeps ), & 1254 & p_fld(ji+1,jj+2) * ( 1. + ( 1. - p_mask(ji+1,jj+1,1) ) * zeps ), & 1255 & p_fld(ji+2,jj+2) * ( 1. + ( 1. - p_mask(ji+2,jj+2,1) ) * zeps ) ) 1256 ! 1257 p_fld_crs(ii,ij) = zflcrs * p_mask_crs(ii,ij,1) 1258 ! 1597 CASE( 'U' ) 1598 1599 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1600 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1601 je_2 = mje_crs(2) 1602 DO ji = nistr, niend, nn_factx 1603 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1604 ijie = mie_crs(ii) 1605 zflcrs = p_fld(ijie,je_2) * p_mask(ijie,je_2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf 1606 1607 p_fld_crs(ii,2) = zflcrs 1608 ENDDO 1609 ENDIF 1610 ELSE 1611 je_2 = mjs_crs(2) 1612 DO ji = nistr, niend, nn_factx 1613 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1614 ijie = mie_crs(ii) 1615 zflcrs = & 1616 & MIN( p_fld(ijie,je_2 ) * p_mask(ijie,je_2 ,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & 1617 & p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf , & 1618 & p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ) 1619 p_fld_crs(ii,2) = zflcrs 1620 ENDDO 1621 ENDIF 1622 DO jj = njstr, njend, nn_facty 1623 DO ji = nistr, niend, nn_factx 1624 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1625 ij = ( jj - njstr ) * rfacty_r + 3 1626 ijie = mie_crs(ii) 1627 zflcrs = & 1628 & MIN( p_fld(ijie,jj ) * p_mask(ijie,jj ,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf , & 1629 & p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf , & 1630 & p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ) 1631 p_fld_crs(ii,ij) = zflcrs 1632 ! 1259 1633 ENDDO 1260 1634 ENDDO 1261 1262 CASE( 'V' ) 1263 1264 DO ji = nistr, niend, nn_factx 1265 DO jj = njstr, njend, nn_facty 1266 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1267 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1268 ijje = mje_crs(ij) 1269 ijie = mie_crs(ii) 1270 1271 zflcrs = MIN( p_fld(ji ,ijje) * ( 1. + ( 1. - p_mask(ji ,ijje,1) ) * zeps ), & 1272 & p_fld(ji+1,ijje) * ( 1. + ( 1. - p_mask(ji+1,ijje,1) ) * zeps ), & 1273 & p_fld(ji+2,ijje) * ( 1. + ( 1. - p_mask(ji+2,ijje,1) ) * zeps ) ) 1274 ! 1275 p_fld_crs(ii,ij) = zflcrs * p_mask_crs(ii,ij,1) 1276 ! 1277 ENDDO 1278 ENDDO 1279 1280 CASE( 'U' ) 1281 1282 DO ji = nistr, niend, nn_factx 1283 DO jj = njstr, njend, nn_facty 1284 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1285 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1286 ijje = mje_crs(ij) 1287 ijie = mie_crs(ii) 1288 1289 zflcrs = MIN( p_fld(ijie,jj ) * ( 1. + ( 1. - p_mask(ijie,jj ,1) ) * zeps ), & 1290 & p_fld(ijie,jj+1) * ( 1. + ( 1. - p_mask(ijie,jj+1,1) ) * zeps ), & 1291 & p_fld(ijie,jj+2) * ( 1. + ( 1. - p_mask(ijie,jj+2,1) ) * zeps ) ) 1292 ! 1293 p_fld_crs(ii,ij) = zflcrs * p_mask_crs(ii,ij,1) 1294 ! 1295 ENDDO 1296 ENDDO 1297 END SELECT 1298 ! 1635 1636 END SELECT 1637 ! 1299 1638 END SELECT 1300 1639 ! 1301 CALL crs_lbc_lnk( p_fld_crs, cd_type, 1.0)1640 CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn ) 1302 1641 ! 1303 1642 END SUBROUTINE crs_dom_ope_2d … … 1316 1655 !! Local variables 1317 1656 INTEGER :: ji, jj, jk ! dummy loop indices 1318 INTEGER :: ijie, ijje, ii, ij 1657 INTEGER :: ijie, ijje, ii, ij, je_2 1319 1658 REAL(wp) :: ze3crs 1659 REAL(wp), DIMENSION(:,:,:), POINTER :: zmask, zsurf 1320 1660 1321 1661 !!---------------------------------------------------------------- 1662 1663 p_e3_crs (:,:,:) = 0. 1664 p_e3_max_crs(:,:,:) = 1. 1322 1665 1323 SELECT CASE ( cd_type ) 1324 1325 CASE ('T', 'U', 'V') 1326 1327 DO jk = 1 , jpk 1328 DO ji = nistr, niend, nn_factx 1329 DO jj = njstr, njend, nn_facty 1330 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1331 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1332 ijje = mje_crs(ij) 1333 ijie = mie_crs(ii) 1334 ! 1335 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk) + & 1336 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk) + & 1337 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk) + & 1338 & p_e3(ji ,jj+1,jk) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,jk) + & 1339 & p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk) + & 1340 & p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) + & 1341 & p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk) + & 1342 & p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) + & 1343 & p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk) 1344 1345 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 1346 ! 1347 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk), & 1348 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk), & 1349 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk), & 1350 & p_e3(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk), & 1351 & p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk), & 1352 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk), & 1353 & p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk), & 1354 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk), & 1355 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) ) 1356 1357 p_e3_max_crs(ii,ij,jk) = ze3crs 1358 ENDDO 1359 ENDDO 1360 ENDDO 1361 1362 CASE ('W') 1363 1364 DO jk = 2 , jpk 1365 DO ji = nistr, niend, nn_factx 1366 DO jj = njstr, njend, nn_facty 1367 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1368 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1369 ijje = mje_crs(ij) 1370 ijie = mie_crs(ii) 1371 ! 1372 ze3crs = p_e3(ji ,jj ,jk) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,jk-1) + & 1373 & p_e3(ji+1,jj ,jk) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,jk-1) + & 1374 & p_e3(ji+2,jj ,jk) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,jk-1) + & 1375 & p_e3(ji ,jj+1,jk) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,jk-1) + & 1376 & p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk-1) + & 1377 & p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk-1) + & 1378 & p_e3(ji ,jj+2,jk) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,jk-1) + & 1379 & p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk-1) + & 1380 & p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk-1) 1381 1382 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 1383 ! 1384 ze3crs = MAX( p_e3(ji ,jj ,jk) * p_mask(ji ,jj ,jk-1), & 1385 & p_e3(ji+1,jj ,jk) * p_mask(ji+1,jj ,jk-1), & 1386 & p_e3(ji+2,jj ,jk) * p_mask(ji+2,jj ,jk-1), & 1387 & p_e3(ji ,jj+1,jk) * p_mask(ji ,jj+1,jk-1), & 1388 & p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1), & 1389 & p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1), & 1390 & p_e3(ji ,jj+2,jk) * p_mask(ji ,jj+2,jk-1), & 1391 & p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1), & 1392 & p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) ) 1393 1394 p_e3_max_crs(ii,ij,jk) = ze3crs 1395 ENDDO 1396 ENDDO 1397 ENDDO 1398 1399 DO ji = nistr, niend, nn_factx 1400 DO jj = njstr, njend, nn_facty 1401 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1402 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1403 ijje = mje_crs(ij) 1404 ijie = mie_crs(ii) 1405 ! 1406 ze3crs = p_e3(ji ,jj ,1) * p_e1(ji ,jj ) * p_e2(ji ,jj ) * p_mask(ji ,jj ,1) + & 1407 & p_e3(ji+1,jj ,1) * p_e1(ji+1,jj ) * p_e2(ji+1,jj ) * p_mask(ji+1,jj ,1) + & 1408 & p_e3(ji+2,jj ,1) * p_e1(ji+2,jj ) * p_e2(ji+2,jj ) * p_mask(ji+2,jj ,1) + & 1409 & p_e3(ji ,jj+1,1) * p_e1(ji ,jj+1) * p_e2(ji ,jj+1) * p_mask(ji ,jj+1,1) + & 1410 & p_e3(ji+1,jj+1,1) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + & 1411 & p_e3(ji+2,jj+1,1) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + & 1412 & p_e3(ji ,jj+2,1) * p_e1(ji ,jj+2) * p_e2(ji ,jj+2) * p_mask(ji ,jj+2,1) + & 1413 & p_e3(ji+1,jj+2,1) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + & 1414 & p_e3(ji+2,jj+2,1) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,1) 1415 1416 p_e3_crs(ii,ij,1) = ze3crs / p_sfc_crs(ii,ij,1) 1417 ! 1418 ze3crs = MAX( p_e3(ji ,jj ,1) * p_mask(ji ,jj ,1), & 1419 & p_e3(ji+1,jj ,1) * p_mask(ji+1,jj ,1), & 1420 & p_e3(ji+2,jj ,1) * p_mask(ji+2,jj ,1), & 1421 & p_e3(ji ,jj+1,1) * p_mask(ji ,jj+1,1), & 1422 & p_e3(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1), & 1423 & p_e3(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1), & 1424 & p_e3(ji ,jj+2,1) * p_mask(ji ,jj+2,1), & 1425 & p_e3(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1), & 1426 & p_e3(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) ) 1427 1428 p_e3_max_crs(ii,ij,1) = ze3crs 1429 ENDDO 1430 ENDDO 1431 1432 END SELECT 1433 ! 1434 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, pval=1.0 ) 1435 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 ) 1436 ! 1666 1667 CALL wrk_alloc( jpi, jpj, jpk, zmask, zsurf ) 1668 1669 SELECT CASE ( cd_type ) 1670 CASE( 'W' ) 1671 zmask(:,:,1) = p_mask(:,:,1) 1672 DO jk = 2, jpk 1673 zmask(:,:,jk) = p_mask(:,:,jk-1) 1674 ENDDO 1675 CASE DEFAULT 1676 DO jk = 1, jpk 1677 zmask(:,:,jk) = p_mask(:,:,jk) 1678 ENDDO 1679 END SELECT 1680 1681 DO jk = 1, jpk 1682 zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 1683 ENDDO 1684 1685 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1686 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1687 je_2 = mje_crs(2) 1688 DO jk = 1 , jpk 1689 DO ji = nistr, niend, nn_factx 1690 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1691 ze3crs = zsurf(ji ,je_2,jk) * zmask(ji ,je_2,jk) & 1692 & + zsurf(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) & 1693 & + zsurf(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) 1694 1695 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 1696 ! 1697 ze3crs = MAX( p_e3(ji ,je_2,jk) * zmask(ji ,je_2,jk), & 1698 & p_e3(ji+1,je_2,jk) * zmask(ji+1,je_2,jk), & 1699 & p_e3(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) ) 1700 ! 1701 p_e3_max_crs(ii,2,jk) = ze3crs 1702 ENDDO 1703 ENDDO 1704 ENDIF 1705 ELSE 1706 je_2 = mjs_crs(2) 1707 DO jk = 1 , jpk 1708 DO ji = nistr, niend, nn_factx 1709 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1710 ze3crs = zsurf(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk) & 1711 & + zsurf(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk) & 1712 & + zsurf(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk) & 1713 & + zsurf(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk) & 1714 & + zsurf(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) & 1715 & + zsurf(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) & 1716 & + zsurf(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk) & 1717 & + zsurf(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) & 1718 & + zsurf(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) 1719 1720 p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk) 1721 ! 1722 ze3crs = MAX( p_e3(ji ,je_2 ,jk) * zmask(ji ,je_2 ,jk), & 1723 & p_e3(ji+1,je_2 ,jk) * zmask(ji+1,je_2 ,jk), & 1724 & p_e3(ji+2,je_2 ,jk) * zmask(ji+2,je_2 ,jk), & 1725 & p_e3(ji ,je_2+1,jk) * zmask(ji ,je_2+1,jk), & 1726 & p_e3(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk), & 1727 & p_e3(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk), & 1728 & p_e3(ji ,je_2+2,jk) * zmask(ji ,je_2+2,jk), & 1729 & p_e3(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk), & 1730 & p_e3(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) ) 1731 1732 p_e3_max_crs(ii,2,jk) = ze3crs 1733 ENDDO 1734 ENDDO 1735 ENDIF 1736 DO jk = 1 , jpk 1737 DO jj = njstr, njend, nn_facty 1738 DO ji = nistr, niend, nn_factx 1739 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1740 ij = ( jj - njstr ) * rfacty_r + 3 1741 ze3crs = zsurf(ji ,jj ,jk) * zmask(ji ,jj ,jk) & 1742 & + zsurf(ji+1,jj ,jk) * zmask(ji+1,jj ,jk) & 1743 & + zsurf(ji+2,jj ,jk) * zmask(ji+2,jj ,jk) & 1744 & + zsurf(ji ,jj+1,jk) * zmask(ji ,jj+1,jk) & 1745 & + zsurf(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) & 1746 & + zsurf(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) & 1747 & + zsurf(ji ,jj+2,jk) * zmask(ji ,jj+2,jk) & 1748 & + zsurf(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) & 1749 & + zsurf(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) 1750 1751 p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk) 1752 ! 1753 ze3crs = MAX( p_e3(ji ,jj ,jk) * zmask(ji ,jj ,jk), & 1754 & p_e3(ji+1,jj ,jk) * zmask(ji+1,jj ,jk), & 1755 & p_e3(ji+2,jj ,jk) * zmask(ji+2,jj ,jk), & 1756 & p_e3(ji ,jj+1,jk) * zmask(ji ,jj+1,jk), & 1757 & p_e3(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk), & 1758 & p_e3(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk), & 1759 & p_e3(ji ,jj+2,jk) * zmask(ji ,jj+2,jk), & 1760 & p_e3(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk), & 1761 & p_e3(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) ) 1762 1763 p_e3_max_crs(ii,ij,jk) = ze3crs 1764 ENDDO 1765 ENDDO 1766 ENDDO 1767 1768 CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, pval=1.0 ) 1769 CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 ) 1770 ! 1771 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zmask ) 1772 ! 1437 1773 END SUBROUTINE crs_dom_e3 1438 1774 … … 1440 1776 1441 1777 !! Arguments 1442 CHARACTER(len=1), INTENT(in):: cd_type ! grid type T, W ( U, V, F)1443 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in):: p_mask ! Parent grid T mask1444 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in), OPTIONAL :: p_e1, p_e2 ! 3D tracer T or W on parent grid1445 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in), OPTIONAL :: p_e3 ! 3D tracer T or W on parent grid1446 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs ! Coarse grid box east or north face quantity1447 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs_msk ! Coarse grid box east or north face quantity1778 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) 1779 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_mask ! Parent grid T mask 1780 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in), OPTIONAL :: p_e1, p_e2 ! 3D tracer T or W on parent grid 1781 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in), OPTIONAL :: p_e3 ! 3D tracer T or W on parent grid 1782 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs ! Coarse grid box east or north face quantity 1783 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs_msk ! Coarse grid box east or north face quantity 1448 1784 1449 1785 !! Local variables 1450 1786 INTEGER :: ji, jj, jk ! dummy loop indices 1451 INTEGER :: ijie, ijje, ii, ij 1452 REAL(wp), DIMENSION(:,:) , POINTER :: zsurf 1453 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf3d 1454 REAL(wp) :: zsfcrs, zsfcrs_msk 1787 INTEGER :: ii, ij, je_2 1788 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk 1455 1789 !!---------------------------------------------------------------- 1456 1790 ! Initialize 1457 1791 1458 1792 1793 CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 1459 1794 ! 1460 1795 SELECT CASE ( cd_type ) 1461 1796 1462 CASE ('W') 1463 1464 CALL wrk_alloc( jpi, jpj, zsurf ) 1465 zsurf(:,:) = p_e1(:,:) * p_e2(:,:) 1466 1467 DO ji = nistr, niend, nn_factx 1468 DO jj = njstr, njend, nn_facty 1469 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1470 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1471 ijje = mje_crs(ij) 1472 ijie = mie_crs(ii) 1797 CASE ('W') 1798 DO jk = 1, jpk 1799 zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 1800 ENDDO 1801 zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) 1802 DO jk = 2, jpk 1803 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) 1804 ENDDO 1805 1806 CASE ('V') 1807 DO jk = 1, jpk 1808 zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk) 1809 ENDDO 1810 DO jk = 1, jpk 1811 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 1812 ENDDO 1813 1814 CASE ('U') 1815 DO jk = 1, jpk 1816 zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk) 1817 ENDDO 1818 DO jk = 1, jpk 1819 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 1820 ENDDO 1821 1822 CASE DEFAULT 1823 DO jk = 1, jpk 1824 zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 1825 ENDDO 1826 DO jk = 1, jpk 1827 zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 1828 ENDDO 1829 END SELECT 1830 1831 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN !!cc bande du sud style ORCA2 1832 IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN 1833 je_2 = mje_crs(2) 1834 DO jk = 1, jpk 1835 DO ji = nistr, niend, nn_factx 1836 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1837 ! 1838 p_surf_crs (ii,2,jk) = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & 1839 & + zsurf(ji,je_2-1,jk) + zsurf(ji+1,je_2-1,jk) + zsurf(ji+2,je_2-1,jk) ! Why ????? 1473 1840 ! 1474 zsfcrs = zsurf(ji,jj ) + zsurf(ji+1,jj ) + zsurf(ji+2,jj ) & 1475 & + zsurf(ji,jj+1) + zsurf(ji+1,jj+1) + zsurf(ji+2,jj+1) & 1476 & + zsurf(ji,jj+2) + zsurf(ji+1,jj+2) + zsurf(ji+2,jj+2) 1477 ! 1478 zsfcrs_msk = zsurf(ji ,jj ) * p_mask(ji ,jj ,1) & 1479 & + zsurf(ji+1,jj ) * p_mask(ji+1,jj ,1) & 1480 & + zsurf(ji+2,jj ) * p_mask(ji+2,jj ,1) & 1481 & + zsurf(ji ,jj+1) * p_mask(ji ,jj+1,1) & 1482 & + zsurf(ji+1,jj+1) * p_mask(ji+1,jj+1,1) & 1483 & + zsurf(ji+2,jj+1) * p_mask(ji+2,jj+1,1) & 1484 & + zsurf(ji ,jj+2) * p_mask(ji ,jj+2,1) & 1485 & + zsurf(ji+1,jj+2) * p_mask(ji+1,jj+2,1) & 1486 & + zsurf(ji+2,jj+2) * p_mask(ji+2,jj+2,1) 1487 ! 1488 p_surf_crs (ii,ij,1) = zsfcrs 1489 p_surf_crs_msk(ii,ij,1) = zsfcrs_msk 1841 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk) 1490 1842 ! 1491 1843 ENDDO 1492 1844 ENDDO 1493 DO jk = 2, jpk 1845 ENDIF 1846 ELSE 1847 je_2 = mjs_crs(2) 1848 DO jk = 1, jpk 1849 DO ji = nistr, niend, nn_factx 1850 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1851 ! 1852 p_surf_crs (ii,2,jk) = zsurf(ji,je_2 ,jk) + zsurf(ji+1,je_2 ,jk) + zsurf(ji+2,je_2 ,jk) & 1853 & + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) & 1854 & + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 1855 1856 p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2 ,jk) + zsurfmsk(ji+1,je_2 ,jk) + zsurfmsk(ji+2,je_2 ,jk) & 1857 & + zsurfmsk(ji,je_2+1,jk) + zsurfmsk(ji+1,je_2+1,jk) + zsurfmsk(ji+2,je_2+1,jk) & 1858 & + zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk) 1859 ENDDO 1860 ENDDO 1861 ENDIF 1862 1863 DO jk = 1, jpk 1864 DO jj = njstr, njend, nn_facty 1865 DO ji = nistr, niend, nn_factx 1866 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1867 ij = ( jj - njstr ) * rfacty_r + 3 1494 1868 ! 1495 p_surf_crs(:,:,jk) = p_surf_crs(:,:,1) 1496 ! 1497 DO ji = nistr, niend, nn_factx 1498 DO jj = njstr, njend, nn_facty 1499 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 ! cordinate in parent grid 1500 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1501 ijje = mje_crs(ij) 1502 ijie = mie_crs(ii) 1503 ! 1504 zsfcrs_msk = zsurf(ji ,jj ) * p_mask(ji ,jj ,jk-1) & 1505 & + zsurf(ji+1,jj ) * p_mask(ji+1,jj ,jk-1) & 1506 & + zsurf(ji+2,jj ) * p_mask(ji+2,jj ,jk-1) & 1507 & + zsurf(ji ,jj+1) * p_mask(ji ,jj+1,jk-1) & 1508 & + zsurf(ji+1,jj+1) * p_mask(ji+1,jj+1,jk-1) & 1509 & + zsurf(ji+2,jj+1) * p_mask(ji+2,jj+1,jk-1) & 1510 & + zsurf(ji ,jj+2) * p_mask(ji ,jj+2,jk-1) & 1511 & + zsurf(ji+1,jj+2) * p_mask(ji+1,jj+2,jk-1) & 1512 & + zsurf(ji+2,jj+2) * p_mask(ji+2,jj+2,jk-1) 1513 ! 1514 p_surf_crs_msk(ii,ij,jk) = zsfcrs_msk 1515 ! 1516 ENDDO 1517 ENDDO 1518 ENDDO 1519 1520 CALL wrk_dealloc( jpi, jpj, zsurf ) 1521 1522 CASE( 'V' ) 1523 1524 CALL wrk_alloc( jpi, jpj, jpk, zsurf3d ) 1525 DO jk = 1, jpk 1526 zsurf3d(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk) 1527 ENDDO 1528 1529 DO jk = 1, jpk 1530 DO ji = nistr, niend, nn_factx 1531 DO jj = njstr, njend, nn_facty 1532 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1533 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1534 ijje = mje_crs(ij) 1535 ijie = mie_crs(ii) 1536 ! 1537 zsfcrs = zsurf3d(ji,ijje,jk) + zsurf3d(ji+1,ijje,jk) + zsurf3d(ji+2,ijje,jk) 1538 ! 1539 zsfcrs_msk = zsurf3d(ji ,ijje,jk) * p_mask(ji ,ijje,jk) & 1540 & + zsurf3d(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) & 1541 & + zsurf3d(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) 1542 ! 1543 p_surf_crs (ii,ij,jk) = zsfcrs 1544 p_surf_crs_msk(ii,ij,jk) = zsfcrs_msk 1545 ! 1546 ENDDO 1547 ENDDO 1548 ENDDO 1549 1550 CALL wrk_dealloc( jpi, jpj, jpk, zsurf3d ) 1551 1552 CASE( 'U' ) 1553 1554 CALL wrk_alloc( jpi, jpj, jpk, zsurf3d ) 1555 DO jk = 1, jpk 1556 zsurf3d(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk) 1557 ENDDO 1558 1559 DO jk = 1, jpk 1560 DO ji = nistr, niend, nn_factx 1561 DO jj = njstr, njend, nn_facty 1562 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1563 ij = ( jj - mjs_crs(2) ) * rfacty_r + 2 1564 ijje = mje_crs(ij) 1565 ijie = mie_crs(ii) 1566 ! 1567 zsfcrs = zsurf3d(ijie,jj,jk) + zsurf3d(ijie,jj+1,jk) + zsurf3d(ijie,jj+2,jk) 1568 ! 1569 zsfcrs_msk = zsurf3d(ijie ,jj,jk) * p_mask(ijie,jj ,jk) & 1570 & + zsurf3d(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) & 1571 & + zsurf3d(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) 1572 ! 1573 p_surf_crs (ii,ij,jk) = zsfcrs 1574 p_surf_crs_msk(ii,ij,jk) = zsfcrs_msk 1575 ! 1576 ENDDO 1577 ENDDO 1578 ENDDO 1579 1580 CALL wrk_dealloc( jpi, jpj, jpk, zsurf3d ) 1581 1582 END SELECT 1583 1869 p_surf_crs (ii,ij,jk) = zsurf(ji,jj ,jk) + zsurf(ji+1,jj ,jk) + zsurf(ji+2,jj ,jk) & 1870 & + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) & 1871 & + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 1872 1873 p_surf_crs_msk(ii,ij,jk) = zsurfmsk(ji,jj ,jk) + zsurfmsk(ji+1,jj ,jk) + zsurfmsk(ji+2,jj ,jk) & 1874 & + zsurfmsk(ji,jj+1,jk) + zsurfmsk(ji+1,jj+1,jk) + zsurfmsk(ji+2,jj+1,jk) & 1875 & + zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) 1876 ENDDO 1877 ENDDO 1878 ENDDO 1879 1584 1880 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0, pval=1.0 ) 1585 1881 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) 1586 1882 1883 CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ) 1587 1884 1588 1885 END SUBROUTINE crs_dom_sfc … … 1601 1898 INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices 1602 1899 INTEGER :: ierr ! allocation error status 1603 1604 ! 1.a. Define global domain indices 1900 1901 1902 ! 1.a. Define global domain indices : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points 1605 1903 jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 2 1606 jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj 1904 ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj 1905 ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 3 1906 jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3 1607 1907 jpiglo_crsm1 = jpiglo_crs - 1 1608 1908 jpjglo_crsm1 = jpjglo_crs - 1 1609 1909 1610 ! 1.b. Define local domain indices 1611 jpi_crs = ( jpiglo_crs-2 * jpreci + (jpni-1) ) / jpni + 2*jpreci 1612 jpj_crs = ( jpjglo_crs-2 * jprecj + (jpnj-1) ) / jpnj + 2*jprecj 1910 jpi_crs = ( jpiglo_crs - 2 * jpreci + (jpni-1) ) / jpni + 2 * jpreci 1911 jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj 1912 1913 IF( noso < 0 ) jpj_crs = jpj_crs + 1 ! add a local band on southern processors 1613 1914 1614 1915 jpi_crsm1 = jpi_crs - 1 … … 1618 1919 1619 1920 ierr = crs_dom_alloc() ! allocate most coarse grid arrays 1620 ! 2.a Define processor domain 1921 1922 ! 2.a Define processor domain 1621 1923 IF( .NOT. lk_mpp ) THEN 1622 1924 nimpp_crs = 1 … … 1628 1930 nlei_crs = jpi_crs 1629 1931 nlej_crs = jpj_crs 1630 1631 1932 ELSE 1632 1933 ! Initialisation of most local variables - … … 1642 1943 ! Calculs suivant une découpage en j 1643 1944 DO jn = 1, jpnij, jpni 1644 IF( jn < ( jpnij-jpni + 1)) THEN1945 IF( jn < ( jpnij - jpni + 1 ) ) THEN 1645 1946 nlejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) & 1646 1947 & - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) ) … … 1648 1949 nlejt_crs(jn) = AINT( REAL( nlejt(jn) / nn_facty, wp ) ) + 1 1649 1950 ENDIF 1650 1951 IF( noso < 0 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 1651 1952 SELECT CASE( ibonjt(jn) ) 1652 1953 CASE ( -1 ) 1653 IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) 1954 IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 1654 1955 nlcjt_crs(jn) = nlejt_crs(jn) + jprecj 1655 1956 nldjt_crs(jn) = nldjt(jn) … … 1657 1958 CASE ( 0 ) 1658 1959 1960 nldjt_crs(jn) = nldjt(jn) 1961 IF( nldjt(jn) == 1 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 1659 1962 nlejt_crs(jn) = nlejt_crs(jn) + jprecj 1660 1963 nlcjt_crs(jn) = nlejt_crs(jn) + jprecj 1661 nldjt_crs(jn) = nldjt(jn)1662 1964 1663 1965 CASE ( 1, 2 ) … … 1670 1972 STOP 1671 1973 END SELECT 1672 1673 njmppt_crs(jn) = ANINT(REAL((njmppt(jn) + 1 + MOD( jpjglo - njmppt(jn) + 1, nn_facty )) / nn_facty, wp ) ) 1974 IF( nlcjt_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 1 1975 1976 IF(nldjt_crs(jn) == 1 ) THEN 1977 njmppt_crs(jn) = 1 1978 ELSE 1979 njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) ) 1980 ENDIF 1674 1981 1675 1982 DO jj = jn + 1, jn + jpni - 1 … … 1685 1992 njmpp_crs = njmppt_crs(nproc + 1) 1686 1993 1687 !!!! Calcul suivant un decoupage en i 1688 DO jn = 1, jpni 1689 IF( jn < jpni ) THEN 1690 1691 nleit_crs(jn) = AINT( REAL( ( jpiglo - (nimppt(jn ) - 1) ) / nn_factx, wp ) ) & 1692 & - AINT( REAL( ( jpiglo - (nimppt(jn+1) - 1) ) / nn_factx, wp ) ) 1693 ELSE 1694 nleit_crs(jn) = AINT( REAL( ( jpiglo - (nimppt(jn ) - 1) ) / nn_factx, wp ) ) 1695 ENDIF 1696 SELECT CASE( ibonit(jn) ) 1697 1698 CASE ( -1 ) 1699 nleit_crs(jn) = nleit_crs(jn) + jpreci 1700 nlcit_crs(jn) = nleit_crs(jn) + jpreci 1701 nldit_crs(jn) = nldit(jn) 1994 ! Calcul suivant un decoupage en i 1995 DO jn = 1, jpni 1996 IF( jn == 1 ) THEN 1997 nleit_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + nlcit(jn ) ) / nn_factx, wp) ) 1998 ELSE 1999 nleit_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + nlcit(jn ) ) / nn_factx, wp) ) & 2000 & - AINT( REAL( ( nimppt(jn-1) - 1 + nlcit(jn-1) ) / nn_factx, wp) ) 2001 ENDIF 2002 2003 SELECT CASE( ibonit(jn) ) 2004 CASE ( -1 ) 2005 nleit_crs(jn) = nleit_crs(jn) + jpreci 2006 nlcit_crs(jn) = nleit_crs(jn) + jpreci 2007 nldit_crs(jn) = nldit(jn) 1702 2008 1703 1704 1705 1706 2009 CASE ( 0 ) 2010 nleit_crs(jn) = nleit_crs(jn) + jpreci 2011 nlcit_crs(jn) = nleit_crs(jn) + jpreci 2012 nldit_crs(jn) = nldit(jn) 1707 2013 1708 1709 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 )nleit_crs(jn) = nleit_crs(jn) + 11710 1711 1712 1713 1714 1715 1716 1717 1718 nimppt_crs(jn) =ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 11719 DO jj = jn+jpni , jpnij, jpni1720 1721 1722 1723 1724 1725 2014 CASE ( 1, 2 ) 2015 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) nleit_crs(jn) = nleit_crs(jn) + 1 2016 nleit_crs(jn) = nleit_crs(jn) + jpreci 2017 nlcit_crs(jn) = nleit_crs(jn) 2018 nldit_crs(jn) = nldit(jn) 2019 2020 CASE DEFAULT 2021 STOP 2022 END SELECT 2023 2024 nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 2025 DO jj = jn + jpni , jpnij, jpni 2026 nleit_crs(jj) = nleit_crs(jn) 2027 nlcit_crs(jj) = nlcit_crs(jn) 2028 nldit_crs(jj) = nldit_crs(jn) 2029 nimppt_crs(jj)= nimppt_crs(jn) 2030 ENDDO 2031 ENDDO 1726 2032 1727 2033 nlei_crs = nleit_crs(nproc + 1) … … 1730 2036 nimpp_crs = nimppt_crs(nproc + 1) 1731 2037 1732 ! rajouter la condition stop2038 ! No coarsening with zoom 1733 2039 IF( jpizoom /= 1 .OR. jpjzoom /= 1) STOP 2040 1734 2041 DO ji = 1, jpi_crs 1735 2042 mig_crs(ji) = ji + nimpp_crs - 1 … … 1737 2044 DO jj = 1, jpj_crs 1738 2045 mjg_crs(jj) = jj + njmpp_crs - 1! 2046 ENDDO 2047 2048 DO ji = 1, jpiglo_crs 2049 mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) 2050 mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) ) 2051 ENDDO 2052 2053 DO jj = 1, jpjglo_crs 2054 mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) 2055 mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) ) 1739 2056 ENDDO 1740 2057 … … 1773 2090 1774 2091 1775 IF 2092 IF(lwp) THEN 1776 2093 WRITE(numout,*) 1777 2094 WRITE(numout,*) 'crs_init : coarse grid dimensions' … … 1793 2110 WRITE(numout,*) ' njmpp = ' , njmpp 1794 2111 WRITE(numout,*) ' njmpp_full = ', njmpp_full 1795 WRITE(numout,*) ' nreci' , nreci1796 ! WRITE(numout,*) ' nlejt' , nlejt1797 ! WRITE(numout,*) ' nldjt' , nldjt1798 ! WRITE(numout,*) ' nlcjt' , nlcjt1799 ! WRITE(numout,*) ' njmppt' , njmppt1800 ! WRITE(numout,*) ' nleit' , nleit1801 ! WRITE(numout,*) ' nldit' , nldit1802 ! WRITE(numout,*) ' nlcit' , nlcit1803 ! WRITE(numout,*) ' nimppt' , nimppt1804 ! WRITE(numout,*) ' nleit_full' , nleit_full1805 2112 WRITE(numout,*) 1806 2113 ENDIF 1807 2114 1808 1809 2115 CALL dom_grid_glo 1810 2116 … … 1847 2153 1848 2154 DO ji = 2, jpiglo_crsm1 1849 ijie = ( ji*nn_factx)-nn_factx !cc1850 ijis = ijie -nn_factx+12155 ijie = ( ji * nn_factx ) - nn_factx !cc 2156 ijis = ijie - nn_factx + 1 1851 2157 mis2_crs(ji) = ijis 1852 2158 mie2_crs(ji) = ijie 1853 2159 ENDDO 1854 IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo-22160 IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 2 1855 2161 1856 2162 ! Handle first the northernmost bin … … 1859 2165 ENDIF 1860 2166 1861 DO jj = 2, jpjglo_crs m11862 ijje = ijjgloT -nn_facty*(jj-2)1863 ijjs = ijje -nn_facty+11864 mjs2_crs(jpjglo_crs-jj+ 1) = ijjs1865 mje2_crs(jpjglo_crs-jj+ 1) = ijje2167 DO jj = 2, jpjglo_crs 2168 ijje = ijjgloT - nn_facty * ( jj - 3 ) 2169 ijjs = ijje - nn_facty + 1 2170 mjs2_crs(jpjglo_crs-jj+2) = ijjs 2171 mje2_crs(jpjglo_crs-jj+2) = ijje 1866 2172 ENDDO 1867 2173 … … 1872 2178 1873 2179 DO ji = 2, jpiglo_crsm1 1874 ijie = ( ji*nn_factx)-nn_factx1875 ijis = ijie -nn_factx+12180 ijie = ( ji * nn_factx ) - nn_factx 2181 ijis = ijie - nn_factx + 1 1876 2182 mis2_crs(ji) = ijis 1877 2183 mie2_crs(ji) = ijie 1878 2184 ENDDO 1879 IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo -22185 IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo - 2 1880 2186 1881 2187 ! Treat the northernmost bin separately. 1882 2188 jj = 2 1883 ijje = jpj -nn_facty*(jj-2)2189 ijje = jpj - nn_facty * ( jj - 2 ) 1884 2190 IF ( nn_facty == 3 ) THEN ; ijjs = ijje - 1 1885 2191 ELSE ; ijjs = ijje - nn_facty + 1 … … 1890 2196 ! Now bin the rest, any remainder at the south is lumped in the southern bin 1891 2197 DO jj = 3, jpjglo_crsm1 1892 ijje = jpjglo -nn_facty*(jj-2)1893 ijjs = ijje -nn_facty+11894 IF ( ijjs <= nn_facty ) 1895 mjs2_crs(jpj_crs-jj+1) = ijjs1896 mje2_crs(jpj_crs-jj+1) = ijje2198 ijje = jpjglo - nn_facty * ( jj - 2 ) 2199 ijjs = ijje - nn_facty + 1 2200 IF ( ijjs <= nn_facty ) ijjs = 2 2201 mjs2_crs(jpj_crs-jj+1) = ijjs 2202 mje2_crs(jpj_crs-jj+1) = ijje 1897 2203 ENDDO 1898 2204 … … 1908 2214 1909 2215 ! Pad the boundaries, do not know if it is necessary 1910 mis2_crs(1) = 1 ; mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1 1911 mie2_crs(1) = nn_factx ; mie2_crs(jpiglo_crs) = jpiglo 1912 mje2_crs(1) = mjs2_crs(2)-1 ; mje2_crs(jpjglo_crs) = jpjglo 1913 mjs2_crs(1) = 1 ; mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1 2216 mis2_crs(2) = 1 ; mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1 2217 mie2_crs(2) = nn_factx ; mie2_crs(jpiglo_crs) = jpiglo 2218 ! 2219 mjs2_crs(1) = 1 2220 mje2_crs(1) = 1 2221 ! 2222 mje2_crs(2) = mjs2_crs(3)-1 ; mje2_crs(jpjglo_crs) = jpjglo 2223 mjs2_crs(2) = 1 ; mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1 1914 2224 1915 2225 IF( .NOT. lk_mpp ) THEN … … 1928 2238 ENDDO 1929 2239 ENDIF 1930 njstr = mjs_crs(2) ; njend = mjs_crs(nlcj_crs - 1)2240 ! 1931 2241 nistr = mis_crs(2) ; niend = mis_crs(nlci_crs - 1) 2242 njstr = mjs_crs(3) ; njend = mjs_crs(nlcj_crs - 1) 1932 2243 ! 1933 2244 END SUBROUTINE crs_dom_def
Note: See TracChangeset
for help on using the changeset viewer.
