Changeset 4486 for branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC
- Timestamp:
- 2014-02-05T12:23:56+01:00 (10 years ago)
- Location:
- branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC
- Files:
-
- 4 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90
r4292 r4486 40 40 INTEGER :: e1u_id, e2v_id, sshn_id, gcb_id 41 41 INTEGER :: trn_id, trb_id, tra_id 42 INTEGER :: unb_id, vnb_id 42 INTEGER :: unb_id, vnb_id, ub2b_id, vb2b_id 43 43 44 44 !!---------------------------------------------------------------------- -
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 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r3294 r4486 10 10 USE lib_mpp 11 11 USE wrk_nemo 12 USE dynspg_oce 12 13 13 14 IMPLICIT NONE … … 34 35 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 35 36 36 37 37 38 IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 38 39 #if defined TWO_WAY … … 79 80 80 81 CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d) 81 CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 82 CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 83 84 #if defined key_dynspg_ts 85 IF (ln_bt_fw) THEN 86 ! Update time integrated transports 87 IF (mod(nbcline,nbclineupdate) == 0) THEN 88 CALL Agrif_Update_Variable(ztab2d,ub2b_id,procname = updateub2b) 89 CALL Agrif_Update_Variable(ztab2d,vb2b_id,procname = updatevb2b) 90 ELSE 91 CALL Agrif_Update_Variable(ztab2d,ub2b_id,locupdate=(/0,1/),procname = updateub2b) 92 CALL Agrif_Update_Variable(ztab2d,vb2b_id,locupdate=(/0,1/),procname = updatevb2b) 93 ENDIF 94 END IF 95 #endif 82 96 83 97 nbcline = nbcline + 1 84 98 85 Agrif_UseSpecialValueInUpdate = ln_spc_dyn99 Agrif_UseSpecialValueInUpdate = .TRUE. 86 100 Agrif_SpecialValueFineGrid = 0. 87 101 CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH) … … 238 252 IF (before) THEN 239 253 zrhoy = Agrif_Rhoy() 240 DO jk = 1,jpkm1 241 DO jj=j1,j2 242 DO ji=i1,i2 243 tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk) 244 END DO 245 END DO 246 END DO 247 DO jj=j1,j2 248 DO ji=i1,i2 249 tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj) 254 DO jj=j1,j2 255 DO ji=i1,i2 256 tabres(ji,jj) = un_b(ji,jj) * hu(ji,jj) * e2u(ji,jj) 250 257 END DO 251 258 END DO … … 266 273 END DO 267 274 ENDIF 275 ! Update barotropic velocities: 276 un_b(ji,jj) = tabres(ji,jj) * hur(ji,jj) / e2u(ji,jj) 268 277 END DO 269 278 END DO … … 287 296 IF (before) THEN 288 297 zrhox = Agrif_Rhox() 289 tabres = 0.e0 290 DO jk = 1,jpkm1 291 DO jj=j1,j2 292 DO ji=i1,i2 293 tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk) 294 END DO 295 END DO 296 END DO 297 DO jj=j1,j2 298 DO ji=i1,i2 299 tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj) 298 DO jj=j1,j2 299 DO ji=i1,i2 300 tabres(ji,jj) = vn_b(ji,jj) * hv(ji,jj) * e1v(ji,jj) 300 301 END DO 301 302 END DO … … 316 317 END DO 317 318 ENDIF 319 ! Update barotropic velocities: 320 vn_b(ji,jj) = tabres(ji,jj) * hvr(ji,jj) / e1v(ji,jj) 318 321 END DO 319 322 END DO … … 333 336 334 337 INTEGER :: ji, jj 335 REAL(wp) :: zrhox, zrhoy 338 339 IF (before) THEN 340 DO jj=j1,j2 341 DO ji=i1,i2 342 tabres(ji,jj) = sshn(ji,jj) 343 END DO 344 END DO 345 ELSE 346 DO jj=j1,j2 347 DO ji=i1,i2 348 sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1) 349 END DO 350 END DO 351 ENDIF 352 353 END SUBROUTINE updateSSH 354 355 SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) 356 !!--------------------------------------------- 357 !! *** ROUTINE updateub2b *** 358 !!--------------------------------------------- 359 360 INTEGER, INTENT(in) :: i1, i2, j1, j2 361 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 362 LOGICAL, INTENT(in) :: before 363 364 INTEGER :: ji, jj 365 REAL(wp) :: zrhoy 366 367 IF (before) THEN 368 zrhoy = Agrif_Rhoy() 369 DO jj=j1,j2 370 DO ji=i1,i2 371 tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj) 372 END DO 373 END DO 374 tabres = zrhoy * tabres 375 ELSE 376 DO jj=j1,j2 377 DO ji=i1,i2 378 ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj) 379 END DO 380 END DO 381 ENDIF 382 383 END SUBROUTINE updateub2b 384 385 SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 386 !!--------------------------------------------- 387 !! *** ROUTINE updatevb2b *** 388 !!--------------------------------------------- 389 390 INTEGER, INTENT(in) :: i1, i2, j1, j2 391 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 392 LOGICAL, INTENT(in) :: before 393 394 INTEGER :: ji, jj 395 REAL(wp) :: zrhox 336 396 337 397 IF (before) THEN 338 398 zrhox = Agrif_Rhox() 339 zrhoy = Agrif_Rhoy() 340 DO jj=j1,j2 341 DO ji=i1,i2 342 tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj) 343 END DO 344 END DO 345 tabres = zrhox * zrhoy * tabres 346 ELSE 347 DO jj=j1,j2 348 DO ji=i1,i2 349 sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj)) 350 sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1) 351 END DO 352 END DO 353 ENDIF 354 355 END SUBROUTINE updateSSH 399 DO jj=j1,j2 400 DO ji=i1,i2 401 tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 402 END DO 403 END DO 404 tabres = zrhox * tabres 405 ELSE 406 DO jj=j1,j2 407 DO ji=i1,i2 408 vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj) 409 END DO 410 END DO 411 ENDIF 412 413 END SUBROUTINE updatevb2b 356 414 357 415 #else … … 365 423 #endif 366 424 END MODULE agrif_opa_update 425 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_user.F90
r4331 r4486 294 294 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 295 295 CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 296 CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_id) 297 CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_id) 296 298 297 299 ! 2. Type of interpolation … … 309 311 Call Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 310 312 Call Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 313 Call Agrif_Set_bcinterp(ub2b_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 314 Call Agrif_Set_bcinterp(vb2b_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 311 315 312 316 ! 3. Location of interpolation … … 318 322 Call Agrif_Set_bc(unb_id,(/0,1/)) 319 323 Call Agrif_Set_bc(vnb_id,(/0,1/)) 324 Call Agrif_Set_bc(ub2b_id,(/0,1/)) 325 Call Agrif_Set_bc(vb2b_id,(/0,1/)) 320 326 321 327 Call Agrif_Set_bc(tsn_id,(/0,1/)) … … 335 341 Call Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 336 342 Call Agrif_Set_Updatetype(vn_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 343 344 Call Agrif_Set_Updatetype(ub2b_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 345 Call Agrif_Set_Updatetype(vb2b_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 337 346 338 347 END SUBROUTINE agrif_declare_var
Note: See TracChangeset
for help on using the changeset viewer.