- Timestamp:
- 2014-02-05T12:23:56+01:00 (10 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r4292 r4486 28 28 USE lib_mpp 29 29 USE wrk_nemo 30 USE dynspg_oce 30 USE dynspg_oce 31 31 32 32 IMPLICIT NONE … … 40 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 41 41 42 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts 42 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 43 43 PUBLIC interpu, interpv, interpunb, interpvnb, interpsshn 44 44 … … 230 230 DO jj=1,jpj 231 231 ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj))) 232 ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u (1:2,jj,jk)232 ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u_a(1:2,jj,jk) 233 233 END DO 234 234 END DO … … 245 245 DO jk=1,jpkm1 246 246 DO jj=1,jpj 247 spgu(2,jj)=spgu(2,jj)+fse3u (2,jj,jk)*ua(2,jj,jk)247 spgu(2,jj)=spgu(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 248 248 END DO 249 249 END DO … … 251 251 DO jj=1,jpj 252 252 IF (umask(2,jj,1).NE.0.) THEN 253 spgu(2,jj)=spgu(2,jj) /hu(2,jj)253 spgu(2,jj)=spgu(2,jj)*hur_a(2,jj) 254 254 ENDIF 255 255 END DO … … 269 269 DO jk=1,jpkm1 270 270 DO jj=1,jpj 271 spgu1(2,jj)=spgu1(2,jj)+fse3u (2,jj,jk)*ua(2,jj,jk)271 spgu1(2,jj)=spgu1(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 272 272 END DO 273 273 END DO … … 275 275 DO jj=1,jpj 276 276 IF (umask(2,jj,1).NE.0.) THEN 277 spgu1(2,jj)=spgu1(2,jj) /hu(2,jj)277 spgu1(2,jj)=spgu1(2,jj)*hur_a(2,jj) 278 278 ENDIF 279 279 END DO … … 288 288 DO jj=1,jpj 289 289 va(2,jj,jk) = (zva(2,jj,jk)/(zrhox*e1v(2,jj)))*vmask(2,jj,jk) 290 va(2,jj,jk) = va(2,jj,jk) / fse3v(2,jj,jk) 291 END DO 292 END DO 290 va(2,jj,jk) = va(2,jj,jk) / fse3v_a(2,jj,jk) 291 END DO 292 END DO 293 294 #if defined key_dynspg_ts 295 ! Set tangential velocities to time splitting estimate 296 spgv1(2,:)=0. 297 DO jk=1,jpkm1 298 DO jj=1,jpj 299 spgv1(2,jj)=spgv1(2,jj)+fse3v_a(2,jj,jk)*va(2,jj,jk) 300 END DO 301 END DO 302 303 DO jj=1,jpj 304 spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 305 END DO 306 307 DO jk=1,jpkm1 308 DO jj=1,jpj 309 va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-spgv1(2,jj))*vmask(2,jj,jk) 310 END DO 311 END DO 312 #endif 293 313 294 314 ENDIF … … 304 324 DO jj=1,jpj 305 325 ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj))) 306 307 ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u(nlci-2:nlci-1,jj,jk) 308 326 ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u_a(nlci-2:nlci-1,jj,jk) 309 327 END DO 310 328 END DO … … 322 340 do jk=1,jpkm1 323 341 do jj=1,jpj 324 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u (nlci-2,jj,jk)*ua(nlci-2,jj,jk)342 spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 325 343 enddo 326 344 enddo … … 328 346 DO jj=1,jpj 329 347 IF (umask(nlci-2,jj,1).NE.0.) THEN 330 spgu(nlci-2,jj)=spgu(nlci-2,jj) /hu(nlci-2,jj)348 spgu(nlci-2,jj)=spgu(nlci-2,jj)*hur_a(nlci-2,jj) 331 349 ENDIF 332 350 END DO … … 348 366 DO jk=1,jpkm1 349 367 DO jj=1,jpj 350 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u (nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk)368 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 351 369 END DO 352 370 END DO … … 354 372 DO jj=1,jpj 355 373 IF (umask(nlci-2,jj,1).NE.0.) THEN 356 spgu1(nlci-2,jj)=spgu1(nlci-2,jj) /hu(nlci-2,jj)374 spgu1(nlci-2,jj)=spgu1(nlci-2,jj)*hur_a(nlci-2,jj) 357 375 ENDIF 358 376 END DO … … 367 385 DO jj=1,jpj-1 368 386 va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk) 369 va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v(nlci-1,jj,jk) 370 END DO 371 END DO 387 va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v_a(nlci-1,jj,jk) 388 END DO 389 END DO 390 391 #if defined key_dynspg_ts 392 ! Set tangential velocities to time splitting estimate 393 spgv1(nlci-1,:)=0._wp 394 DO jk=1,jpkm1 395 DO jj=1,jpj 396 spgv1(nlci-1,jj)=spgv1(nlci-1,jj)+fse3v_a(nlci-1,jj,jk)*va(nlci-1,jj,jk)*vmask(nlci-1,jj,jk) 397 END DO 398 END DO 399 400 DO jj=1,jpj 401 spgv1(nlci-1,jj)=spgv1(nlci-1,jj)*hvr_a(nlci-1,jj) 402 END DO 403 404 DO jk=1,jpkm1 405 DO jj=1,jpj 406 va(nlci-1,jj,jk) = (va(nlci-1,jj,jk)+va_b(nlci-1,jj)-spgv1(nlci-1,jj))*vmask(nlci-1,jj,jk) 407 END DO 408 END DO 409 #endif 372 410 373 411 ENDIF … … 384 422 DO ji=1,jpi 385 423 va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2))) 386 va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v (ji,1:2,jk)424 va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v_a(ji,1:2,jk) 387 425 END DO 388 426 END DO … … 399 437 DO jk=1,jpkm1 400 438 DO ji=1,jpi 401 spgv(ji,2)=spgv(ji,2)+fse3v (ji,2,jk)*va(ji,2,jk)439 spgv(ji,2)=spgv(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk) 402 440 END DO 403 441 END DO … … 405 443 DO ji=1,jpi 406 444 IF (vmask(ji,2,1).NE.0.) THEN 407 spgv(ji,2)=spgv(ji,2) /hv(ji,2)445 spgv(ji,2)=spgv(ji,2)*hvr_a(ji,2) 408 446 ENDIF 409 447 END DO … … 423 461 DO jk=1,jpkm1 424 462 DO ji=1,jpi 425 spgv1(ji,2)=spgv1(ji,2)+fse3v (ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk)463 spgv1(ji,2)=spgv1(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 426 464 END DO 427 465 END DO … … 429 467 DO ji=1,jpi 430 468 IF (vmask(ji,2,1).NE.0.) THEN 431 spgv1(ji,2)=spgv1(ji,2) /hv(ji,2)469 spgv1(ji,2)=spgv1(ji,2)*hvr_a(ji,2) 432 470 ENDIF 433 471 END DO … … 442 480 DO ji=1,jpi 443 481 ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoy*e2u(ji,2)))*umask(ji,2,jk) 444 ua(ji,2,jk) = ua(ji,2,jk) / fse3u(ji,2,jk) 445 END DO 446 END DO 447 482 ua(ji,2,jk) = ua(ji,2,jk) / fse3u_a(ji,2,jk) 483 END DO 484 END DO 485 486 #if defined key_dynspg_ts 487 ! Set tangential velocities to time splitting estimate 488 spgu1(:,2)=0._wp 489 DO jk=1,jpkm1 490 DO ji=1,jpi 491 spgu1(ji,2)=spgu1(ji,2)+fse3u_a(ji,2,jk)*ua(ji,2,jk)*umask(ji,2,jk) 492 END DO 493 END DO 494 495 DO ji=1,jpi 496 spgu1(ji,2)=spgu1(ji,2)*hur_a(ji,2) 497 END DO 498 499 DO jk=1,jpkm1 500 DO ji=1,jpi 501 ua(ji,2,jk) = (ua(ji,2,jk)+ua_b(ji,2)-spgu1(ji,2))*umask(ji,2,jk) 502 END DO 503 END DO 504 #endif 448 505 ENDIF 449 506 … … 459 516 DO ji=1,jpi 460 517 va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1))) 461 va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v (ji,nlcj-2:nlcj-1,jk)518 va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v_a(ji,nlcj-2:nlcj-1,jk) 462 519 END DO 463 520 END DO … … 474 531 DO jk=1,jpkm1 475 532 DO ji=1,jpi 476 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v (ji,nlcj-2,jk)*va(ji,nlcj-2,jk)533 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 477 534 END DO 478 535 END DO … … 480 537 DO ji=1,jpi 481 538 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 482 spgv(ji,nlcj-2)=spgv(ji,nlcj-2) /hv(ji,nlcj-2)539 spgv(ji,nlcj-2)=spgv(ji,nlcj-2)*hvr_a(ji,nlcj-2) 483 540 ENDIF 484 541 END DO … … 498 555 DO jk=1,jpkm1 499 556 DO ji=1,jpi 500 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v (ji,nlcj-2,jk)*va(ji,nlcj-2,jk)557 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 501 558 END DO 502 559 END DO … … 504 561 DO ji=1,jpi 505 562 IF (vmask(ji,nlcj-2,1).NE.0.) THEN 506 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2) /hv(ji,nlcj-2)563 spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)*hvr_a(ji,nlcj-2) 507 564 ENDIF 508 565 END DO … … 517 574 DO ji=1,jpi 518 575 ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk) 519 ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u(ji,nlcj-1,jk) 520 END DO 521 END DO 576 ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u_a(ji,nlcj-1,jk) 577 END DO 578 END DO 579 580 #if defined key_dynspg_ts 581 ! Set tangential velocities to time splitting estimate 582 spgu1(:,nlcj-1)=0._wp 583 DO jk=1,jpkm1 584 DO ji=1,jpi 585 spgu1(ji,nlcj-1)=spgu1(ji,nlcj-1)+fse3u_a(ji,nlcj-1,jk)*ua(ji,nlcj-1,jk) 586 END DO 587 END DO 588 589 DO ji=1,jpi 590 spgu1(ji,nlcj-1)=spgu1(ji,nlcj-1)*hur_a(ji,nlcj-1) 591 END DO 592 593 DO jk=1,jpkm1 594 DO ji=1,jpi 595 ua(ji,nlcj-1,jk) = (ua(ji,nlcj-1,jk)+ua_b(ji,nlcj-1)-spgu1(ji,nlcj-1))*umask(ji,nlcj-1,jk) 596 END DO 597 END DO 598 #endif 522 599 523 600 ENDIF … … 528 605 END SUBROUTINE Agrif_dyn 529 606 530 SUBROUTINE Agrif_dyn_ts( kt,jn )607 SUBROUTINE Agrif_dyn_ts( jn ) 531 608 !!---------------------------------------------------------------------- 532 609 !! *** ROUTINE Agrif_dyn_ts *** 533 610 !!---------------------------------------------------------------------- 534 611 !! 535 INTEGER, INTENT(in) :: kt,jn612 INTEGER, INTENT(in) :: jn 536 613 !! 537 614 INTEGER :: ji, jj 538 REAL(wp) :: zrhox, zrhoy539 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1540 REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn541 615 !!---------------------------------------------------------------------- 542 616 543 617 IF( Agrif_Root() ) RETURN 544 618 545 IF ((kt==nit000).AND.(jn==1)) THEN546 ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj))547 ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj))548 ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi))549 ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi))550 ENDIF551 552 IF (jn==1) THEN553 ! Fill boundary arrays at each baroclinic step554 ! with Parent grid barotropic fluxes and sea level555 !556 CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn )557 558 zrhox = Agrif_Rhox()559 zrhoy = Agrif_Rhoy()560 561 !alt Agrif_SpecialValue = 0.e0562 !alt Agrif_UseSpecialValue = .TRUE.563 !alt CALL Agrif_Bc_variable(zsshn, sshn_id, procname=interpsshn )564 !alt Agrif_UseSpecialValue = .FALSE.565 566 Agrif_SpecialValue=0.567 Agrif_UseSpecialValue = ln_spc_dyn568 zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp569 CALL Agrif_Bc_variable(zunb,unb_id,procname=interpunb)570 CALL Agrif_Bc_variable(zvnb,vnb_id,procname=interpvnb)571 Agrif_UseSpecialValue = .FALSE.572 573 IF((nbondi == -1).OR.(nbondi == 2)) THEN574 DO jj=1,jpj575 ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj)))576 vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj)))577 hbdy_w(jj) = zsshn(2,jj)578 END DO579 ENDIF580 581 IF((nbondi == 1).OR.(nbondi == 2)) THEN582 DO jj=1,jpj583 ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))584 vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj))585 hbdy_e(jj) = zsshn(nlci-1,jj)586 END DO587 ENDIF588 589 IF((nbondj == -1).OR.(nbondj == 2)) THEN590 DO ji=1,jpi591 ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2))592 vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2))593 hbdy_s(ji) = zsshn(ji,2)594 END DO595 ENDIF596 597 IF((nbondj == 1).OR.(nbondj == 2)) THEN598 DO ji=1,jpi599 ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1))600 vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2))601 hbdy_n(ji) = zsshn(ji,nlcj-1)602 END DO603 ENDIF604 605 CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn )606 ENDIF ! jn==1607 608 ! Then update velocities at each barotropic time step609 619 IF((nbondi == -1).OR.(nbondi == 2)) THEN 610 620 DO jj=1,jpj … … 653 663 END SUBROUTINE Agrif_dyn_ts 654 664 665 SUBROUTINE Agrif_dta_ts( kt ) 666 !!---------------------------------------------------------------------- 667 !! *** ROUTINE Agrif_dta_ts *** 668 !!---------------------------------------------------------------------- 669 !! 670 INTEGER, INTENT(in) :: kt 671 !! 672 INTEGER :: ji, jj 673 LOGICAL :: ll_int_cons 674 REAL(wp) :: zrhox, zrhoy, zrhot, zt 675 REAL(wp) :: zaa, zab, zat 676 REAL(wp) :: zt0, zt1 677 REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn 678 REAL(wp), POINTER, DIMENSION(:,:) :: zuab, zvab, zubb, zvbb, zutn, zvtn 679 !!---------------------------------------------------------------------- 680 681 IF( Agrif_Root() ) RETURN 682 683 ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 684 ! the forward case only 685 686 zrhox = Agrif_Rhox() 687 zrhoy = Agrif_Rhoy() 688 zrhot = Agrif_rhot() 689 690 IF ( kt==nit000 ) THEN ! Allocate boundary data arrays 691 ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj)) 692 ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj)) 693 ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi)) 694 ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi)) 695 ENDIF 696 697 CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn ) 698 699 ! "Central" time index for interpolation: 700 IF (ln_bt_fw) THEN 701 zt = REAL(Agrif_NbStepint()+0.5_wp,wp) / zrhot 702 ELSE 703 zt = REAL(Agrif_NbStepint(),wp) / zrhot 704 ENDIF 705 706 ! Linear interpolation of sea level 707 Agrif_SpecialValue = 0.e0 708 Agrif_UseSpecialValue = .TRUE. 709 CALL Agrif_Bc_variable(zsshn, sshn_id,calledweight=zt, procname=interpsshn ) 710 Agrif_UseSpecialValue = .FALSE. 711 712 ! Interpolate barotropic fluxes 713 Agrif_SpecialValue=0. 714 Agrif_UseSpecialValue = ln_spc_dyn 715 716 IF (ll_int_cons) THEN ! Conservative interpolation 717 CALL wrk_alloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 718 zuab(:,:) = 0._wp ; zvab(:,:) = 0._wp 719 zubb(:,:) = 0._wp ; zvbb(:,:) = 0._wp 720 zutn(:,:) = 0._wp ; zvtn(:,:) = 0._wp 721 CALL Agrif_Bc_variable(zubb,unb_id ,calledweight=0._wp, procname=interpunb) ! Before 722 CALL Agrif_Bc_variable(zvbb,vnb_id ,calledweight=0._wp, procname=interpvnb) 723 CALL Agrif_Bc_variable(zuab,unb_id ,calledweight=1._wp, procname=interpunb) ! After 724 CALL Agrif_Bc_variable(zvab,vnb_id ,calledweight=1._wp, procname=interpvnb) 725 CALL Agrif_Bc_variable(zutn,ub2b_id,calledweight=1._wp, procname=interpub2b)! Time integrated 726 CALL Agrif_Bc_variable(zvtn,vb2b_id,calledweight=1._wp, procname=interpvb2b) 727 728 ! Time indexes bounds for integration 729 zt0 = REAL(Agrif_NbStepint() , wp) / zrhot 730 zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 731 732 ! Polynomial interpolation coefficients: 733 zaa = zrhot * ( zt1**2._wp * ( zt1 - 1._wp) & 734 & - zt0**2._wp * ( zt0 - 1._wp) ) 735 zab = zrhot * ( zt1 * ( zt1 - 1._wp)**2._wp & 736 & - zt0 * ( zt0 - 1._wp)**2._wp ) 737 zat = zrhot * ( zt1**2._wp * (-2._wp*zt1 + 3._wp) & 738 & - zt0**2._wp * (-2._wp*zt0 + 3._wp) ) 739 740 ! Do time interpolation 741 IF((nbondi == -1).OR.(nbondi == 2)) THEN 742 DO jj=1,jpj 743 zunb(2,jj) = zaa * zuab(2,jj) + zab * zubb(2,jj) + zat * zutn(2,jj) 744 zvnb(2,jj) = zaa * zvab(2,jj) + zab * zvbb(2,jj) + zat * zvtn(2,jj) 745 END DO 746 ENDIF 747 IF((nbondi == 1).OR.(nbondi == 2)) THEN 748 DO jj=1,jpj 749 zunb(nlci-2,jj) = zaa * zuab(nlci-2,jj) + zab * zubb(nlci-2,jj) + zat * zutn(nlci-2,jj) 750 zvnb(nlci-1,jj) = zaa * zvab(nlci-1,jj) + zab * zvbb(nlci-1,jj) + zat * zvtn(nlci-1,jj) 751 END DO 752 ENDIF 753 IF((nbondj == -1).OR.(nbondj == 2)) THEN 754 DO ji=1,jpi 755 zunb(ji,2) = zaa * zuab(ji,2) + zab * zubb(ji,2) + zat * zutn(ji,2) 756 zvnb(ji,2) = zaa * zvab(ji,2) + zab * zvbb(ji,2) + zat * zvtn(ji,2) 757 END DO 758 ENDIF 759 IF((nbondj == 1).OR.(nbondj == 2)) THEN 760 DO ji=1,jpi 761 zunb(ji,nlcj-1) = zaa * zuab(ji,nlcj-1) + zab * zubb(ji,nlcj-1) + zat * zutn(ji,nlcj-1) 762 zvnb(ji,nlcj-2) = zaa * zvab(ji,nlcj-2) + zab * zvbb(ji,nlcj-2) + zat * zvtn(ji,nlcj-2) 763 END DO 764 ENDIF 765 CALL wrk_dealloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 766 767 ELSE ! Linear interpolation 768 zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp 769 CALL Agrif_Bc_variable(zunb,unb_id,calledweight=zt, procname=interpunb) 770 CALL Agrif_Bc_variable(zvnb,vnb_id,calledweight=zt, procname=interpvnb) 771 ENDIF 772 Agrif_UseSpecialValue = .FALSE. 773 774 ! Fill boundary data arrays: 775 IF((nbondi == -1).OR.(nbondi == 2)) THEN 776 DO jj=1,jpj 777 ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj))) * umask(2,jj,1) 778 vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj))) * vmask(2,jj,1) 779 hbdy_w(jj) = zsshn(2,jj) * tmask(2,jj,1) 780 END DO 781 ENDIF 782 783 IF((nbondi == 1).OR.(nbondi == 2)) THEN 784 DO jj=1,jpj 785 ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj)) * umask(nlci-2,jj,1) 786 vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj)) * vmask(nlci-1,jj,1) 787 hbdy_e(jj) = zsshn(nlci-1,jj) * tmask(nlci-1,jj,1) 788 END DO 789 ENDIF 790 791 IF((nbondj == -1).OR.(nbondj == 2)) THEN 792 DO ji=1,jpi 793 ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2)) * umask(ji,2,1) 794 vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2)) * vmask(ji,2,1) 795 hbdy_s(ji) = zsshn(ji,2) * tmask(ji,2,1) 796 END DO 797 ENDIF 798 799 IF((nbondj == 1).OR.(nbondj == 2)) THEN 800 DO ji=1,jpi 801 ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1)) * umask(ji,nlcj-1,1) 802 vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)) * vmask(ji,nlcj-2,1) 803 hbdy_n(ji) = zsshn(ji,nlcj-1) * tmask(ji,nlcj-1,1) 804 END DO 805 ENDIF 806 807 CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn ) 808 809 END SUBROUTINE Agrif_dta_ts 810 655 811 SUBROUTINE Agrif_ssh( kt ) 656 812 !!---------------------------------------------------------------------- … … 686 842 END SUBROUTINE Agrif_ssh 687 843 688 SUBROUTINE Agrif_ssh_ts( kt)844 SUBROUTINE Agrif_ssh_ts( jn ) 689 845 !!---------------------------------------------------------------------- 690 846 !! *** ROUTINE Agrif_ssh_ts *** 691 847 !!---------------------------------------------------------------------- 692 INTEGER, INTENT(in) :: kt 693 !! 848 INTEGER, INTENT(in) :: jn 849 !! 850 INTEGER :: ji,jj 694 851 !!---------------------------------------------------------------------- 695 852 696 853 IF((nbondi == -1).OR.(nbondi == 2)) THEN 697 ssha_e(2,:) = ssha_e(3,:) 854 DO jj=1,jpj 855 ssha_e(2,jj) = hbdy_w(jj) 856 END DO 698 857 ENDIF 699 858 700 859 IF((nbondi == 1).OR.(nbondi == 2)) THEN 701 ssha_e(nlci-1,:) = ssha_e(nlci-2,:) 860 DO jj=1,jpj 861 ssha_e(nlci-1,jj) = hbdy_e(jj) 862 END DO 702 863 ENDIF 703 864 704 865 IF((nbondj == -1).OR.(nbondj == 2)) THEN 705 ssha_e(:,2) = ssha_e(:,3) 866 DO ji=1,jpi 867 ssha_e(ji,2) = hbdy_s(ji) 868 END DO 706 869 ENDIF 707 870 708 871 IF((nbondj == 1).OR.(nbondj == 2)) THEN 709 ssha_e(:,nlcj-1) = ssha_e(:,nlcj-2) 872 DO ji=1,jpi 873 ssha_e(ji,nlcj-1) = hbdy_n(ji) 874 END DO 710 875 ENDIF 711 876 … … 740 905 DO ji=i1,i2 741 906 tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 742 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u (ji,jj,jk)907 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk) 743 908 END DO 744 909 END DO … … 781 946 DO ji=i1,i2 782 947 tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 783 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v (ji,jj,jk)948 tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk) 784 949 END DO 785 950 END DO … … 815 980 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 816 981 !! 817 INTEGER :: ji,jj,jk 818 !!---------------------------------------------------------------------- 819 820 tabres(:,:) = 0.e0 821 DO jk=1,jpkm1 822 DO jj=j1,j2 823 DO ji=i1,i2 824 tabres(ji,jj) = tabres(ji,jj) + e2u(ji,jj) * un(ji,jj,jk) & 825 * umask(ji,jj,jk) * fse3u(ji,jj,jk) 826 END DO 982 INTEGER :: ji,jj 983 !!---------------------------------------------------------------------- 984 985 DO jj=j1,j2 986 DO ji=i1,i2 987 tabres(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj) 827 988 END DO 828 989 END DO … … 837 998 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 838 999 !! 839 INTEGER :: ji,jj,jk 840 !!---------------------------------------------------------------------- 841 842 tabres(:,:) = 0.e0 843 DO jk=1,jpkm1 844 DO jj=j1,j2 845 DO ji=i1,i2 846 tabres(ji,jj) = tabres(ji,jj) + e1v(ji,jj) * vn(ji,jj,jk) & 847 * vmask(ji,jj,jk) * fse3v(ji,jj,jk) 848 END DO 1000 INTEGER :: ji,jj 1001 !!---------------------------------------------------------------------- 1002 1003 DO jj=j1,j2 1004 DO ji=i1,i2 1005 tabres(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 849 1006 END DO 850 1007 END DO 851 1008 852 1009 END SUBROUTINE interpvnb 1010 1011 SUBROUTINE interpub2b(tabres,i1,i2,j1,j2) 1012 !!---------------------------------------------------------------------- 1013 !! *** ROUTINE interpub2b *** 1014 !!---------------------------------------------------------------------- 1015 INTEGER, INTENT(in) :: i1,i2,j1,j2 1016 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1017 !! 1018 INTEGER :: ji,jj 1019 !!---------------------------------------------------------------------- 1020 1021 DO jj=j1,j2 1022 DO ji=i1,i2 1023 tabres(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 1024 END DO 1025 END DO 1026 1027 END SUBROUTINE interpub2b 1028 1029 SUBROUTINE interpvb2b(tabres,i1,i2,j1,j2) 1030 !!---------------------------------------------------------------------- 1031 !! *** ROUTINE interpvb2b *** 1032 !!---------------------------------------------------------------------- 1033 INTEGER, INTENT(in) :: i1,i2,j1,j2 1034 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 1035 !! 1036 INTEGER :: ji,jj 1037 !!---------------------------------------------------------------------- 1038 1039 DO jj=j1,j2 1040 DO ji=i1,i2 1041 tabres(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 1042 END DO 1043 END DO 1044 1045 END SUBROUTINE interpvb2b 853 1046 854 1047 #else
Note: See TracChangeset
for help on using the changeset viewer.
