Changeset 4292
- Timestamp:
- 2013-11-20T17:28:04+01:00 (10 years ago)
- Location:
- branches/2013/dev_MERGE_2013/NEMOGCM
- Files:
-
- 1 deleted
- 88 edited
- 2 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_MERGE_2013/NEMOGCM/CONFIG/SHARED/1_namelist_ref
r4230 r4292 507 507 !----------------------------------------------------------------------- 508 508 ln_tide_pot = .true. ! use tidal potential forcing 509 nb_harmo = 11 ! number of constituents used 509 510 clname(1) = 'M2' ! name of constituent 510 511 clname(2) = 'S2' … … 700 701 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 701 702 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 703 / 704 !----------------------------------------------------------------------- 705 &nam_vvl ! vertical coordinate options 706 !----------------------------------------------------------------------- 707 ln_vvl_zstar = .true. ! zstar vertical coordinate 708 ln_vvl_ztilde = .false. ! ztilde vertical coordinate: only high frequency variations 709 ln_vvl_layer = .false. ! full layer vertical coordinate 710 ln_vvl_ztilde_as_zstar = .false. ! ztilde vertical coordinate emulating zstar 711 rn_ahe3 = 0.0e0 ! thickness diffusion coefficient 712 rn_rst_e3t = 30.e0 ! ztilde to zstar restoration timescale [days] 713 rn_lf_cutoff = 5.0e0 ! cutoff frequency for low-pass filter [days] 714 rn_zdef_max = 0.9e0 ! maximum fractional e3t deformation 715 ln_vvl_dbg = .true. ! debug prints (T/F) 702 716 / 703 717 !----------------------------------------------------------------------- -
branches/2013/dev_MERGE_2013/NEMOGCM/CONFIG/SHARED/namelist_ref
r4245 r4292 513 513 !----------------------------------------------------------------------- 514 514 ln_tide_pot = .true. ! use tidal potential forcing 515 nb_harmo = 11 ! number of constituents used 515 516 clname(1) = 'M2' ! name of constituent 516 517 clname(2) = 'S2' … … 712 713 ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme 713 714 ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme 715 / 716 !----------------------------------------------------------------------- 717 &nam_vvl ! vertical coordinate options 718 !----------------------------------------------------------------------- 719 ln_vvl_zstar = .true. ! zstar vertical coordinate 720 ln_vvl_ztilde = .false. ! ztilde vertical coordinate: only high frequency variations 721 ln_vvl_layer = .false. ! full layer vertical coordinate 722 ln_vvl_ztilde_as_zstar = .false. ! ztilde vertical coordinate emulating zstar 723 rn_ahe3 = 0.0e0 ! thickness diffusion coefficient 724 rn_rst_e3t = 30.e0 ! ztilde to zstar restoration timescale [days] 725 rn_lf_cutoff = 5.0e0 ! cutoff frequency for low-pass filter [days] 726 rn_zdef_max = 0.9e0 ! maximum fractional e3t deformation 727 ln_vvl_dbg = .true. ! debug prints (T/F) 714 728 / 715 729 !----------------------------------------------------------------------- -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/LIM_SRC_2/limsbc_2.F90
r4148 r4292 24 24 USE phycst ! physical constants 25 25 USE dom_oce ! ocean domain 26 USE domvvl ! ocean vertical scale factors 26 27 USE dom_ice_2 ! LIM-2: ice domain 27 28 USE ice_2 ! LIM-2: ice variables … … 59 60 !! * Substitutions 60 61 # include "vectopt_loop_substitute.h90" 62 # include "domzgr_substitute.h90" 61 63 !!---------------------------------------------------------------------- 62 64 !! NEMO/LIM2 4.0 , UCL - NEMO Consortium (2011) … … 446 448 !!------------------------------------------------------------------- 447 449 ! 450 INTEGER :: jk ! local integer 451 ! 448 452 IF(lwp) WRITE(numout,*) 449 453 IF(lwp) WRITE(numout,*) 'lim_sbc_init_2 : LIM-2 sea-ice - surface boundary condition' … … 472 476 snwice_mass (:,:) = 0.e0 ! no mass exchanges 473 477 snwice_mass_b(:,:) = 0.e0 ! no mass exchanges 478 snwice_fmass (:,:) = 0.e0 ! no mass exchanges 474 479 ENDIF 475 480 IF( nn_ice_embd == 2 .AND. & ! full embedment (case 2) & no restart : … … 477 482 sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0 478 483 sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0 484 do jk = 1,jpkm1 ! adjust initial vertical scale factors 485 fse3t_n(:,:,jk) = e3t_0(:,:,jk)*( 1._wp + sshn(:,:)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) 486 fse3t_b(:,:,jk) = e3t_0(:,:,jk)*( 1._wp + sshb(:,:)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) 487 end do 488 fse3t_a(:,:,:) = fse3t_b(:,:,:) 489 ! Reconstruction of all vertical scale factors at now and before time steps 490 ! ============================================================================= 491 ! Horizontal scale factor interpolations 492 ! -------------------------------------- 493 CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3u_b(:,:,:), 'U' ) 494 CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3v_b(:,:,:), 'V' ) 495 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3u_n(:,:,:), 'U' ) 496 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3v_n(:,:,:), 'V' ) 497 CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3f_n(:,:,:), 'F' ) 498 ! Vertical scale factor interpolations 499 ! ------------------------------------ 500 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n (:,:,:), 'W' ) 501 CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3uw_n(:,:,:), 'UW' ) 502 CALL dom_vvl_interpol( fse3v_n(:,:,:), fse3vw_n(:,:,:), 'VW' ) 503 CALL dom_vvl_interpol( fse3u_b(:,:,:), fse3uw_b(:,:,:), 'UW' ) 504 CALL dom_vvl_interpol( fse3v_b(:,:,:), fse3vw_b(:,:,:), 'VW' ) 505 ! t- and w- points depth 506 ! ---------------------- 507 fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 508 fsdepw_n(:,:,1) = 0.0_wp 509 fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 510 DO jk = 2, jpk 511 fsdept_n(:,:,jk) = fsdept_n(:,:,jk-1) + fse3w_n(:,:,jk) 512 fsdepw_n(:,:,jk) = fsdepw_n(:,:,jk-1) + fse3t_n(:,:,jk-1) 513 fsde3w_n(:,:,jk) = fsdept_n(:,:,jk ) - sshn (:,:) 514 END DO 479 515 ENDIF 480 516 ! -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/LIM_SRC_2/limthd_2.F90
r4147 r4292 237 237 238 238 ! energy needed to bring ocean surface layer until its freezing 239 qcmif (ji,jj) = rau0 * rcp * fse3t_m(ji,jj ,1) * ( tfu(ji,jj) - sst_m(ji,jj) - rt0 ) * ( 1 - zinda )239 qcmif (ji,jj) = rau0 * rcp * fse3t_m(ji,jj) * ( tfu(ji,jj) - sst_m(ji,jj) - rt0 ) * ( 1 - zinda ) 240 240 241 241 ! calculate oceanic heat flux. -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90
r4147 r4292 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 43 43 44 !!---------------------------------------------------------------------- -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r3294 r4292 27 27 USE agrif_opa_sponge 28 28 USE lib_mpp 29 USE wrk_nemo 29 USE wrk_nemo 30 USE dynspg_oce 30 31 31 32 IMPLICIT NONE 32 33 PRIVATE 34 35 ! Barotropic arrays used to store open boundary data during 36 ! time-splitting loop: 37 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_w, vbdy_w, hbdy_w 38 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_e, vbdy_e, hbdy_e 39 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_n, vbdy_n, hbdy_n 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: ubdy_s, vbdy_s, hbdy_s 33 41 34 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, interpu, interpv 42 PUBLIC Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts 43 PUBLIC interpu, interpv, interpunb, interpvnb, interpsshn 35 44 36 45 # include "domzgr_substitute.h90" … … 169 178 REAL(wp) :: timeref 170 179 REAL(wp) :: z2dt, znugdt 171 REAL(wp) :: zrhox, rhoy180 REAL(wp) :: zrhox, zrhoy 172 181 REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva 173 182 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d … … 180 189 181 190 zrhox = Agrif_Rhox() 182 rhoy = Agrif_Rhoy()191 zrhoy = Agrif_Rhoy() 183 192 184 193 timeref = 1. … … 201 210 zva2d = 0. 202 211 212 #if defined key_dynspg_flt 203 213 Agrif_SpecialValue=0. 204 214 Agrif_UseSpecialValue = ln_spc_dyn 205 215 CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d) 206 216 CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d) 217 #endif 207 218 Agrif_UseSpecialValue = .FALSE. 208 219 … … 210 221 IF((nbondi == -1).OR.(nbondi == 2)) THEN 211 222 223 #if defined key_dynspg_flt 212 224 DO jj=1,jpj 213 laplacu(2,jj) = timeref * (zua2d(2,jj)/(rhoy*e2u(2,jj)))*umask(2,jj,1) 214 END DO 215 216 DO jk=1,jpkm1 217 DO jj=1,jpj 218 ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(rhoy*e2u(1:2,jj))) 225 laplacu(2,jj) = timeref * (zua2d(2,jj)/(zrhoy*e2u(2,jj)))*umask(2,jj,1) 226 END DO 227 #endif 228 229 DO jk=1,jpkm1 230 DO jj=1,jpj 231 ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj))) 219 232 ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u(1:2,jj,jk) 220 233 END DO 221 234 END DO 222 235 236 #if defined key_dynspg_flt 223 237 DO jk=1,jpkm1 224 238 DO jj=1,jpj … … 240 254 ENDIF 241 255 END DO 256 #else 257 spgu(2,:) = ua_b(2,:) 258 #endif 242 259 243 260 DO jk=1,jpkm1 … … 278 295 279 296 IF((nbondi == 1).OR.(nbondi == 2)) THEN 280 297 #if defined key_dynspg_flt 281 298 DO jj=1,jpj 282 laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(rhoy*e2u(nlci-2,jj))) 283 END DO 284 285 DO jk=1,jpkm1 286 DO jj=1,jpj 287 ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(rhoy*e2u(nlci-2:nlci-1,jj))) 299 laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))) 300 END DO 301 #endif 302 303 DO jk=1,jpkm1 304 DO jj=1,jpj 305 ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj))) 288 306 289 307 ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u(nlci-2:nlci-1,jj,jk) … … 292 310 END DO 293 311 312 #if defined key_dynspg_flt 294 313 DO jk=1,jpkm1 295 314 DO jj=1,jpj … … 312 331 ENDIF 313 332 END DO 333 #else 334 spgu(nlci-2,:) = ua_b(nlci-2,:) 335 #endif 314 336 315 337 DO jk=1,jpkm1 … … 353 375 IF((nbondj == -1).OR.(nbondj == 2)) THEN 354 376 377 #if defined key_dynspg_flt 355 378 DO ji=1,jpi 356 379 laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2))) 357 380 END DO 381 #endif 358 382 359 383 DO jk=1,jpkm1 … … 364 388 END DO 365 389 390 #if defined key_dynspg_flt 366 391 DO jk=1,jpkm1 367 392 DO ji=1,jpi … … 383 408 ENDIF 384 409 END DO 410 #else 411 spgv(:,2)=va_b(:,2) 412 #endif 385 413 386 414 DO jk=1,jpkm1 … … 413 441 DO jk=1,jpkm1 414 442 DO ji=1,jpi 415 ua(ji,2,jk) = (zua(ji,2,jk)/( rhoy*e2u(ji,2)))*umask(ji,2,jk)443 ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoy*e2u(ji,2)))*umask(ji,2,jk) 416 444 ua(ji,2,jk) = ua(ji,2,jk) / fse3u(ji,2,jk) 417 445 END DO … … 422 450 IF((nbondj == 1).OR.(nbondj == 2)) THEN 423 451 452 #if defined key_dynspg_flt 424 453 DO ji=1,jpi 425 454 laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2))) 426 455 END DO 456 #endif 427 457 428 458 DO jk=1,jpkm1 … … 433 463 END DO 434 464 465 #if defined key_dynspg_flt 435 466 DO jk=1,jpkm1 436 467 DO ji=1,jpi … … 438 469 END DO 439 470 END DO 440 441 471 442 472 spgv(:,nlcj-2)=0. … … 453 483 ENDIF 454 484 END DO 485 #else 486 spgv(:,nlcj-2)=va_b(:,nlcj-2) 487 #endif 455 488 456 489 DO jk=1,jpkm1 … … 483 516 DO jk=1,jpkm1 484 517 DO ji=1,jpi 485 ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/( rhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk)518 ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk) 486 519 ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u(ji,nlcj-1,jk) 487 520 END DO … … 495 528 END SUBROUTINE Agrif_dyn 496 529 530 SUBROUTINE Agrif_dyn_ts( kt, jn ) 531 !!---------------------------------------------------------------------- 532 !! *** ROUTINE Agrif_dyn_ts *** 533 !!---------------------------------------------------------------------- 534 !! 535 INTEGER, INTENT(in) :: kt, jn 536 !! 537 INTEGER :: ji, jj 538 REAL(wp) :: zrhox, zrhoy 539 REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 540 REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn 541 !!---------------------------------------------------------------------- 542 543 IF( Agrif_Root() ) RETURN 544 545 IF ((kt==nit000).AND.(jn==1)) THEN 546 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 ENDIF 551 552 IF (jn==1) THEN 553 ! Fill boundary arrays at each baroclinic step 554 ! with Parent grid barotropic fluxes and sea level 555 ! 556 CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn ) 557 558 zrhox = Agrif_Rhox() 559 zrhoy = Agrif_Rhoy() 560 561 !alt Agrif_SpecialValue = 0.e0 562 !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_dyn 568 zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp 569 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)) THEN 574 DO jj=1,jpj 575 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 DO 579 ENDIF 580 581 IF((nbondi == 1).OR.(nbondi == 2)) THEN 582 DO jj=1,jpj 583 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 DO 587 ENDIF 588 589 IF((nbondj == -1).OR.(nbondj == 2)) THEN 590 DO ji=1,jpi 591 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 DO 595 ENDIF 596 597 IF((nbondj == 1).OR.(nbondj == 2)) THEN 598 DO ji=1,jpi 599 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 DO 603 ENDIF 604 605 CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn ) 606 ENDIF ! jn==1 607 608 ! Then update velocities at each barotropic time step 609 IF((nbondi == -1).OR.(nbondi == 2)) THEN 610 DO jj=1,jpj 611 va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 612 ! Specified fluxes: 613 ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 614 ! Characteristics method: 615 !alt ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 616 !alt & - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 617 END DO 618 ENDIF 619 620 IF((nbondi == 1).OR.(nbondi == 2)) THEN 621 DO jj=1,jpj 622 va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 623 ! Specified fluxes: 624 ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 625 ! Characteristics method: 626 !alt ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 627 !alt & + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 628 END DO 629 ENDIF 630 631 IF((nbondj == -1).OR.(nbondj == 2)) THEN 632 DO ji=1,jpi 633 ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 634 ! Specified fluxes: 635 va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 636 ! Characteristics method: 637 !alt va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 638 !alt & - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 639 END DO 640 ENDIF 641 642 IF((nbondj == 1).OR.(nbondj == 2)) THEN 643 DO ji=1,jpi 644 ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 645 ! Specified fluxes: 646 va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 647 ! Characteristics method: 648 !alt va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2) + va_e(ji,nlcj-3) & 649 !alt & + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 650 END DO 651 ENDIF 652 ! 653 END SUBROUTINE Agrif_dyn_ts 497 654 498 655 SUBROUTINE Agrif_ssh( kt ) … … 518 675 519 676 IF((nbondj == -1).OR.(nbondj == 2)) THEN 520 ssha(:,2)=ssh n(:,3)521 sshn(:,2)=ssh b(:,3)677 ssha(:,2)=ssha(:,3) 678 sshn(:,2)=sshn(:,3) 522 679 ENDIF 523 680 524 681 IF((nbondj == 1).OR.(nbondj == 2)) THEN 525 682 ssha(:,nlcj-1)=ssha(:,nlcj-2) 526 ssh a(:,nlcj-1)=sshn(:,nlcj-2)683 sshn(:,nlcj-1)=sshn(:,nlcj-2) 527 684 ENDIF 528 685 529 686 END SUBROUTINE Agrif_ssh 530 687 688 SUBROUTINE Agrif_ssh_ts( kt ) 689 !!---------------------------------------------------------------------- 690 !! *** ROUTINE Agrif_ssh_ts *** 691 !!---------------------------------------------------------------------- 692 INTEGER, INTENT(in) :: kt 693 !! 694 !!---------------------------------------------------------------------- 695 696 IF((nbondi == -1).OR.(nbondi == 2)) THEN 697 ssha_e(2,:) = ssha_e(3,:) 698 ENDIF 699 700 IF((nbondi == 1).OR.(nbondi == 2)) THEN 701 ssha_e(nlci-1,:) = ssha_e(nlci-2,:) 702 ENDIF 703 704 IF((nbondj == -1).OR.(nbondj == 2)) THEN 705 ssha_e(:,2) = ssha_e(:,3) 706 ENDIF 707 708 IF((nbondj == 1).OR.(nbondj == 2)) THEN 709 ssha_e(:,nlcj-1) = ssha_e(:,nlcj-2) 710 ENDIF 711 712 END SUBROUTINE Agrif_ssh_ts 713 714 SUBROUTINE interpsshn(tabres,i1,i2,j1,j2) 715 !!---------------------------------------------------------------------- 716 !! *** ROUTINE interpsshn *** 717 !!---------------------------------------------------------------------- 718 INTEGER, INTENT(in) :: i1,i2,j1,j2 719 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 720 !! 721 INTEGER :: ji,jj 722 !!---------------------------------------------------------------------- 723 724 tabres(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 725 726 END SUBROUTINE interpsshn 531 727 532 728 SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) … … 611 807 612 808 END SUBROUTINE interpv2d 809 810 SUBROUTINE interpunb(tabres,i1,i2,j1,j2) 811 !!---------------------------------------------------------------------- 812 !! *** ROUTINE interpunb *** 813 !!---------------------------------------------------------------------- 814 INTEGER, INTENT(in) :: i1,i2,j1,j2 815 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 816 !! 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 827 END DO 828 END DO 829 830 END SUBROUTINE interpunb 831 832 SUBROUTINE interpvnb(tabres,i1,i2,j1,j2) 833 !!---------------------------------------------------------------------- 834 !! *** ROUTINE interpvnb *** 835 !!---------------------------------------------------------------------- 836 INTEGER, INTENT(in) :: i1,i2,j1,j2 837 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 838 !! 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 849 END DO 850 END DO 851 852 END SUBROUTINE interpvnb 613 853 614 854 #else -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OFF_SRC/domain.F90
r4248 r4292 295 295 !! vertical scale factors. 296 296 !! 297 !! ** Method : - reference 1D vertical coordinate (gdep._ 0, e3._0)297 !! ** Method : - reference 1D vertical coordinate (gdep._1d, e3._1d) 298 298 !! - read/set ocean depth and ocean levels (bathy, mbathy) 299 299 !! - vertical coordinate (gdep., e3.) depending on the -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OFF_SRC/domrea.F90
r3680 r4292 25 25 26 26 PUBLIC dom_rea ! routine called by inidom.F90 27 !! * Substitutions 28 # include "domzgr_substitute.h90" 27 29 !!---------------------------------------------------------------------- 28 30 !! NEMO/OFF 3.3 , NEMO Consortium (2010) … … 173 175 CALL iom_get( inum4, jpdom_unknown, 'esigw', esigw ) 174 176 175 CALL iom_get( inum4, jpdom_data, 'e3t', e3t) ! scale factors176 CALL iom_get( inum4, jpdom_data, 'e3u', e3u)177 CALL iom_get( inum4, jpdom_data, 'e3v', e3v)178 CALL iom_get( inum4, jpdom_data, 'e3w', e3w)179 180 CALL iom_get( inum4, jpdom_unknown, 'gdept_ 0', gdept_0) ! depth181 CALL iom_get( inum4, jpdom_unknown, 'gdepw_ 0', gdepw_0)177 CALL iom_get( inum4, jpdom_data, 'e3t', fse3t_n(:,:,:) ) ! scale factors 178 CALL iom_get( inum4, jpdom_data, 'e3u', fse3u_n(:,:,:) ) 179 CALL iom_get( inum4, jpdom_data, 'e3v', fse3v_n(:,:,:) ) 180 CALL iom_get( inum4, jpdom_data, 'e3w', fse3w_n(:,:,:) ) 181 182 CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d ) ! depth 183 CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 182 184 ENDIF 183 185 184 186 185 187 IF( ln_zps ) THEN ! z-coordinate - partial steps 186 CALL iom_get( inum4, jpdom_unknown, 'gdept_ 0', gdept_0 )! reference depth187 CALL iom_get( inum4, jpdom_unknown, 'gdepw_ 0', gdepw_0)188 CALL iom_get( inum4, jpdom_unknown, 'e3t_ 0' , e3t_0) ! reference scale factors189 CALL iom_get( inum4, jpdom_unknown, 'e3w_ 0' , e3w_0)188 CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d ) ! reference depth 189 CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 190 CALL iom_get( inum4, jpdom_unknown, 'e3t_1d' , e3t_1d ) ! reference scale factors 191 CALL iom_get( inum4, jpdom_unknown, 'e3w_1d' , e3w_1d ) 190 192 ! 191 193 IF( nmsh <= 6 ) THEN ! 3D vertical scale factors 192 CALL iom_get( inum4, jpdom_data, 'e3t', e3t)193 CALL iom_get( inum4, jpdom_data, 'e3u', e3u)194 CALL iom_get( inum4, jpdom_data, 'e3v', e3v)195 CALL iom_get( inum4, jpdom_data, 'e3w', e3w)194 CALL iom_get( inum4, jpdom_data, 'e3t', fse3t_n(:,:,:) ) 195 CALL iom_get( inum4, jpdom_data, 'e3u', fse3u_n(:,:,:) ) 196 CALL iom_get( inum4, jpdom_data, 'e3v', fse3v_n(:,:,:) ) 197 CALL iom_get( inum4, jpdom_data, 'e3w', fse3w_n(:,:,:) ) 196 198 ELSE ! 2D bottom scale factors 197 199 CALL iom_get( inum4, jpdom_data, 'e3t_ps', e3tp ) … … 199 201 ! ! deduces the 3D scale factors 200 202 DO jk = 1, jpk 201 e3t(:,:,jk) = e3t_0(jk)! set to the ref. factors202 e3u(:,:,jk) = e3t_0(jk)203 e3v(:,:,jk) = e3t_0(jk)204 e3w(:,:,jk) = e3w_0(jk)203 fse3t_n(:,:,jk) = e3t_1d(jk) ! set to the ref. factors 204 fse3u_n(:,:,jk) = e3t_1d(jk) 205 fse3v_n(:,:,jk) = e3t_1d(jk) 206 fse3w_n(:,:,jk) = e3w_1d(jk) 205 207 END DO 206 208 DO jj = 1,jpj ! adjust the deepest values 207 209 DO ji = 1,jpi 208 210 ik = mbkt(ji,jj) 209 e3t(ji,jj,ik) = e3tp(ji,jj) * tmask(ji,jj,1) + e3t_0(1) * ( 1._wp - tmask(ji,jj,1) )210 e3w(ji,jj,ik) = e3wp(ji,jj) * tmask(ji,jj,1) + e3w_0(1) * ( 1._wp - tmask(ji,jj,1) )211 fse3t_n(ji,jj,ik) = e3tp(ji,jj) * tmask(ji,jj,1) + e3t_1d(1) * ( 1._wp - tmask(ji,jj,1) ) 212 fse3w_n(ji,jj,ik) = e3wp(ji,jj) * tmask(ji,jj,1) + e3w_1d(1) * ( 1._wp - tmask(ji,jj,1) ) 211 213 END DO 212 214 END DO … … 214 216 DO jj = 1, jpjm1 215 217 DO ji = 1, jpim1 216 e3u(ji,jj,jk) = MIN( e3t(ji,jj,jk), e3t(ji+1,jj,jk) )217 e3v(ji,jj,jk) = MIN( e3t(ji,jj,jk), e3t(ji,jj+1,jk) )218 fse3u_n(ji,jj,jk) = MIN( fse3t_n(ji,jj,jk), fse3t_n(ji+1,jj,jk) ) 219 fse3v_n(ji,jj,jk) = MIN( fse3t_n(ji,jj,jk), fse3t_n(ji,jj+1,jk) ) 218 220 END DO 219 221 END DO 220 222 END DO 221 CALL lbc_lnk( e3u , 'U', 1._wp ) ; CALL lbc_lnk( e3uw, 'U', 1._wp ) ! lateral boundary conditions222 CALL lbc_lnk( e3v , 'V', 1._wp ) ; CALL lbc_lnk( e3vw, 'V', 1._wp )223 CALL lbc_lnk( fse3u_n(:,:,:) , 'U', 1._wp ) ; CALL lbc_lnk( fse3uw_n(:,:,:), 'U', 1._wp ) ! lateral boundary conditions 224 CALL lbc_lnk( fse3v_n(:,:,:) , 'V', 1._wp ) ; CALL lbc_lnk( fse3vw_n(:,:,:), 'V', 1._wp ) 223 225 ! 224 226 DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries) 225 WHERE( e3u(:,:,jk) == 0._wp ) e3u(:,:,jk) = e3t_0(jk)226 WHERE( e3v(:,:,jk) == 0._wp ) e3v(:,:,jk) = e3t_0(jk)227 WHERE( fse3u_n(:,:,jk) == 0._wp ) fse3u_n(:,:,jk) = e3t_1d(jk) 228 WHERE( fse3v_n(:,:,jk) == 0._wp ) fse3v_n(:,:,jk) = e3t_1d(jk) 227 229 END DO 228 230 END IF 229 231 230 232 IF( iom_varid( inum4, 'gdept', ldstop = .FALSE. ) > 0 ) THEN ! 3D depth of t- and w-level 231 CALL iom_get( inum4, jpdom_data, 'gdept', gdept)232 CALL iom_get( inum4, jpdom_data, 'gdepw', gdepw)233 CALL iom_get( inum4, jpdom_data, 'gdept', fsdept_n(:,:,:) ) 234 CALL iom_get( inum4, jpdom_data, 'gdepw', fsdepw_n(:,:,:) ) 233 235 ELSE ! 2D bottom depth 234 236 CALL iom_get( inum4, jpdom_data, 'hdept', zprt ) … … 236 238 ! 237 239 DO jk = 1, jpk ! deduces the 3D depth 238 gdept(:,:,jk) = gdept_0(jk)239 gdepw(:,:,jk) = gdepw_0(jk)240 fsdept_n(:,:,jk) = gdept_1d(jk) 241 fsdepw_n(:,:,jk) = gdepw_1d(jk) 240 242 END DO 241 243 DO jj = 1, jpj … … 243 245 ik = mbkt(ji,jj) 244 246 IF( ik > 0 ) THEN 245 gdepw(ji,jj,ik+1) = zprw(ji,jj)246 gdept(ji,jj,ik ) = zprt(ji,jj)247 gdept(ji,jj,ik+1) = gdept(ji,jj,ik) + e3t(ji,jj,ik)247 fsdepw_n(ji,jj,ik+1) = zprw(ji,jj) 248 fsdept_n(ji,jj,ik ) = zprt(ji,jj) 249 fsdept_n(ji,jj,ik+1) = fsdept_n(ji,jj,ik) + fse3t_n(ji,jj,ik) 248 250 ENDIF 249 251 END DO … … 254 256 255 257 IF( ln_zco ) THEN ! Vertical coordinates and scales factors 256 CALL iom_get( inum4, jpdom_unknown, 'gdept_ 0', gdept_0) ! depth257 CALL iom_get( inum4, jpdom_unknown, 'gdepw_ 0', gdepw_0)258 CALL iom_get( inum4, jpdom_unknown, 'e3t_ 0' , e3t_0)259 CALL iom_get( inum4, jpdom_unknown, 'e3w_ 0' , e3w_0)258 CALL iom_get( inum4, jpdom_unknown, 'gdept_1d', gdept_1d ) ! depth 259 CALL iom_get( inum4, jpdom_unknown, 'gdepw_1d', gdepw_1d ) 260 CALL iom_get( inum4, jpdom_unknown, 'e3t_1d' , e3t_1d ) 261 CALL iom_get( inum4, jpdom_unknown, 'e3w_1d' , e3w_1d ) 260 262 DO jk = 1, jpk 261 e3t (:,:,jk) = e3t_0(jk)! set to the ref. factors262 e3u (:,:,jk) = e3t_0(jk)263 e3v (:,:,jk) = e3t_0(jk)264 e3w (:,:,jk) = e3w_0(jk)265 gdept(:,:,jk) = gdept_0(jk)266 gdepw(:,:,jk) = gdepw_0(jk)263 fse3t_n(:,:,jk) = e3t_1d(jk) ! set to the ref. factors 264 fse3u_n(:,:,jk) = e3t_1d(jk) 265 fse3v_n(:,:,jk) = e3t_1d(jk) 266 fse3w_n(:,:,jk) = e3w_1d(jk) 267 fsdept_n(:,:,jk) = gdept_1d(jk) 268 fsdepw_n(:,:,jk) = gdepw_1d(jk) 267 269 END DO 268 270 ENDIF … … 270 272 !!gm BUG in s-coordinate this does not work! 271 273 ! deepest/shallowest W level Above/Below ~10m 272 zrefdep = 10._wp - ( 0.1_wp * MINVAL(e3w_ 0) )! ref. depth with tolerance (10% of minimum layer thickness)273 nlb10 = MINLOC( gdepw_ 0, mask = gdepw_0 > zrefdep, dim = 1 )! shallowest W level Below ~10m274 zrefdep = 10._wp - ( 0.1_wp * MINVAL(e3w_1d) ) ! ref. depth with tolerance (10% of minimum layer thickness) 275 nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 274 276 nla10 = nlb10 - 1 ! deepest W level Above ~10m 275 277 !!gm end bug … … 312 314 WRITE(numout,*) ' Reference z-coordinate depth and scale factors:' 313 315 WRITE(numout, "(9x,' level gdept gdepw e3t e3w ')" ) 314 WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_ 0(jk), gdepw_0(jk), e3t_0(jk), e3w_0(jk), jk = 1, jpk )316 WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_1d(jk), gdepw_1d(jk), e3t_1d(jk), e3w_1d(jk), jk = 1, jpk ) 315 317 ENDIF 316 318 317 319 DO jk = 1, jpk 318 IF( e3w_ 0 (jk) <= 0._wp .OR. e3t_0 (jk) <= 0._wp ) CALL ctl_stop( ' e3w_0 or e3t_0=< 0 ' )319 IF( gdepw_ 0(jk) < 0._wp .OR. gdept_0(jk) < 0._wp ) CALL ctl_stop( ' gdepw_0 or gdept_0< 0 ' )320 IF( e3w_1d (jk) <= 0._wp .OR. e3t_1d (jk) <= 0._wp ) CALL ctl_stop( ' e3w_1d or e3t_1d =< 0 ' ) 321 IF( gdepw_1d(jk) < 0._wp .OR. gdept_1d(jk) < 0._wp ) CALL ctl_stop( ' gdepw_1d or gdept_1d < 0 ' ) 320 322 END DO 321 323 ! ! ============================ -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_oce.F90
r3651 r4292 8 8 !! 3.3 ! 2010-09 (D. Storkey) add ice boundary conditions 9 9 !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge 10 !! 3.6 ! 2012-01 (C. Rousset) add ice boundary conditions for lim3 10 11 !!---------------------------------------------------------------------- 11 12 #if defined key_bdy … … 27 28 INTEGER, POINTER, DIMENSION(:,:) :: nbr 28 29 INTEGER, POINTER, DIMENSION(:,:) :: nbmap 29 REAL , POINTER, DIMENSION(:,:) :: nbw 30 REAL , POINTER, DIMENSION(:,:) :: nbd 31 REAL , POINTER, DIMENSION(:) :: flagu 32 REAL , POINTER, DIMENSION(:) :: flagv 30 REAL(wp) , POINTER, DIMENSION(:,:) :: nbw 31 REAL(wp) , POINTER, DIMENSION(:,:) :: nbd 32 REAL(wp) , POINTER, DIMENSION(:,:) :: nbdout 33 REAL(wp) , POINTER, DIMENSION(:,:) :: flagu 34 REAL(wp) , POINTER, DIMENSION(:,:) :: flagv 33 35 END TYPE OBC_INDEX 34 36 37 !! Logicals in OBC_DATA structure are true if the chosen algorithm requires this 38 !! field as external data. If true the data can come from external files 39 !! or model initial conditions. If false then no "external" data array 40 !! is required for this field. 41 35 42 TYPE, PUBLIC :: OBC_DATA !: Storage for external data 36 REAL, POINTER, DIMENSION(:) :: ssh 37 REAL, POINTER, DIMENSION(:) :: u2d 38 REAL, POINTER, DIMENSION(:) :: v2d 39 REAL, POINTER, DIMENSION(:,:) :: u3d 40 REAL, POINTER, DIMENSION(:,:) :: v3d 41 REAL, POINTER, DIMENSION(:,:) :: tem 42 REAL, POINTER, DIMENSION(:,:) :: sal 43 INTEGER, DIMENSION(2) :: nread 44 LOGICAL :: ll_ssh 45 LOGICAL :: ll_u2d 46 LOGICAL :: ll_v2d 47 LOGICAL :: ll_u3d 48 LOGICAL :: ll_v3d 49 LOGICAL :: ll_tem 50 LOGICAL :: ll_sal 51 REAL(wp), POINTER, DIMENSION(:) :: ssh 52 REAL(wp), POINTER, DIMENSION(:) :: u2d 53 REAL(wp), POINTER, DIMENSION(:) :: v2d 54 REAL(wp), POINTER, DIMENSION(:,:) :: u3d 55 REAL(wp), POINTER, DIMENSION(:,:) :: v3d 56 REAL(wp), POINTER, DIMENSION(:,:) :: tem 57 REAL(wp), POINTER, DIMENSION(:,:) :: sal 43 58 #if defined key_lim2 44 REAL, POINTER, DIMENSION(:) :: frld 45 REAL, POINTER, DIMENSION(:) :: hicif 46 REAL, POINTER, DIMENSION(:) :: hsnif 59 LOGICAL :: ll_frld 60 LOGICAL :: ll_hicif 61 LOGICAL :: ll_hsnif 62 REAL(wp), POINTER, DIMENSION(:) :: frld 63 REAL(wp), POINTER, DIMENSION(:) :: hicif 64 REAL(wp), POINTER, DIMENSION(:) :: hsnif 65 #elif defined key_lim3 66 LOGICAL :: ll_a_i 67 LOGICAL :: ll_ht_i 68 LOGICAL :: ll_ht_s 69 REAL, POINTER, DIMENSION(:,:) :: a_i !: now ice leads fraction climatology 70 REAL, POINTER, DIMENSION(:,:) :: ht_i !: Now ice thickness climatology 71 REAL, POINTER, DIMENSION(:,:) :: ht_s !: now snow thickness 47 72 #endif 48 73 END TYPE OBC_DATA … … 63 88 INTEGER :: nn_volctl !: = 0 the total volume will have the variability of the surface Flux E-P 64 89 ! ! = 1 the volume will be constant during all the integration. 65 INTEGER, DIMENSION(jp_bdy) :: nn_dyn2d! Choice of boundary condition for barotropic variables (U,V,SSH)66 INTEGER, DIMENSION(jp_bdy) :: nn_dyn2d_dta!: = 0 use the initial state as bdy dta ;90 CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_dyn2d ! Choice of boundary condition for barotropic variables (U,V,SSH) 91 INTEGER, DIMENSION(jp_bdy) :: nn_dyn2d_dta !: = 0 use the initial state as bdy dta ; 67 92 !: = 1 read it in a NetCDF file 68 93 !: = 2 read tidal harmonic forcing from a NetCDF file 69 94 !: = 3 read external data AND tidal harmonic forcing from NetCDF files 70 INTEGER, DIMENSION(jp_bdy) :: nn_dyn3d! Choice of boundary condition for baroclinic velocities71 INTEGER, DIMENSION(jp_bdy) :: nn_dyn3d_dta!: = 0 use the initial state as bdy dta ;95 CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_dyn3d ! Choice of boundary condition for baroclinic velocities 96 INTEGER, DIMENSION(jp_bdy) :: nn_dyn3d_dta !: = 0 use the initial state as bdy dta ; 72 97 !: = 1 read it in a NetCDF file 73 INTEGER, DIMENSION(jp_bdy) :: nn_tra! Choice of boundary condition for active tracers (T and S)74 INTEGER, DIMENSION(jp_bdy) :: nn_tra_dta!: = 0 use the initial state as bdy dta ;98 CHARACTER(len=20), DIMENSION(jp_bdy) :: cn_tra ! Choice of boundary condition for active tracers (T and S) 99 INTEGER, DIMENSION(jp_bdy) :: nn_tra_dta !: = 0 use the initial state as bdy dta ; 75 100 !: = 1 read it in a NetCDF file 76 101 LOGICAL, DIMENSION(jp_bdy) :: ln_tra_dmp !: =T Tracer damping 77 102 LOGICAL, DIMENSION(jp_bdy) :: ln_dyn3d_dmp !: =T Baroclinic velocity damping 78 REAL, DIMENSION(jp_bdy) :: rn_time_dmp !: Damping time scale in days 103 REAL(wp), DIMENSION(jp_bdy) :: rn_time_dmp !: Damping time scale in days 104 REAL(wp), DIMENSION(jp_bdy) :: rn_time_dmp_out !: Damping time scale in days at radiation outflow points 79 105 80 106 #if defined key_lim2 81 INTEGER, DIMENSION(jp_bdy) :: nn_ice_lim2! Choice of boundary condition for sea ice variables82 INTEGER, DIMENSION(jp_bdy) :: nn_ice_lim2_dta!: = 0 use the initial state as bdy dta ;83 !: = 1 read it in a NetCDF file107 CHARACTER(len=20), DIMENSION(jp_bdy) :: nn_ice_lim2 ! Choice of boundary condition for sea ice variables 108 INTEGER, DIMENSION(jp_bdy) :: nn_ice_lim2_dta !: = 0 use the initial state as bdy dta ; 109 !: = 1 read it in a NetCDF file 84 110 #endif 85 111 ! … … 88 114 !! Global variables 89 115 !!---------------------------------------------------------------------- 90 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: bdytmask !: Mask defining computational domain at T-points91 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: bdyumask !: Mask defining computational domain at U-points92 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: bdyvmask !: Mask defining computational domain at V-points116 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdytmask !: Mask defining computational domain at T-points 117 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdyumask !: Mask defining computational domain at U-points 118 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: bdyvmask !: Mask defining computational domain at V-points 93 119 94 120 REAL(wp) :: bdysurftot !: Lateral surface of unstructured open boundary 95 121 96 REAL(wp), POINTER, DIMENSION(:,:) :: pssh !:97 REAL(wp), POINTER, DIMENSION(:,:) :: phur !:98 REAL(wp), POINTER, DIMENSION(:,:) :: phvr !: Pointers for barotropic fields99 REAL(wp), POINTER, DIMENSION(:,:) :: pu 2d!:100 REAL(wp), POINTER, DIMENSION(:,:) :: pv 2d!:122 REAL(wp), POINTER, DIMENSION(:,:) :: pssh !: 123 REAL(wp), POINTER, DIMENSION(:,:) :: phur !: 124 REAL(wp), POINTER, DIMENSION(:,:) :: phvr !: Pointers for barotropic fields 125 REAL(wp), POINTER, DIMENSION(:,:) :: pub2d, pun2d, pua2d !: 126 REAL(wp), POINTER, DIMENSION(:,:) :: pvb2d, pvn2d, pva2d !: 101 127 102 128 !!---------------------------------------------------------------------- … … 109 135 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: dta_global2 !: workspace for reading in global data arrays (struct. bdy) 110 136 TYPE(OBC_INDEX), DIMENSION(jp_bdy), TARGET :: idx_bdy !: bdy indices (local process) 111 TYPE(OBC_DATA) , DIMENSION(jp_bdy) 137 TYPE(OBC_DATA) , DIMENSION(jp_bdy), TARGET :: dta_bdy !: bdy external data (local process) 112 138 113 139 !!---------------------------------------------------------------------- … … 125 151 !!---------------------------------------------------------------------- 126 152 ! 127 ALLOCATE( bdytmask(jpi,jpj) , bdyumask(jpi,jpj), bdyvmask(jpi,jpj), 153 ALLOCATE( bdytmask(jpi,jpj) , bdyumask(jpi,jpj), bdyvmask(jpi,jpj), & 128 154 & STAT=bdy_oce_alloc ) 129 155 ! -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_par.F90
r3294 r4292 23 23 # endif 24 24 INTEGER, PUBLIC, PARAMETER :: jp_bdy = 10 !: Maximum number of bdy sets 25 INTEGER, PUBLIC, PARAMETER :: jpbtime = 1000 !: Max number of time dumps per file26 25 INTEGER, PUBLIC, PARAMETER :: jpbgrd = 3 !: Number of horizontal grid types used (T, U, V) 27 26 28 !! Flags for choice of schemes29 INTEGER, PUBLIC, PARAMETER :: jp_none = 0 !: Flag for no open boundary condition30 INTEGER, PUBLIC, PARAMETER :: jp_frs = 1 !: Flag for Flow Relaxation Scheme31 INTEGER, PUBLIC, PARAMETER :: jp_flather = 2 !: Flag for Flather32 27 #else 33 28 !!---------------------------------------------------------------------- -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90
r4230 r4292 11 11 !! 3.3 ! 2010-09 (D.Storkey) add ice boundary conditions 12 12 !! 3.4 ! 2011 (D. Storkey) rewrite in preparation for OBC-BDY merge 13 !! 3.6 ! 2012-01 (C. Rousset) add ice boundary conditions for lim3 13 14 !!---------------------------------------------------------------------- 14 15 #if defined key_bdy … … 29 30 USE iom ! IOM library 30 31 USE in_out_manager ! I/O logical units 32 USE dynspg_oce, ONLY: lk_dynspg_ts ! Split-explicit free surface flag 31 33 #if defined key_lim2 32 34 USE ice_2 35 #elif defined key_lim3 36 USE par_ice 37 USE ice 38 USE limcat_1D ! redistribute ice input into categories 33 39 #endif 34 40 USE sbcapr … … 49 55 50 56 TYPE(MAP_POINTER), ALLOCATABLE, DIMENSION(:) :: nbmap_ptr ! array of pointers to nbmap 57 58 #if defined key_lim3 59 LOGICAL :: ll_bdylim3 ! determine whether ice input is lim2 (F) or lim3 (T) type 60 INTEGER :: jfld_hti, jfld_hts, jfld_ai ! indices of ice thickness, snow thickness and concentration in bf structure 61 #endif 51 62 52 63 # include "domzgr_substitute.h90" … … 77 88 ! etc. 78 89 !! 79 INTEGER :: ib_bdy, jfld, jstart, jend, ib, ii, ij, ik, igrd ! local indices90 INTEGER :: ib_bdy, jfld, jstart, jend, ib, ii, ij, ik, igrd, jl ! local indices 80 91 INTEGER, DIMENSION(jpbgrd) :: ilen1 81 92 INTEGER, POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts 93 TYPE(OBC_DATA), POINTER :: dta ! short cut 82 94 !! 83 95 !!--------------------------------------------------------------------------- … … 91 103 ! Calculate depth-mean currents 92 104 !----------------------------- 93 CALL wrk_alloc(jpi,jpj,pu2d,pv2d) 94 95 pu2d(:,:) = 0.e0 96 pv2d(:,:) = 0.e0 97 105 CALL wrk_alloc(jpi,jpj,pun2d,pvn2d) 106 107 pun2d(:,:) = 0.e0 108 pvn2d(:,:) = 0.e0 98 109 DO ik = 1, jpkm1 !! Vertically integrated momentum trends 99 pu 2d(:,:) = pu2d(:,:) + fse3u(:,:,ik) * umask(:,:,ik) * un(:,:,ik)100 pv 2d(:,:) = pv2d(:,:) + fse3v(:,:,ik) * vmask(:,:,ik) * vn(:,:,ik)110 pun2d(:,:) = pun2d(:,:) + fse3u(:,:,ik) * umask(:,:,ik) * un(:,:,ik) 111 pvn2d(:,:) = pvn2d(:,:) + fse3v(:,:,ik) * vmask(:,:,ik) * vn(:,:,ik) 101 112 END DO 102 pu 2d(:,:) = pu2d(:,:) * hur(:,:)103 pv 2d(:,:) = pv2d(:,:) * hvr(:,:)113 pun2d(:,:) = pun2d(:,:) * hur(:,:) 114 pvn2d(:,:) = pvn2d(:,:) * hvr(:,:) 104 115 105 116 DO ib_bdy = 1, nb_bdy … … 107 118 nblen => idx_bdy(ib_bdy)%nblen 108 119 nblenrim => idx_bdy(ib_bdy)%nblenrim 109 110 IF( nn_dyn2d(ib_bdy) .gt. 0 .and. nn_dyn2d_dta(ib_bdy) .eq. 0 ) THEN 120 dta => dta_bdy(ib_bdy) 121 122 IF( nn_dyn2d_dta(ib_bdy) .eq. 0 ) THEN 111 123 ilen1(:) = nblen(:) 112 igrd = 1 113 DO ib = 1, ilen1(igrd) 114 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 115 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 116 dta_bdy(ib_bdy)%ssh(ib) = sshn(ii,ij) * tmask(ii,ij,1) 117 END DO 118 igrd = 2 119 DO ib = 1, ilen1(igrd) 120 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 121 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 122 dta_bdy(ib_bdy)%u2d(ib) = pu2d(ii,ij) * umask(ii,ij,1) 123 END DO 124 igrd = 3 125 DO ib = 1, ilen1(igrd) 126 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 127 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 128 dta_bdy(ib_bdy)%v2d(ib) = pv2d(ii,ij) * vmask(ii,ij,1) 129 END DO 130 ENDIF 131 132 IF( nn_dyn3d(ib_bdy) .gt. 0 .and. nn_dyn3d_dta(ib_bdy) .eq. 0 ) THEN 133 ilen1(:) = nblen(:) 134 igrd = 2 135 DO ib = 1, ilen1(igrd) 136 DO ik = 1, jpkm1 124 IF( dta%ll_ssh ) THEN 125 igrd = 1 126 DO ib = 1, ilen1(igrd) 137 127 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 138 128 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 139 dta_bdy(ib_bdy)% u3d(ib,ik) = ( un(ii,ij,ik) - pu2d(ii,ij) ) * umask(ii,ij,ik)140 END DO 141 END DO142 igrd = 3143 DO ib = 1, ilen1(igrd)144 DO i k = 1, jpkm1129 dta_bdy(ib_bdy)%ssh(ib) = sshn(ii,ij) * tmask(ii,ij,1) 130 END DO 131 END IF 132 IF( dta%ll_u2d ) THEN 133 igrd = 2 134 DO ib = 1, ilen1(igrd) 145 135 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 146 136 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 147 dta_bdy(ib_bdy)%v3d(ib,ik) = ( vn(ii,ij,ik) - pv2d(ii,ij) ) * vmask(ii,ij,ik) 148 END DO 149 END DO 150 ENDIF 151 152 IF( nn_tra(ib_bdy) .gt. 0 .and. nn_tra_dta(ib_bdy) .eq. 0 ) THEN 153 ilen1(:) = nblen(:) 154 igrd = 1 ! Everything is at T-points here 155 DO ib = 1, ilen1(igrd) 156 DO ik = 1, jpkm1 137 dta_bdy(ib_bdy)%u2d(ib) = pun2d(ii,ij) * umask(ii,ij,1) 138 END DO 139 END IF 140 IF( dta%ll_v2d ) THEN 141 igrd = 3 142 DO ib = 1, ilen1(igrd) 157 143 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 158 144 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 159 dta_bdy(ib_bdy)%tem(ib,ik) = tsn(ii,ij,ik,jp_tem) * tmask(ii,ij,ik) 160 dta_bdy(ib_bdy)%sal(ib,ik) = tsn(ii,ij,ik,jp_sal) * tmask(ii,ij,ik) 145 dta_bdy(ib_bdy)%v2d(ib) = pvn2d(ii,ij) * vmask(ii,ij,1) 146 END DO 147 END IF 148 ENDIF 149 150 IF( nn_dyn3d_dta(ib_bdy) .eq. 0 ) THEN 151 ilen1(:) = nblen(:) 152 IF( dta%ll_u3d ) THEN 153 igrd = 2 154 DO ib = 1, ilen1(igrd) 155 DO ik = 1, jpkm1 156 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 157 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 158 dta_bdy(ib_bdy)%u3d(ib,ik) = ( un(ii,ij,ik) - pun2d(ii,ij) ) * umask(ii,ij,ik) 159 END DO 160 END DO 161 END IF 162 IF( dta%ll_v3d ) THEN 163 igrd = 3 164 DO ib = 1, ilen1(igrd) 165 DO ik = 1, jpkm1 166 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 167 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 168 dta_bdy(ib_bdy)%v3d(ib,ik) = ( vn(ii,ij,ik) - pvn2d(ii,ij) ) * vmask(ii,ij,ik) 169 END DO 170 END DO 171 END IF 172 ENDIF 173 174 IF( nn_tra_dta(ib_bdy) .eq. 0 ) THEN 175 ilen1(:) = nblen(:) 176 IF( dta%ll_tem ) THEN 177 igrd = 1 178 DO ib = 1, ilen1(igrd) 179 DO ik = 1, jpkm1 180 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 181 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 182 dta_bdy(ib_bdy)%tem(ib,ik) = tsn(ii,ij,ik,jp_tem) * tmask(ii,ij,ik) 183 END DO 184 END DO 185 END IF 186 IF( dta%ll_sal ) THEN 187 igrd = 1 188 DO ib = 1, ilen1(igrd) 189 DO ik = 1, jpkm1 190 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 191 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 192 dta_bdy(ib_bdy)%sal(ib,ik) = tsn(ii,ij,ik,jp_sal) * tmask(ii,ij,ik) 193 END DO 194 END DO 195 END IF 196 ENDIF 197 198 #if defined key_lim2 199 IF( nn_ice_lim2_dta(ib_bdy) .eq. 0 ) THEN 200 ilen1(:) = nblen(:) 201 IF( dta%ll_frld ) THEN 202 igrd = 1 203 DO ib = 1, ilen1(igrd) 204 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 205 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 206 dta_bdy(ib_bdy)%frld(ib) = frld(ii,ij) * tmask(ii,ij,1) 207 END DO 208 END IF 209 IF( dta%ll_hicif ) THEN 210 igrd = 1 211 DO ib = 1, ilen1(igrd) 212 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 213 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 214 dta_bdy(ib_bdy)%hicif(ib) = hicif(ii,ij) * tmask(ii,ij,1) 215 END DO 216 END IF 217 IF( dta%ll_hsnif ) THEN 218 igrd = 1 219 DO ib = 1, ilen1(igrd) 220 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 221 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 222 dta_bdy(ib_bdy)%hsnif(ib) = hsnif(ii,ij) * tmask(ii,ij,1) 223 END DO 224 END IF 225 ENDIF 226 #elif defined key_lim3 227 IF( nn_ice_lim_dta(ib_bdy) .eq. 0 ) THEN 228 ilen1(:) = nblen(:) 229 IF( dta%ll_a_i ) THEN 230 igrd = 1 231 DO jl = 1, jpl 232 DO ib = 1, ilen1(igrd) 233 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 234 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 235 dta_bdy(ib_bdy)%a_i (ib,jl) = a_i(ii,ij,jl) * tmask(ii,ij,1) 236 END DO 161 237 END DO 162 END DO 163 ENDIF 164 165 #if defined key_lim2 166 IF( nn_ice_lim2(ib_bdy) .gt. 0 .and. nn_ice_lim2_dta(ib_bdy) .eq. 0 ) THEN 167 ilen1(:) = nblen(:) 168 igrd = 1 ! Everything is at T-points here 169 DO ib = 1, ilen1(igrd) 170 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 171 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 172 dta_bdy(ib_bdy)%frld(ib) = frld(ii,ij) * tmask(ii,ij,1) 173 dta_bdy(ib_bdy)%hicif(ib) = hicif(ii,ij) * tmask(ii,ij,1) 174 dta_bdy(ib_bdy)%hsnif(ib) = hsnif(ii,ij) * tmask(ii,ij,1) 175 END DO 238 ENDIF 239 IF( dta%ll_ht_i ) THEN 240 igrd = 1 241 DO jl = 1, jpl 242 DO ib = 1, ilen1(igrd) 243 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 244 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 245 dta_bdy(ib_bdy)%ht_i (ib,jl) = ht_i(ii,ij,jl) * tmask(ii,ij,1) 246 END DO 247 END DO 248 ENDIF 249 IF( dta%ll_ht_s ) THEN 250 igrd = 1 251 DO jl = 1, jpl 252 DO ib = 1, ilen1(igrd) 253 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 254 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 255 dta_bdy(ib_bdy)%ht_s (ib,jl) = ht_s(ii,ij,jl) * tmask(ii,ij,1) 256 END DO 257 END DO 258 ENDIF 176 259 ENDIF 177 260 #endif … … 179 262 ENDDO ! ib_bdy 180 263 181 CALL wrk_dealloc(jpi,jpj,pu 2d,pv2d)264 CALL wrk_dealloc(jpi,jpj,pun2d,pvn2d) 182 265 183 266 ENDIF ! kt .eq. nit000 … … 188 271 jstart = 1 189 272 DO ib_bdy = 1, nb_bdy 273 dta => dta_bdy(ib_bdy) 190 274 IF( nn_dta(ib_bdy) .eq. 1 ) THEN ! skip this bit if no external data required 191 275 … … 193 277 ! Update barotropic boundary conditions only 194 278 ! jit is optional argument for fld_read and bdytide_update 195 IF( nn_dyn2d(ib_bdy) .gt. 0) THEN279 IF( cn_dyn2d(ib_bdy) /= 'none' ) THEN 196 280 IF( nn_dyn2d_dta(ib_bdy) .eq. 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 197 dta_bdy(ib_bdy)%ssh(:) = 0.0198 dta_bdy(ib_bdy)%u2d(:) = 0.0199 dta_bdy(ib_bdy)%v2d(:) = 0.0281 IF( dta%ll_ssh ) dta%ssh(:) = 0.0 282 IF( dta%ll_u2d ) dta%u2d(:) = 0.0 283 IF( dta%ll_u3d ) dta%v2d(:) = 0.0 200 284 ENDIF 201 IF (nn_tra(ib_bdy).ne.4) THEN 202 IF( nn_dyn2d_dta(ib_bdy) .EQ. 1 .OR. nn_dyn2d_dta(ib_bdy) .EQ. 3 .OR. & 203 & (ln_full_vel_array(ib_bdy) .AND. nn_dyn3d_dta(ib_bdy).eq.1) )THEN 204 205 ! For the runoff case, no need to update the forcing (already done in the baroclinic part) 206 jend = nb_bdy_fld(ib_bdy) 207 IF ( nn_tra(ib_bdy) .GT. 0 .AND. nn_tra_dta(ib_bdy) .GE. 1 ) jend = jend - 2 285 IF (cn_tra(ib_bdy) /= 'runoff') THEN 286 IF( nn_dyn2d_dta(ib_bdy) .EQ. 1 .OR. nn_dyn2d_dta(ib_bdy) .EQ. 3 ) THEN 287 288 jend = jstart + dta%nread(2) - 1 208 289 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), map=nbmap_ptr(jstart:jend), & 209 290 & kit=jit, kt_offset=time_offset ) 210 IF ( nn_tra(ib_bdy) .GT. 0 .AND. nn_tra_dta(ib_bdy) .GE. 1 ) jend = jend + 2 211 212 ! If full velocities in boundary data then split into barotropic and baroclinic data 291 292 ! If full velocities in boundary data then extract barotropic velocities from 3D fields 213 293 IF( ln_full_vel_array(ib_bdy) .AND. & 214 294 & ( nn_dyn2d_dta(ib_bdy) .EQ. 1 .OR. nn_dyn2d_dta(ib_bdy) .EQ. 3 .OR. & … … 216 296 217 297 igrd = 2 ! zonal velocity 218 dta _bdy(ib_bdy)%u2d(:) = 0.0298 dta%u2d(:) = 0.0 219 299 DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 220 300 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 221 301 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 222 302 DO ik = 1, jpkm1 223 dta _bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) &224 & + fse3u(ii,ij,ik) * umask(ii,ij,ik) * dta _bdy(ib_bdy)%u3d(ib,ik)303 dta%u2d(ib) = dta%u2d(ib) & 304 & + fse3u(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik) 225 305 END DO 226 dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) * hur(ii,ij) 227 DO ik = 1, jpkm1 228 dta_bdy(ib_bdy)%u3d(ib,ik) = dta_bdy(ib_bdy)%u3d(ib,ik) - dta_bdy(ib_bdy)%u2d(ib) 229 END DO 306 dta%u2d(ib) = dta%u2d(ib) * hur(ii,ij) 230 307 END DO 231 308 igrd = 3 ! meridional velocity 232 dta _bdy(ib_bdy)%v2d(:) = 0.0309 dta%v2d(:) = 0.0 233 310 DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 234 311 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 235 312 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 236 313 DO ik = 1, jpkm1 237 dta _bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) &238 & + fse3v(ii,ij,ik) * vmask(ii,ij,ik) * dta _bdy(ib_bdy)%v3d(ib,ik)314 dta%v2d(ib) = dta%v2d(ib) & 315 & + fse3v(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 239 316 END DO 240 dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) * hvr(ii,ij) 241 DO ik = 1, jpkm1 242 dta_bdy(ib_bdy)%v3d(ib,ik) = dta_bdy(ib_bdy)%v3d(ib,ik) - dta_bdy(ib_bdy)%v2d(ib) 243 END DO 317 dta%v2d(ib) = dta%v2d(ib) * hvr(ii,ij) 244 318 END DO 245 319 ENDIF 246 320 ENDIF 247 321 IF( nn_dyn2d_dta(ib_bdy) .ge. 2 ) THEN ! update tidal harmonic forcing 248 CALL bdytide_update( kt=kt, idx=idx_bdy(ib_bdy), dta=dta _bdy(ib_bdy), td=tides(ib_bdy), &322 CALL bdytide_update( kt=kt, idx=idx_bdy(ib_bdy), dta=dta, td=tides(ib_bdy), & 249 323 & jit=jit, time_offset=time_offset ) 250 324 ENDIF … … 252 326 ENDIF 253 327 ELSE 254 IF ( nn_tra(ib_bdy).eq.4) then ! runoff condition328 IF (cn_tra(ib_bdy) == 'runoff') then ! runoff condition 255 329 jend = nb_bdy_fld(ib_bdy) 256 330 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & … … 261 335 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 262 336 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 263 dta _bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) )337 dta%u2d(ib) = dta%u2d(ib) / ( e2u(ii,ij) * hu_0(ii,ij) ) 264 338 END DO 265 339 ! … … 268 342 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 269 343 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 270 dta _bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) )344 dta%v2d(ib) = dta%v2d(ib) / ( e1v(ii,ij) * hv_0(ii,ij) ) 271 345 END DO 272 346 ELSE 273 IF( nn_dyn2d (ib_bdy) .gt. 0 .and. nn_dyn2d_dta(ib_bdy) .eq. 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays274 dta_bdy(ib_bdy)%ssh(:) = 0.0275 dta_bdy(ib_bdy)%u2d(:) = 0.0276 dta_bdy(ib_bdy)%v2d(:) = 0.0347 IF( nn_dyn2d_dta(ib_bdy) .eq. 2 ) THEN ! tidal harmonic forcing ONLY: initialise arrays 348 IF( dta%ll_ssh ) dta%ssh(:) = 0.0 349 IF( dta%ll_u2d ) dta%u2d(:) = 0.0 350 IF( dta%ll_v2d ) dta%v2d(:) = 0.0 277 351 ENDIF 278 IF( nb_bdy_fld(ib_bdy) .gt. 0 ) THEN ! update external data279 jend = nb_bdy_fld(ib_bdy)352 IF( dta%nread(1) .gt. 0 ) THEN ! update external data 353 jend = jstart + dta%nread(1) - 1 280 354 CALL fld_read( kt=kt, kn_fsbc=1, sd=bf(jstart:jend), & 281 355 & map=nbmap_ptr(jstart:jend), kt_offset=time_offset ) … … 286 360 & nn_dyn3d_dta(ib_bdy) .EQ. 1 ) ) THEN 287 361 igrd = 2 ! zonal velocity 288 dta _bdy(ib_bdy)%u2d(:) = 0.0362 dta%u2d(:) = 0.0 289 363 DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 290 364 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 291 365 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 292 366 DO ik = 1, jpkm1 293 dta _bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) &294 & + fse3u(ii,ij,ik) * umask(ii,ij,ik) * dta _bdy(ib_bdy)%u3d(ib,ik)367 dta%u2d(ib) = dta%u2d(ib) & 368 & + fse3u(ii,ij,ik) * umask(ii,ij,ik) * dta%u3d(ib,ik) 295 369 END DO 296 dta _bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) * hur(ii,ij)370 dta%u2d(ib) = dta%u2d(ib) * hur(ii,ij) 297 371 DO ik = 1, jpkm1 298 dta _bdy(ib_bdy)%u3d(ib,ik) = dta_bdy(ib_bdy)%u3d(ib,ik) - dta_bdy(ib_bdy)%u2d(ib)372 dta%u3d(ib,ik) = dta%u3d(ib,ik) - dta%u2d(ib) 299 373 END DO 300 374 END DO 301 375 igrd = 3 ! meridional velocity 302 dta _bdy(ib_bdy)%v2d(:) = 0.0376 dta%v2d(:) = 0.0 303 377 DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) 304 378 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 305 379 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 306 380 DO ik = 1, jpkm1 307 dta _bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) &308 & + fse3v(ii,ij,ik) * vmask(ii,ij,ik) * dta _bdy(ib_bdy)%v3d(ib,ik)381 dta%v2d(ib) = dta%v2d(ib) & 382 & + fse3v(ii,ij,ik) * vmask(ii,ij,ik) * dta%v3d(ib,ik) 309 383 END DO 310 dta _bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) * hvr(ii,ij)384 dta%v2d(ib) = dta%v2d(ib) * hvr(ii,ij) 311 385 DO ik = 1, jpkm1 312 dta _bdy(ib_bdy)%v3d(ib,ik) = dta_bdy(ib_bdy)%v3d(ib,ik) - dta_bdy(ib_bdy)%v2d(ib)386 dta%v3d(ib,ik) = dta%v3d(ib,ik) - dta%v2d(ib) 313 387 END DO 314 388 END DO 315 389 ENDIF 316 IF( nn_dyn2d(ib_bdy) .gt. 0 .and. nn_dyn2d_dta(ib_bdy) .ge. 2 ) THEN ! update tidal harmonic forcing 317 CALL bdytide_update( kt=kt, idx=idx_bdy(ib_bdy), dta=dta_bdy(ib_bdy), & 318 & td=tides(ib_bdy), time_offset=time_offset ) 319 ENDIF 320 ENDIF 321 ENDIF 322 jstart = jend+1 390 391 ENDIF 392 #if defined key_lim3 393 IF( .NOT. ll_bdylim3 .AND. nn_ice_lim(ib_bdy) > 0 .AND. nn_ice_lim_dta(ib_bdy) == 1 ) THEN ! bdy ice input (case input is lim2 type) 394 CALL lim_cat_1D ( bf(jfld_hti)%fnow(:,1,1), bf(jfld_hts)%fnow(:,1,1), bf(jfld_ai)%fnow(:,1,1), & 395 & dta_bdy(ib_bdy)%ht_i, dta_bdy(ib_bdy)%ht_s, dta_bdy(ib_bdy)%a_i ) 396 ENDIF 397 #endif 398 ENDIF 399 jstart = jstart + dta%nread(1) 323 400 END IF ! nn_dta(ib_bdy) = 1 324 401 END DO ! ib_bdy 325 402 403 ! bg jchanut tschanges 404 #if defined key_tide 405 ! Add tides if not split-explicit free surface else this is done in ts loop 406 IF (.NOT.lk_dynspg_ts) CALL bdy_dta_tides( kt=kt, time_offset=time_offset ) 407 #endif 408 ! end jchanut tschanges 409 326 410 IF ( ln_apr_obc ) THEN 327 411 DO ib_bdy = 1, nb_bdy 328 IF ( nn_tra(ib_bdy).NE.4)THEN412 IF (cn_tra(ib_bdy) /= 'runoff')THEN 329 413 igrd = 1 ! meridional velocity 330 414 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) … … 349 433 !! for open boundary conditions 350 434 !! 351 !! ** Method : Use fldread.F90435 !! ** Method : 352 436 !! 353 437 !!---------------------------------------------------------------------- … … 362 446 ! =F => baroclinic velocities in 3D boundary data 363 447 INTEGER :: ilen_global ! Max length required for global bdy dta arrays 364 INTEGER, DIMENSION(jpbgrd) :: ilen0 ! size of local arrays365 448 INTEGER, ALLOCATABLE, DIMENSION(:) :: ilen1, ilen3 ! size of 1st and 3rd dimensions of local arrays 366 449 INTEGER, ALLOCATABLE, DIMENSION(:) :: ibdy ! bdy set for a particular jfld 367 450 INTEGER, ALLOCATABLE, DIMENSION(:) :: igrid ! index for grid type (1,2,3 = T,U,V) 368 451 INTEGER, POINTER, DIMENSION(:) :: nblen, nblenrim ! short cuts 452 TYPE(OBC_DATA), POINTER :: dta ! short cut 453 #if defined key_lim3 454 INTEGER, DIMENSION(3) :: zdimsz ! number of elements in each of the 4 dimensions (i.e. i,j,t,ice-cat) for an array 455 INTEGER :: zndims ! number of dimensions in an array (i.e. 3 = wo ice cat; 4 = w ice cat) 456 INTEGER :: inum,id1 ! local integer 457 #endif 369 458 TYPE(FLD_N), ALLOCATABLE, DIMENSION(:) :: blf_i ! array of namelist information structures 370 459 TYPE(FLD_N) :: bn_tem, bn_sal, bn_u3d, bn_v3d ! … … 372 461 #if defined key_lim2 373 462 TYPE(FLD_N) :: bn_frld, bn_hicif, bn_hsnif ! 463 #elif defined key_lim3 464 TYPE(FLD_N) :: bn_a_i, bn_ht_i, bn_ht_s 374 465 #endif 375 466 NAMELIST/nambdy_dta/ cn_dir, bn_tem, bn_sal, bn_u3d, bn_v3d, bn_ssh, bn_u2d, bn_v2d 376 467 #if defined key_lim2 377 468 NAMELIST/nambdy_dta/ bn_frld, bn_hicif, bn_hsnif 469 #elif defined key_lim3 470 NAMELIST/nambdy_dta/ bn_a_i, bn_ht_i, bn_ht_s 378 471 #endif 379 472 NAMELIST/nambdy_dta/ ln_full_vel … … 392 485 ,nn_dyn3d_dta(ib_bdy) & 393 486 ,nn_tra_dta(ib_bdy) & 394 #if defined key_lim2395 ,nn_ice_lim2_dta(ib_bdy) &487 #if ( defined key_lim2 || defined key_lim3 ) 488 ,nn_ice_lim_dta(ib_bdy) & 396 489 #endif 397 490 ) … … 404 497 nb_bdy_fld(:) = 0 405 498 DO ib_bdy = 1, nb_bdy 406 IF( nn_dyn2d(ib_bdy) .gt. 0.and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) THEN499 IF( cn_dyn2d(ib_bdy) /= 'none' .and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) THEN 407 500 nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 3 408 501 ENDIF 409 IF( nn_dyn3d(ib_bdy) .gt. 0.and. nn_dyn3d_dta(ib_bdy) .eq. 1 ) THEN502 IF( cn_dyn3d(ib_bdy) /= 'none' .and. nn_dyn3d_dta(ib_bdy) .eq. 1 ) THEN 410 503 nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 2 411 504 ENDIF 412 IF( nn_tra(ib_bdy) .gt. 0.and. nn_tra_dta(ib_bdy) .eq. 1 ) THEN505 IF( cn_tra(ib_bdy) /= 'none' .and. nn_tra_dta(ib_bdy) .eq. 1 ) THEN 413 506 nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 2 414 507 ENDIF 415 #if defined key_lim2416 IF( nn_ice_lim2(ib_bdy) .gt. 0 .and. nn_ice_lim2_dta(ib_bdy) .eq. 1 ) THEN508 #if ( defined key_lim2 || defined key_lim3 ) 509 IF( cn_ice_lim(ib_bdy) /= 'none' .and. nn_ice_lim_dta(ib_bdy) .eq. 1 ) THEN 417 510 nb_bdy_fld(ib_bdy) = nb_bdy_fld(ib_bdy) + 3 418 511 ENDIF … … 458 551 nblen => idx_bdy(ib_bdy)%nblen 459 552 nblenrim => idx_bdy(ib_bdy)%nblenrim 553 dta => dta_bdy(ib_bdy) 554 dta%nread(2) = 0 460 555 461 556 ! Only read in necessary fields for this set. 462 557 ! Important that barotropic variables come first. 463 IF( nn_dyn2d(ib_bdy) .gt. 0 .and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) THEN 464 465 IF( nn_dyn2d(ib_bdy) .ne. jp_frs .and. nn_tra(ib_bdy) .ne. 4 ) THEN ! runoff condition : no ssh reading 558 IF( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) THEN 559 560 IF( dta%ll_ssh ) THEN 561 if(lwp) write(numout,*) '++++++ reading in ssh field' 466 562 jfld = jfld + 1 467 563 blf_i(jfld) = bn_ssh … … 470 566 ilen1(jfld) = nblen(igrid(jfld)) 471 567 ilen3(jfld) = 1 472 ENDIF 473 474 IF( .not. ln_full_vel_array(ib_bdy) ) THEN 568 dta%nread(2) = dta%nread(2) + 1 569 ENDIF 570 571 IF( dta%ll_u2d .and. .not. ln_full_vel_array(ib_bdy) ) THEN 572 if(lwp) write(numout,*) '++++++ reading in u2d field' 475 573 jfld = jfld + 1 476 574 blf_i(jfld) = bn_u2d … … 479 577 ilen1(jfld) = nblen(igrid(jfld)) 480 578 ilen3(jfld) = 1 481 579 dta%nread(2) = dta%nread(2) + 1 580 ENDIF 581 582 IF( dta%ll_v2d .and. .not. ln_full_vel_array(ib_bdy) ) THEN 583 if(lwp) write(numout,*) '++++++ reading in v2d field' 482 584 jfld = jfld + 1 483 585 blf_i(jfld) = bn_v2d … … 486 588 ilen1(jfld) = nblen(igrid(jfld)) 487 589 ilen3(jfld) = 1 488 ENDIF 489 490 ENDIF 491 492 ! baroclinic velocities 493 IF( ( nn_dyn3d(ib_bdy) .gt. 0 .and. nn_dyn3d_dta(ib_bdy) .eq. 1 ) .or. & 494 & ( ln_full_vel_array(ib_bdy) .and. nn_dyn2d(ib_bdy) .gt. 0 .and. & 495 & ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) ) THEN 496 497 jfld = jfld + 1 498 blf_i(jfld) = bn_u3d 499 ibdy(jfld) = ib_bdy 500 igrid(jfld) = 2 501 ilen1(jfld) = nblen(igrid(jfld)) 502 ilen3(jfld) = jpk 503 504 jfld = jfld + 1 505 blf_i(jfld) = bn_v3d 506 ibdy(jfld) = ib_bdy 507 igrid(jfld) = 3 508 ilen1(jfld) = nblen(igrid(jfld)) 509 ilen3(jfld) = jpk 590 dta%nread(2) = dta%nread(2) + 1 591 ENDIF 592 593 ENDIF 594 595 ! read 3D velocities if baroclinic velocities require OR if 596 ! barotropic velocities required and ln_full_vel set to .true. 597 IF( nn_dyn3d_dta(ib_bdy) .eq. 1 .or. & 598 & ( ln_full_vel_array(ib_bdy) .and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) ) THEN 599 600 IF( dta%ll_u3d .or. ( ln_full_vel_array(ib_bdy) .and. dta%ll_u2d ) ) THEN 601 if(lwp) write(numout,*) '++++++ reading in u3d field' 602 jfld = jfld + 1 603 blf_i(jfld) = bn_u3d 604 ibdy(jfld) = ib_bdy 605 igrid(jfld) = 2 606 ilen1(jfld) = nblen(igrid(jfld)) 607 ilen3(jfld) = jpk 608 IF( ln_full_vel_array(ib_bdy) .and. dta%ll_u2d ) dta%nread(2) = dta%nread(2) + 1 609 ENDIF 610 611 IF( dta%ll_v3d .or. ( ln_full_vel_array(ib_bdy) .and. dta%ll_v2d ) ) THEN 612 if(lwp) write(numout,*) '++++++ reading in v3d field' 613 jfld = jfld + 1 614 blf_i(jfld) = bn_v3d 615 ibdy(jfld) = ib_bdy 616 igrid(jfld) = 3 617 ilen1(jfld) = nblen(igrid(jfld)) 618 ilen3(jfld) = jpk 619 IF( ln_full_vel_array(ib_bdy) .and. dta%ll_v2d ) dta%nread(2) = dta%nread(2) + 1 620 ENDIF 510 621 511 622 ENDIF 512 623 513 624 ! temperature and salinity 514 IF( nn_tra(ib_bdy) .gt. 0 .and. nn_tra_dta(ib_bdy) .eq. 1 ) THEN 515 516 jfld = jfld + 1 517 blf_i(jfld) = bn_tem 518 ibdy(jfld) = ib_bdy 519 igrid(jfld) = 1 520 ilen1(jfld) = nblen(igrid(jfld)) 521 ilen3(jfld) = jpk 522 523 jfld = jfld + 1 524 blf_i(jfld) = bn_sal 525 ibdy(jfld) = ib_bdy 526 igrid(jfld) = 1 527 ilen1(jfld) = nblen(igrid(jfld)) 528 ilen3(jfld) = jpk 625 IF( nn_tra_dta(ib_bdy) .eq. 1 ) THEN 626 627 IF( dta%ll_tem ) THEN 628 if(lwp) write(numout,*) '++++++ reading in tem field' 629 jfld = jfld + 1 630 blf_i(jfld) = bn_tem 631 ibdy(jfld) = ib_bdy 632 igrid(jfld) = 1 633 ilen1(jfld) = nblen(igrid(jfld)) 634 ilen3(jfld) = jpk 635 ENDIF 636 637 IF( dta%ll_sal ) THEN 638 if(lwp) write(numout,*) '++++++ reading in sal field' 639 jfld = jfld + 1 640 blf_i(jfld) = bn_sal 641 ibdy(jfld) = ib_bdy 642 igrid(jfld) = 1 643 ilen1(jfld) = nblen(igrid(jfld)) 644 ilen3(jfld) = jpk 645 ENDIF 529 646 530 647 ENDIF … … 532 649 #if defined key_lim2 533 650 ! sea ice 534 IF( nn_ice_lim2(ib_bdy) .gt. 0 .and. nn_ice_lim2_dta(ib_bdy) .eq. 1 ) THEN 535 536 jfld = jfld + 1 537 blf_i(jfld) = bn_frld 538 ibdy(jfld) = ib_bdy 539 igrid(jfld) = 1 540 ilen1(jfld) = nblen(igrid(jfld)) 541 ilen3(jfld) = 1 542 543 jfld = jfld + 1 544 blf_i(jfld) = bn_hicif 545 ibdy(jfld) = ib_bdy 546 igrid(jfld) = 1 547 ilen1(jfld) = nblen(igrid(jfld)) 548 ilen3(jfld) = 1 549 550 jfld = jfld + 1 551 blf_i(jfld) = bn_hsnif 552 ibdy(jfld) = ib_bdy 553 igrid(jfld) = 1 554 ilen1(jfld) = nblen(igrid(jfld)) 555 ilen3(jfld) = 1 556 557 ENDIF 651 IF( nn_ice_lim2_dta(ib_bdy) .eq. 1 ) THEN 652 653 IF( dta%ll_frld ) THEN 654 jfld = jfld + 1 655 blf_i(jfld) = bn_frld 656 ibdy(jfld) = ib_bdy 657 igrid(jfld) = 1 658 ilen1(jfld) = nblen(igrid(jfld)) 659 ilen3(jfld) = 1 660 ENDIF 661 662 IF( dta%ll_hicif ) THEN 663 jfld = jfld + 1 664 blf_i(jfld) = bn_hicif 665 ibdy(jfld) = ib_bdy 666 igrid(jfld) = 1 667 ilen1(jfld) = nblen(igrid(jfld)) 668 ilen3(jfld) = 1 669 ENDIF 670 671 IF( dta%ll_hsnif ) THEN 672 jfld = jfld + 1 673 blf_i(jfld) = bn_hsnif 674 ibdy(jfld) = ib_bdy 675 igrid(jfld) = 1 676 ilen1(jfld) = nblen(igrid(jfld)) 677 ilen3(jfld) = 1 678 ENDIF 679 680 ENDIF 681 #elif defined key_lim3 682 ! sea ice 683 IF( nn_ice_lim_dta(ib_bdy) .eq. 1 ) THEN 684 685 ! Test for types of ice input (lim2 or lim3) 686 CALL iom_open ( bn_a_i%clname, inum ) 687 id1 = iom_varid ( inum, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 688 CALL iom_close ( inum ) 689 !CALL fld_clopn ( bn_a_i, nyear, nmonth, nday, ldstop=.TRUE. ) 690 !CALL iom_open ( bn_a_i %clname, inum ) 691 !id1 = iom_varid ( bn_a_i%num, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 692 IF ( zndims == 4 ) THEN 693 ll_bdylim3 = .TRUE. ! lim3 input 694 ELSE 695 ll_bdylim3 = .FALSE. ! lim2 input 696 ENDIF 697 ! End test 698 699 IF( dta%ll_a_i ) THEN 700 jfld = jfld + 1 701 blf_i(jfld) = bn_a_i 702 ibdy(jfld) = ib_bdy 703 igrid(jfld) = 1 704 ilen1(jfld) = nblen(igrid(jfld)) 705 IF ( ll_bdylim3 ) THEN ; ilen3(jfld)=jpl ; ELSE ; ilen3(jfld)=1 ; ENDIF 706 ENDIF 707 708 IF( dta%ll_ht_i ) THEN 709 jfld = jfld + 1 710 blf_i(jfld) = bn_ht_i 711 ibdy(jfld) = ib_bdy 712 igrid(jfld) = 1 713 ilen1(jfld) = nblen(igrid(jfld)) 714 IF ( ll_bdylim3 ) THEN ; ilen3(jfld)=jpl ; ELSE ; ilen3(jfld)=1 ; ENDIF 715 ENDIF 716 717 IF( dta%ll_ht_s ) THEN 718 jfld = jfld + 1 719 blf_i(jfld) = bn_ht_s 720 ibdy(jfld) = ib_bdy 721 igrid(jfld) = 1 722 ilen1(jfld) = nblen(igrid(jfld)) 723 IF ( ll_bdylim3 ) THEN ; ilen3(jfld)=jpl ; ELSE ; ilen3(jfld)=1 ; ENDIF 724 ENDIF 725 558 726 #endif 559 727 ! Recalculate field counts … … 568 736 ENDIF 569 737 738 dta%nread(1) = nb_bdy_fld(ib_bdy) 739 570 740 ENDIF ! nn_dta .eq. 1 571 741 ENDDO ! ib_bdy … … 596 766 597 767 nblen => idx_bdy(ib_bdy)%nblen 598 nblenrim => idx_bdy(ib_bdy)%nblenrim 599 600 IF (nn_dyn2d(ib_bdy) .gt. 0) THEN 601 IF( nn_dyn2d_dta(ib_bdy) .eq. 0 .or. nn_dyn2d_dta(ib_bdy) .eq. 2 .or. ln_full_vel_array(ib_bdy) ) THEN 602 ilen0(1:3) = nblen(1:3) 603 ALLOCATE( dta_bdy(ib_bdy)%u2d(ilen0(2)) ) 604 ALLOCATE( dta_bdy(ib_bdy)%v2d(ilen0(3)) ) 605 IF ( nn_dyn2d(ib_bdy) .ne. jp_frs .and. (nn_dyn2d_dta(ib_bdy).eq.1.or.nn_dyn2d_dta(ib_bdy).eq.3) ) THEN 606 jfld = jfld + 1 607 dta_bdy(ib_bdy)%ssh => bf(jfld)%fnow(:,1,1) 768 dta => dta_bdy(ib_bdy) 769 770 if(lwp) then 771 write(numout,*) '++++++ dta%ll_ssh = ',dta%ll_ssh 772 write(numout,*) '++++++ dta%ll_u2d = ',dta%ll_u2d 773 write(numout,*) '++++++ dta%ll_v2d = ',dta%ll_v2d 774 write(numout,*) '++++++ dta%ll_u3d = ',dta%ll_u3d 775 write(numout,*) '++++++ dta%ll_v3d = ',dta%ll_v3d 776 write(numout,*) '++++++ dta%ll_tem = ',dta%ll_tem 777 write(numout,*) '++++++ dta%ll_sal = ',dta%ll_sal 778 endif 779 780 IF ( nn_dyn2d_dta(ib_bdy) .eq. 0 .or. nn_dyn2d_dta(ib_bdy) .eq. 2 ) THEN 781 if(lwp) write(numout,*) '++++++ dta%ssh/u2d/u3d allocated space' 782 IF( dta%ll_ssh ) ALLOCATE( dta%ssh(nblen(1)) ) 783 IF( dta%ll_u2d ) ALLOCATE( dta%u2d(nblen(2)) ) 784 IF( dta%ll_v2d ) ALLOCATE( dta%v2d(nblen(3)) ) 785 ENDIF 786 IF ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) THEN 787 IF( dta%ll_ssh ) THEN 788 if(lwp) write(numout,*) '++++++ dta%ssh pointing to fnow' 789 jfld = jfld + 1 790 dta%ssh => bf(jfld)%fnow(:,1,1) 791 ENDIF 792 IF ( dta%ll_u2d ) THEN 793 IF ( ln_full_vel_array(ib_bdy) ) THEN 794 if(lwp) write(numout,*) '++++++ dta%u2d allocated space' 795 ALLOCATE( dta%u2d(nblen(2)) ) 608 796 ELSE 609 ALLOCATE( dta_bdy(ib_bdy)%ssh(nblen(1)) ) 610 ENDIF 611 ELSE 612 IF( nn_dyn2d(ib_bdy) .ne. jp_frs ) THEN 613 jfld = jfld + 1 614 dta_bdy(ib_bdy)%ssh => bf(jfld)%fnow(:,1,1) 615 ENDIF 797 if(lwp) write(numout,*) '++++++ dta%u2d pointing to fnow' 798 jfld = jfld + 1 799 dta%u2d => bf(jfld)%fnow(:,1,1) 800 ENDIF 801 ENDIF 802 IF ( dta%ll_v2d ) THEN 803 IF ( ln_full_vel_array(ib_bdy) ) THEN 804 if(lwp) write(numout,*) '++++++ dta%v2d allocated space' 805 ALLOCATE( dta%v2d(nblen(3)) ) 806 ELSE 807 if(lwp) write(numout,*) '++++++ dta%v2d pointing to fnow' 808 jfld = jfld + 1 809 dta%v2d => bf(jfld)%fnow(:,1,1) 810 ENDIF 811 ENDIF 812 ENDIF 813 814 IF ( nn_dyn3d_dta(ib_bdy) .eq. 0 ) THEN 815 if(lwp) write(numout,*) '++++++ dta%u3d/v3d allocated space' 816 IF( dta%ll_u3d ) ALLOCATE( dta_bdy(ib_bdy)%u3d(nblen(2),jpk) ) 817 IF( dta%ll_v3d ) ALLOCATE( dta_bdy(ib_bdy)%v3d(nblen(3),jpk) ) 818 ENDIF 819 IF ( nn_dyn3d_dta(ib_bdy) .eq. 1 .or. & 820 & ( ln_full_vel_array(ib_bdy) .and. ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) ) THEN 821 IF ( dta%ll_u3d .or. ( ln_full_vel_array(ib_bdy) .and. dta%ll_u2d ) ) THEN 822 if(lwp) write(numout,*) '++++++ dta%u3d pointing to fnow' 616 823 jfld = jfld + 1 617 dta_bdy(ib_bdy)%u2d => bf(jfld)%fnow(:,1,1) 824 dta_bdy(ib_bdy)%u3d => bf(jfld)%fnow(:,1,:) 825 ENDIF 826 IF ( dta%ll_v3d .or. ( ln_full_vel_array(ib_bdy) .and. dta%ll_v2d ) ) THEN 827 if(lwp) write(numout,*) '++++++ dta%v3d pointing to fnow' 618 828 jfld = jfld + 1 619 dta_bdy(ib_bdy)%v2d => bf(jfld)%fnow(:,1,1) 620 ENDIF 621 ENDIF 622 623 IF ( nn_dyn3d(ib_bdy) .gt. 0 .and. nn_dyn3d_dta(ib_bdy) .eq. 0 ) THEN 624 ilen0(1:3) = nblen(1:3) 625 ALLOCATE( dta_bdy(ib_bdy)%u3d(ilen0(2),jpk) ) 626 ALLOCATE( dta_bdy(ib_bdy)%v3d(ilen0(3),jpk) ) 627 ENDIF 628 IF ( ( nn_dyn3d(ib_bdy) .gt. 0 .and. nn_dyn3d_dta(ib_bdy) .eq. 1 ).or. & 629 & ( ln_full_vel_array(ib_bdy) .and. nn_dyn2d(ib_bdy) .gt. 0 .and. & 630 & ( nn_dyn2d_dta(ib_bdy) .eq. 1 .or. nn_dyn2d_dta(ib_bdy) .eq. 3 ) ) ) THEN 631 jfld = jfld + 1 632 dta_bdy(ib_bdy)%u3d => bf(jfld)%fnow(:,1,:) 633 jfld = jfld + 1 634 dta_bdy(ib_bdy)%v3d => bf(jfld)%fnow(:,1,:) 635 ENDIF 636 637 IF (nn_tra(ib_bdy) .gt. 0) THEN 638 IF( nn_tra_dta(ib_bdy) .eq. 0 ) THEN 639 ilen0(1:3) = nblen(1:3) 640 ALLOCATE( dta_bdy(ib_bdy)%tem(ilen0(1),jpk) ) 641 ALLOCATE( dta_bdy(ib_bdy)%sal(ilen0(1),jpk) ) 642 ELSE 829 dta_bdy(ib_bdy)%v3d => bf(jfld)%fnow(:,1,:) 830 ENDIF 831 ENDIF 832 833 IF( nn_tra_dta(ib_bdy) .eq. 0 ) THEN 834 if(lwp) write(numout,*) '++++++ dta%tem/sal allocated space' 835 IF( dta%ll_tem ) ALLOCATE( dta_bdy(ib_bdy)%tem(nblen(1),jpk) ) 836 IF( dta%ll_sal ) ALLOCATE( dta_bdy(ib_bdy)%sal(nblen(1),jpk) ) 837 ELSE 838 IF( dta%ll_tem ) THEN 839 if(lwp) write(numout,*) '++++++ dta%tem pointing to fnow' 643 840 jfld = jfld + 1 644 841 dta_bdy(ib_bdy)%tem => bf(jfld)%fnow(:,1,:) 842 ENDIF 843 IF( dta%ll_sal ) THEN 844 if(lwp) write(numout,*) '++++++ dta%sal pointing to fnow' 645 845 jfld = jfld + 1 646 846 dta_bdy(ib_bdy)%sal => bf(jfld)%fnow(:,1,:) … … 649 849 650 850 #if defined key_lim2 651 IF (nn_ice_lim 2(ib_bdy) .gt. 0) THEN851 IF (nn_ice_lim(ib_bdy) .gt. 0) THEN 652 852 IF( nn_ice_lim2_dta(ib_bdy) .eq. 0 ) THEN 653 ilen0(1:3) = nblen(1:3) 654 ALLOCATE( dta_bdy(ib_bdy)%frld(ilen0(1)) ) 655 ALLOCATE( dta_bdy(ib_bdy)%hicif(ilen0(1)) ) 656 ALLOCATE( dta_bdy(ib_bdy)%hsnif(ilen0(1)) ) 853 ALLOCATE( dta_bdy(ib_bdy)%frld(nblen(1)) ) 854 ALLOCATE( dta_bdy(ib_bdy)%hicif(nblen(1)) ) 855 ALLOCATE( dta_bdy(ib_bdy)%hsnif(nblen(1)) ) 657 856 ELSE 658 857 jfld = jfld + 1 … … 662 861 jfld = jfld + 1 663 862 dta_bdy(ib_bdy)%hsnif => bf(jfld)%fnow(:,1,1) 863 ENDIF 864 ENDIF 865 #elif defined key_lim3 866 IF (nn_ice_lim(ib_bdy) .gt. 0) THEN 867 IF( nn_ice_lim_dta(ib_bdy) .eq. 0 ) THEN 868 ALLOCATE( dta_bdy(ib_bdy)%a_i (nblen(1),jpl) ) 869 ALLOCATE( dta_bdy(ib_bdy)%ht_i(nblen(1),jpl) ) 870 ALLOCATE( dta_bdy(ib_bdy)%ht_s(nblen(1),jpl) ) 871 ELSE 872 IF ( ll_bdylim3 ) THEN ! case input is lim3 type 873 jfld = jfld + 1 874 dta_bdy(ib_bdy)%a_i => bf(jfld)%fnow(:,1,:) 875 jfld = jfld + 1 876 dta_bdy(ib_bdy)%ht_i => bf(jfld)%fnow(:,1,:) 877 jfld = jfld + 1 878 dta_bdy(ib_bdy)%ht_s => bf(jfld)%fnow(:,1,:) 879 ELSE ! case input is lim2 type 880 jfld_ai = jfld + 1 881 jfld_hti = jfld + 2 882 jfld_hts = jfld + 3 883 jfld = jfld + 3 884 ALLOCATE( dta_bdy(ib_bdy)%a_i (nblen(1),jpl) ) 885 ALLOCATE( dta_bdy(ib_bdy)%ht_i(nblen(1),jpl) ) 886 ALLOCATE( dta_bdy(ib_bdy)%ht_s(nblen(1),jpl) ) 887 dta_bdy(ib_bdy)%a_i (:,:) = 0.0 888 dta_bdy(ib_bdy)%ht_i(:,:) = 0.0 889 dta_bdy(ib_bdy)%ht_s(:,:) = 0.0 890 ENDIF 891 664 892 ENDIF 665 893 ENDIF -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn.F90
r4153 r4292 30 30 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 31 31 USE in_out_manager ! 32 USE domvvl ! variable volume32 USE domvvl 33 33 34 34 IMPLICIT NONE … … 57 57 LOGICAL, INTENT( in ), OPTIONAL :: dyn3d_only ! T => only update baroclinic velocities 58 58 !! 59 INTEGER :: jk,ii,ij,ib,igrd ! Loop counter 60 LOGICAL :: ll_dyn2d, ll_dyn3d 61 !! 59 INTEGER :: jk,ii,ij,ib_bdy,ib,igrd ! Loop counter 60 LOGICAL :: ll_dyn2d, ll_dyn3d, ll_orlanski 61 !! 62 REAL(wp), POINTER, DIMENSION(:,:) :: phur1, phvr1 ! inverse depth at u and v points 62 63 63 64 IF( nn_timing == 1 ) CALL timing_start('bdy_dyn') … … 70 71 ENDIF 71 72 73 ll_orlanski = .false. 74 DO ib_bdy = 1, nb_bdy 75 IF ( cn_dyn2d(ib_bdy) == 'orlanski' .or. cn_dyn2d(ib_bdy) == 'orlanski_npo' & 76 & .or. cn_dyn3d(ib_bdy) == 'orlanski' .or. cn_dyn3d(ib_bdy) == 'orlanski_npo') ll_orlanski = .true. 77 ENDDO 78 72 79 !------------------------------------------------------- 73 80 ! Set pointers … … 77 84 phur => hur 78 85 phvr => hvr 79 CALL wrk_alloc(jpi,jpj,pu2d,pv2d) 86 CALL wrk_alloc(jpi,jpj,pua2d,pva2d) 87 IF ( ll_orlanski ) CALL wrk_alloc(jpi,jpj,pub2d,pvb2d,phur1,phvr1) 80 88 81 89 !------------------------------------------------------- … … 83 91 !------------------------------------------------------- 84 92 85 pu2d(:,:) = 0.e0 86 pv2d(:,:) = 0.e0 93 ! "After" velocities: 94 95 pua2d(:,:) = 0.e0 96 pva2d(:,:) = 0.e0 97 87 98 IF (lk_vvl) THEN 88 DO jk = 1, jpkm1 !! Vertically integrated momentum trends 89 pu2d(:,:) = pu2d(:,:) + fse3u_a(:,:,jk) * umask(:,:,jk) * ua(:,:,jk) 90 pv2d(:,:) = pv2d(:,:) + fse3v_a(:,:,jk) * vmask(:,:,jk) * va(:,:,jk) 91 END DO 92 pu2d(:,:) = pu2d(:,:) / ( hu_0(:,:) + sshu_a(:,:) + 1._wp - umask(:,:,1) ) 93 pv2d(:,:) = pv2d(:,:) / ( hv_0(:,:) + sshv_a(:,:) + 1._wp - vmask(:,:,1) ) 99 phur1(:,:) = 0. 100 phvr1(:,:) = 0. 101 DO jk = 1, jpkm1 102 phur1(:,:) = phur1(:,:) + fse3u_a(:,:,jk) * umask(:,:,jk) 103 phvr1(:,:) = phvr1(:,:) + fse3v_a(:,:,jk) * vmask(:,:,jk) 104 pua2d(:,:) = pua2d(:,:) + fse3u_a(:,:,jk) * umask(:,:,jk) * ua(:,:,jk) 105 pva2d(:,:) = pva2d(:,:) + fse3v_a(:,:,jk) * vmask(:,:,jk) * va(:,:,jk) 106 END DO 107 phur1(:,:) = umask(:,:,1) / ( phur1(:,:) + 1. - umask(:,:,1) ) 108 phvr1(:,:) = vmask(:,:,1) / ( phvr1(:,:) + 1. - vmask(:,:,1) ) 109 pua2d(:,:) = pua2d(:,:) * phur1(:,:) 110 pva2d(:,:) = pva2d(:,:) * phvr1(:,:) 94 111 ELSE 95 DO jk = 1, jpkm1 !! Vertically integrated momentum trends96 pu 2d(:,:) = pu2d(:,:) + fse3u(:,:,jk) * umask(:,:,jk) * ua(:,:,jk)97 pv 2d(:,:) = pv2d(:,:) + fse3v(:,:,jk) * vmask(:,:,jk) * va(:,:,jk)98 END DO 99 pu 2d(:,:) = pu2d(:,:) * phur(:,:)100 pv 2d(:,:) = pv2d(:,:) * phvr(:,:)112 DO jk = 1, jpkm1 113 pua2d(:,:) = pua2d(:,:) + fse3u(:,:,jk) * umask(:,:,jk) * ua(:,:,jk) 114 pva2d(:,:) = pva2d(:,:) + fse3v(:,:,jk) * vmask(:,:,jk) * va(:,:,jk) 115 END DO 116 pua2d(:,:) = pua2d(:,:) * phur(:,:) 117 pva2d(:,:) = pva2d(:,:) * phvr(:,:) 101 118 ENDIF 119 102 120 DO jk = 1 , jpkm1 103 ua(:,:,jk) = ua(:,:,jk) - pu 2d(:,:) * umask(:,:,jk)104 va(:,:,jk) = va(:,:,jk) - pv 2d(:,:) * vmask(:,:,jk)121 ua(:,:,jk) = ua(:,:,jk) - pua2d(:,:) 122 va(:,:,jk) = va(:,:,jk) - pva2d(:,:) 105 123 END DO 124 125 ! "Before" velocities (required for Orlanski condition): 126 127 IF ( ll_orlanski ) THEN 128 pub2d(:,:) = 0.e0 129 pvb2d(:,:) = 0.e0 130 131 IF (lk_vvl) THEN 132 phur1(:,:) = 0. 133 phvr1(:,:) = 0. 134 DO jk = 1, jpkm1 !! Vertically integrated momentum trends 135 phur1(:,:) = phur1(:,:) + fse3u_b(:,:,jk) * umask(:,:,jk) 136 phvr1(:,:) = phvr1(:,:) + fse3v_b(:,:,jk) * vmask(:,:,jk) 137 pub2d(:,:) = pub2d(:,:) + fse3u_b(:,:,jk) * umask(:,:,jk) * ub(:,:,jk) 138 pvb2d(:,:) = pvb2d(:,:) + fse3v_b(:,:,jk) * vmask(:,:,jk) * vb(:,:,jk) 139 END DO 140 phur1(:,:) = umask(:,:,1) / ( phur1(:,:) + 1. - umask(:,:,1) ) 141 phvr1(:,:) = vmask(:,:,1) / ( phvr1(:,:) + 1. - vmask(:,:,1) ) 142 pub2d(:,:) = pub2d(:,:) * phur1(:,:) 143 pvb2d(:,:) = pvb2d(:,:) * phvr1(:,:) 144 ELSE 145 DO jk = 1, jpkm1 !! Vertically integrated momentum trends 146 pub2d(:,:) = pub2d(:,:) + fse3u(:,:,jk) * umask(:,:,jk) * ub(:,:,jk) 147 pvb2d(:,:) = pvb2d(:,:) + fse3v(:,:,jk) * vmask(:,:,jk) * vb(:,:,jk) 148 END DO 149 pub2d(:,:) = pub2d(:,:) * phur(:,:) 150 pvb2d(:,:) = pvb2d(:,:) * phvr(:,:) 151 ENDIF 152 153 DO jk = 1 , jpkm1 154 ub(:,:,jk) = ub(:,:,jk) - pub2d(:,:) 155 vb(:,:,jk) = vb(:,:,jk) - pvb2d(:,:) 156 END DO 157 END IF 106 158 107 159 !------------------------------------------------------- … … 119 171 120 172 DO jk = 1 , jpkm1 121 ua(:,:,jk) = ( ua(:,:,jk) + pu 2d(:,:) ) * umask(:,:,jk)122 va(:,:,jk) = ( va(:,:,jk) + pv 2d(:,:) ) * vmask(:,:,jk)173 ua(:,:,jk) = ( ua(:,:,jk) + pua2d(:,:) ) * umask(:,:,jk) 174 va(:,:,jk) = ( va(:,:,jk) + pva2d(:,:) ) * vmask(:,:,jk) 123 175 END DO 124 176 125 CALL wrk_dealloc(jpi,jpj,pu2d,pv2d) 177 IF ( ll_orlanski ) THEN 178 DO jk = 1 , jpkm1 179 ub(:,:,jk) = ( ub(:,:,jk) + pub2d(:,:) ) * umask(:,:,jk) 180 vb(:,:,jk) = ( vb(:,:,jk) + pvb2d(:,:) ) * vmask(:,:,jk) 181 END DO 182 END IF 183 184 CALL wrk_dealloc(jpi,jpj,pua2d,pva2d) 185 IF ( ll_orlanski ) CALL wrk_dealloc(jpi,jpj,pub2d,pvb2d) 126 186 127 187 IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn') -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90
r3680 r4292 6 6 !! History : 3.4 ! 2011 (D. Storkey) new module as part of BDY rewrite 7 7 !! 3.5 ! 2012 (S. Mocavero, I. Epicoco) Optimization of BDY communications 8 !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes 8 9 !!---------------------------------------------------------------------- 9 10 #if defined key_bdy … … 11 12 !! 'key_bdy' : Unstructured Open Boundary Condition 12 13 !!---------------------------------------------------------------------- 13 !! bdy_dyn2d : Apply open boundary conditions to barotropic variables. 14 !! bdy_dyn2d_fla : Apply Flather condition 14 !! bdy_dyn2d : Apply open boundary conditions to barotropic variables. 15 !! bdy_dyn2d_frs : Apply Flow Relaxation Scheme 16 !! bdy_dyn2d_fla : Apply Flather condition 17 !! bdy_dyn2d_orlanski : Orlanski Radiation 18 !! bdy_ssh : Duplicate sea level across open boundaries 15 19 !!---------------------------------------------------------------------- 16 20 USE timing ! Timing … … 18 22 USE dom_oce ! ocean space and time domain 19 23 USE bdy_oce ! ocean open boundary conditions 24 USE bdylib ! BDY library routines 20 25 USE dynspg_oce ! for barotropic variables 21 26 USE phycst ! physical constants … … 26 31 PRIVATE 27 32 28 PUBLIC bdy_dyn2d ! routine called in dynspg_ts and bdy_dyn 33 PUBLIC bdy_dyn2d ! routine called in dynspg_ts and bdy_dyn 34 PUBLIC bdy_ssh ! routine called in dynspg_ts or sshwzv 29 35 30 36 !!---------------------------------------------------------------------- … … 48 54 DO ib_bdy=1, nb_bdy 49 55 50 SELECT CASE( nn_dyn2d(ib_bdy) )51 CASE( jp_none)56 SELECT CASE( cn_dyn2d(ib_bdy) ) 57 CASE('none') 52 58 CYCLE 53 CASE( jp_frs)59 CASE('frs') 54 60 CALL bdy_dyn2d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 55 CASE( jp_flather)61 CASE('flather') 56 62 CALL bdy_dyn2d_fla( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy ) 63 CASE('orlanski') 64 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.false. ) 65 CASE('orlanski_npo') 66 CALL bdy_dyn2d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.true. ) 57 67 CASE DEFAULT 58 68 CALL ctl_stop( 'bdy_dyn2d : unrecognised option for open boundaries for barotropic variables' ) … … 89 99 ij = idx%nbj(jb,igrd) 90 100 zwgt = idx%nbw(jb,igrd) 91 pu 2d(ii,ij) = ( pu2d(ii,ij) + zwgt * ( dta%u2d(jb) - pu2d(ii,ij) ) ) * umask(ii,ij,1)101 pua2d(ii,ij) = ( pua2d(ii,ij) + zwgt * ( dta%u2d(jb) - pua2d(ii,ij) ) ) * umask(ii,ij,1) 92 102 END DO 93 103 ! … … 97 107 ij = idx%nbj(jb,igrd) 98 108 zwgt = idx%nbw(jb,igrd) 99 pv 2d(ii,ij) = ( pv2d(ii,ij) + zwgt * ( dta%v2d(jb) - pv2d(ii,ij) ) ) * vmask(ii,ij,1)109 pva2d(ii,ij) = ( pva2d(ii,ij) + zwgt * ( dta%v2d(jb) - pva2d(ii,ij) ) ) * vmask(ii,ij,1) 100 110 END DO 101 CALL lbc_bdy_lnk( pu 2d, 'U', -1., ib_bdy )102 CALL lbc_bdy_lnk( pv 2d, 'V', -1., ib_bdy) ! Boundary points should be updated111 CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy ) 112 CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy) ! Boundary points should be updated 103 113 ! 104 114 IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn2d_frs') … … 133 143 INTEGER :: jb, igrd ! dummy loop indices 134 144 INTEGER :: ii, ij, iim1, iip1, ijm1, ijp1 ! 2D addresses 145 REAL(wp), POINTER :: flagu, flagv ! short cuts 135 146 REAL(wp) :: zcorr ! Flather correction 136 147 REAL(wp) :: zforc ! temporary scalar 148 REAL(wp) :: zflag, z1_2 ! " " 137 149 !!---------------------------------------------------------------------- 138 150 139 151 IF( nn_timing == 1 ) CALL timing_start('bdy_dyn2d_fla') 152 153 z1_2 = 0.5_wp 140 154 141 155 ! ---------------------------------! … … 160 174 ii = idx%nbi(jb,igrd) 161 175 ij = idx%nbj(jb,igrd) 162 iim1 = ii + MAX( 0, INT( idx%flagu(jb) ) ) ! T pts i-indice inside the boundary 163 iip1 = ii - MIN( 0, INT( idx%flagu(jb) ) ) ! T pts i-indice outside the boundary 176 flagu => idx%flagu(jb,igrd) 177 iim1 = ii + MAX( 0, INT( flagu ) ) ! T pts i-indice inside the boundary 178 iip1 = ii - MIN( 0, INT( flagu ) ) ! T pts i-indice outside the boundary 164 179 ! 165 zcorr = - idx%flagu(jb) * SQRT( grav * phur(ii, ij) ) * ( pssh(iim1, ij) - spgu(iip1,ij) ) 166 zforc = dta%u2d(jb) 167 pu2d(ii,ij) = zforc + zcorr * umask(ii,ij,1) 180 zcorr = - flagu * SQRT( grav * phur(ii, ij) ) * ( pssh(iim1, ij) - spgu(iip1,ij) ) 181 182 ! jchanut tschanges: Set zflag to 0 below to revert to Flather scheme 183 ! Use characteristics method instead 184 zflag = ABS(flagu) 185 zforc = dta%u2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pua2d(iim1,ij) 186 pua2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * umask(ii,ij,1) 168 187 END DO 169 188 ! … … 173 192 ii = idx%nbi(jb,igrd) 174 193 ij = idx%nbj(jb,igrd) 175 ijm1 = ij + MAX( 0, INT( idx%flagv(jb) ) ) ! T pts j-indice inside the boundary 176 ijp1 = ij - MIN( 0, INT( idx%flagv(jb) ) ) ! T pts j-indice outside the boundary 194 flagv => idx%flagv(jb,igrd) 195 ijm1 = ij + MAX( 0, INT( flagv ) ) ! T pts j-indice inside the boundary 196 ijp1 = ij - MIN( 0, INT( flagv ) ) ! T pts j-indice outside the boundary 177 197 ! 178 zcorr = - idx%flagv(jb) * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii, ijm1) - spgu(ii,ijp1) ) 179 zforc = dta%v2d(jb) 180 pv2d(ii,ij) = zforc + zcorr * vmask(ii,ij,1) 181 END DO 182 CALL lbc_bdy_lnk( pu2d, 'U', -1., ib_bdy ) ! Boundary points should be updated 183 CALL lbc_bdy_lnk( pv2d, 'V', -1., ib_bdy ) ! 198 zcorr = - flagv * SQRT( grav * phvr(ii, ij) ) * ( pssh(ii, ijm1) - spgu(ii,ijp1) ) 199 200 ! jchanut tschanges: Set zflag to 0 below to revert to std Flather scheme 201 ! Use characteristics method instead 202 zflag = ABS(flagv) 203 zforc = dta%v2d(jb) * (1._wp - z1_2*zflag) + z1_2 * zflag * pva2d(ii,ijm1) 204 pva2d(ii,ij) = zforc + (1._wp - z1_2*zflag) * zcorr * vmask(ii,ij,1) 205 END DO 206 CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy ) ! Boundary points should be updated 207 CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy ) ! 184 208 ! 185 209 IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn2d_fla') 186 210 ! 187 211 END SUBROUTINE bdy_dyn2d_fla 212 213 214 SUBROUTINE bdy_dyn2d_orlanski( idx, dta, ib_bdy, ll_npo ) 215 !!---------------------------------------------------------------------- 216 !! *** SUBROUTINE bdy_dyn2d_orlanski *** 217 !! 218 !! - Apply Orlanski radiation condition adaptively: 219 !! - radiation plus weak nudging at outflow points 220 !! - no radiation and strong nudging at inflow points 221 !! 222 !! 223 !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) 224 !!---------------------------------------------------------------------- 225 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 226 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 227 INTEGER, INTENT(in) :: ib_bdy ! number of current open boundary set 228 LOGICAL, INTENT(in) :: ll_npo ! flag for NPO version 229 230 INTEGER :: ib, igrd ! dummy loop indices 231 INTEGER :: ii, ij, iibm1, ijbm1 ! indices 232 !!---------------------------------------------------------------------- 233 234 IF( nn_timing == 1 ) CALL timing_start('bdy_dyn2d_orlanski') 235 ! 236 igrd = 2 ! Orlanski bc on u-velocity; 237 ! 238 CALL bdy_orlanski_2d( idx, igrd, pub2d, pua2d, dta%u2d, ll_npo ) 239 240 igrd = 3 ! Orlanski bc on v-velocity 241 ! 242 CALL bdy_orlanski_2d( idx, igrd, pvb2d, pva2d, dta%v2d, ll_npo ) 243 ! 244 IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn2d_orlanski') 245 ! 246 CALL lbc_bdy_lnk( pua2d, 'U', -1., ib_bdy ) ! Boundary points should be updated 247 CALL lbc_bdy_lnk( pva2d, 'V', -1., ib_bdy ) ! 248 ! 249 IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn2d_orlanski') 250 ! 251 END SUBROUTINE bdy_dyn2d_orlanski 252 253 SUBROUTINE bdy_ssh( zssh ) 254 !!---------------------------------------------------------------------- 255 !! *** SUBROUTINE bdy_ssh *** 256 !! 257 !! ** Purpose : Duplicate sea level across open boundaries 258 !! 259 !!---------------------------------------------------------------------- 260 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zssh ! Sea level 261 !! 262 INTEGER :: ib_bdy, ib, igrd ! local integers 263 INTEGER :: ii, ij, zcoef, zcoef1, zcoef2, ip, jp ! " " 264 265 igrd = 1 ! Everything is at T-points here 266 267 DO ib_bdy = 1, nb_bdy 268 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 269 ii = idx_bdy(ib_bdy)%nbi(ib,igrd) 270 ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 271 ! Set gradient direction: 272 zcoef1 = bdytmask(ii-1,ij ) + bdytmask(ii+1,ij ) 273 zcoef2 = bdytmask(ii ,ij-1) + bdytmask(ii ,ij+1) 274 IF ( zcoef1+zcoef2 == 0 ) THEN 275 ! corner 276 ! zcoef = tmask(ii-1,ij,1) + tmask(ii+1,ij,1) + tmask(ii,ij-1,1) + tmask(ii,ij+1,1) 277 ! zssh(ii,ij) = zssh(ii-1,ij ) * tmask(ii-1,ij ,1) + & 278 ! & zssh(ii+1,ij ) * tmask(ii+1,ij ,1) + & 279 ! & zssh(ii ,ij-1) * tmask(ii ,ij-1,1) + & 280 ! & zssh(ii ,ij+1) * tmask(ii ,ij+1,1) 281 zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) + bdytmask(ii,ij-1) + bdytmask(ii,ij+1) 282 zssh(ii,ij) = zssh(ii-1,ij ) * bdytmask(ii-1,ij ) + & 283 & zssh(ii+1,ij ) * bdytmask(ii+1,ij ) + & 284 & zssh(ii ,ij-1) * bdytmask(ii ,ij-1) + & 285 & zssh(ii ,ij+1) * bdytmask(ii ,ij+1) 286 zssh(ii,ij) = ( zssh(ii,ij) / MAX( 1, zcoef) ) * tmask(ii,ij,1) 287 ELSE 288 ip = bdytmask(ii+1,ij ) - bdytmask(ii-1,ij ) 289 jp = bdytmask(ii ,ij+1) - bdytmask(ii ,ij-1) 290 zssh(ii,ij) = zssh(ii+ip,ij+jp) * tmask(ii+ip,ij+jp,1) 291 ENDIF 292 END DO 293 294 ! Boundary points should be updated 295 CALL lbc_bdy_lnk( zssh(:,:), 'T', 1., ib_bdy ) 296 END DO 297 298 END SUBROUTINE bdy_ssh 299 188 300 #else 189 301 !!---------------------------------------------------------------------- … … 192 304 CONTAINS 193 305 SUBROUTINE bdy_dyn2d( kt ) ! Empty routine 194 WRITE(*,*) 'bdy_dyn_frs: You should not have seen this print! error?', kt 306 INTEGER, intent(in) :: kt 307 WRITE(*,*) 'bdy_dyn2d: You should not have seen this print! error?', kt 195 308 END SUBROUTINE bdy_dyn2d 309 196 310 #endif 197 311 198 312 !!====================================================================== 199 313 END MODULE bdydyn2d 314 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn3d.F90
r3703 r4292 19 19 USE dom_oce ! ocean space and time domain 20 20 USE bdy_oce ! ocean open boundary conditions 21 USE bdylib ! for orlanski library routines 21 22 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 22 23 USE in_out_manager ! … … 52 53 DO ib_bdy=1, nb_bdy 53 54 54 !!$ IF ( using Orlanski radiation conditions ) THEN 55 !!$ CALL bdy_rad( kt, bdyidx(ib_bdy) ) 56 !!$ ENDIF 57 58 SELECT CASE( nn_dyn3d(ib_bdy) ) 59 CASE(jp_none) 55 SELECT CASE( cn_dyn3d(ib_bdy) ) 56 CASE('none') 60 57 CYCLE 61 CASE( jp_frs)58 CASE('frs') 62 59 CALL bdy_dyn3d_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 63 CASE( 2)60 CASE('specified') 64 61 CALL bdy_dyn3d_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 65 CASE( 3)62 CASE('zero') 66 63 CALL bdy_dyn3d_zro( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) 64 CASE('orlanski') 65 CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.false. ) 66 CASE('orlanski_npo') 67 CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, ll_npo=.true. ) 67 68 CASE DEFAULT 68 69 CALL ctl_stop( 'bdy_dyn3d : unrecognised option for open boundaries for baroclinic velocities' ) … … 109 110 END DO 110 111 END DO 111 CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy ) ; CALL lbc_bdy_lnk( va, 'V', -1.,ib_bdy ) ! Boundary points should be updated 112 CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 113 CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy ) 112 114 ! 113 115 IF( kt .eq. nit000 ) CLOSE( unit = 102 ) … … 204 206 END DO 205 207 END DO 206 CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy ) ; CALL lbc_bdy_lnk( va, 'V', -1.,ib_bdy ) ! Boundary points should be updated 208 CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 209 CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy ) 207 210 ! 208 211 IF( kt .eq. nit000 ) CLOSE( unit = 102 ) … … 211 214 212 215 END SUBROUTINE bdy_dyn3d_frs 216 217 SUBROUTINE bdy_dyn3d_orlanski( idx, dta, ib_bdy, ll_npo ) 218 !!---------------------------------------------------------------------- 219 !! *** SUBROUTINE bdy_dyn3d_orlanski *** 220 !! 221 !! - Apply Orlanski radiation to baroclinic velocities. 222 !! - Wrapper routine for bdy_orlanski_3d 223 !! 224 !! 225 !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) 226 !!---------------------------------------------------------------------- 227 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 228 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 229 INTEGER, INTENT(in) :: ib_bdy ! BDY set index 230 LOGICAL, INTENT(in) :: ll_npo ! switch for NPO version 231 232 INTEGER :: jb, igrd ! dummy loop indices 233 !!---------------------------------------------------------------------- 234 235 IF( nn_timing == 1 ) CALL timing_start('bdy_dyn3d_orlanski') 236 ! 237 !! Note that at this stage the ub and ua arrays contain the baroclinic velocities. 238 ! 239 igrd = 2 ! Orlanski bc on u-velocity; 240 ! 241 CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo ) 242 243 igrd = 3 ! Orlanski bc on v-velocity 244 ! 245 CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo ) 246 ! 247 CALL lbc_bdy_lnk( ua, 'U', -1., ib_bdy ) ! Boundary points should be updated 248 CALL lbc_bdy_lnk( va, 'V', -1., ib_bdy ) 249 ! 250 IF( nn_timing == 1 ) CALL timing_stop('bdy_dyn3d_orlanski') 251 ! 252 END SUBROUTINE bdy_dyn3d_orlanski 253 213 254 214 255 SUBROUTINE bdy_dyn3d_dmp( kt ) … … 225 266 REAL(wp) :: zwgt ! boundary weight 226 267 INTEGER :: ib_bdy ! loop index 268 REAL(wp), POINTER, DIMENSION(:,:) :: phur1, phvr1 ! inverse depth at u and v points 227 269 !!---------------------------------------------------------------------- 228 270 ! … … 232 274 ! Remove barotropic part from before velocity 233 275 !------------------------------------------------------- 234 CALL wrk_alloc(jpi,jpj,pu2d,pv2d) 235 236 pu2d(:,:) = 0.e0 237 pv2d(:,:) = 0.e0 238 276 CALL wrk_alloc(jpi,jpj,pub2d,pvb2d,phur1,phvr1) 277 278 pub2d(:,:) = 0.e0 279 pvb2d(:,:) = 0.e0 280 281 phur1(:,:) = 0. 282 phvr1(:,:) = 0. 239 283 DO jk = 1, jpkm1 240 284 #if defined key_vvl 241 pu2d(:,:) = pu2d(:,:) + fse3u_b(:,:,jk)* ub(:,:,jk) *umask(:,:,jk) 242 pv2d(:,:) = pv2d(:,:) + fse3v_b(:,:,jk)* vb(:,:,jk) *vmask(:,:,jk) 285 phur1(:,:) = phur1(:,:) + fse3u_a(:,:,jk) * umask(:,:,jk) 286 phvr1(:,:) = phvr1(:,:) + fse3v_a(:,:,jk) * vmask(:,:,jk) 287 pub2d(:,:) = pub2d(:,:) + fse3u_b(:,:,jk)* ub(:,:,jk) *umask(:,:,jk) 288 pvb2d(:,:) = pvb2d(:,:) + fse3v_b(:,:,jk)* vb(:,:,jk) *vmask(:,:,jk) 243 289 #else 244 pu 2d(:,:) = pu2d(:,:) + fse3u_0(:,:,jk) * ub(:,:,jk) * umask(:,:,jk)245 pv 2d(:,:) = pv2d(:,:) + fse3v_0(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk)290 pub2d(:,:) = pub2d(:,:) + fse3u_0(:,:,jk) * ub(:,:,jk) * umask(:,:,jk) 291 pvb2d(:,:) = pvb2d(:,:) + fse3v_0(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk) 246 292 #endif 247 293 END DO 248 294 249 295 IF( lk_vvl ) THEN 250 pu2d(:,:) = pu2d(:,:) * umask(:,:,1) / ( hu_0(:,:) + sshu_b(:,:) + 1._wp - umask(:,:,1) ) 251 pv2d(:,:) = pv2d(:,:) * vmask(:,:,1) / ( hv_0(:,:) + sshv_b(:,:) + 1._wp - vmask(:,:,1) ) 296 phur1(:,:) = umask(:,:,1) / ( phur1(:,:) + 1. - umask(:,:,1) ) 297 phvr1(:,:) = vmask(:,:,1) / ( phvr1(:,:) + 1. - vmask(:,:,1) ) 298 pub2d(:,:) = pub2d(:,:) * umask(:,:,1) * phur1(:,:) 299 pvb2d(:,:) = pvb2d(:,:) * vmask(:,:,1) * phvr1(:,:) 252 300 ELSE 253 pu 2d(:,:) = pv2d(:,:) * hur(:,:)254 pv 2d(:,:) = pu2d(:,:) * hvr(:,:)301 pub2d(:,:) = pvb2d(:,:) * hur(:,:) 302 pvb2d(:,:) = pub2d(:,:) * hvr(:,:) 255 303 ENDIF 256 304 257 305 DO ib_bdy=1, nb_bdy 258 IF ( ln_dyn3d_dmp(ib_bdy) .and.nn_dyn3d(ib_bdy).gt.0) THEN306 IF ( ln_dyn3d_dmp(ib_bdy) .and. cn_dyn3d(ib_bdy) /= 'none' ) THEN 259 307 igrd = 2 ! Relaxation of zonal velocity 260 308 DO jb = 1, idx_bdy(ib_bdy)%nblen(igrd) … … 264 312 DO jk = 1, jpkm1 265 313 ua(ii,ij,jk) = ( ua(ii,ij,jk) + zwgt * ( dta_bdy(ib_bdy)%u3d(jb,jk) - & 266 ub(ii,ij,jk) + pu 2d(ii,ij)) ) * umask(ii,ij,jk)314 ub(ii,ij,jk) + pub2d(ii,ij)) ) * umask(ii,ij,jk) 267 315 END DO 268 316 END DO … … 275 323 DO jk = 1, jpkm1 276 324 va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta_bdy(ib_bdy)%v3d(jb,jk) - & 277 vb(ii,ij,jk) + pv 2d(ii,ij)) ) * vmask(ii,ij,jk)325 vb(ii,ij,jk) + pvb2d(ii,ij)) ) * vmask(ii,ij,jk) 278 326 END DO 279 327 END DO … … 281 329 ENDDO 282 330 ! 283 CALL wrk_dealloc(jpi,jpj,pu 2d,pv2d)331 CALL wrk_dealloc(jpi,jpj,pub2d,pvb2d) 284 332 ! 285 333 CALL lbc_lnk( ua, 'U', -1. ) ; CALL lbc_lnk( va, 'V', -1. ) ! Boundary points should be updated -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90
r4148 r4292 21 21 !! bdy_init : Initialization of unstructured open boundaries 22 22 !!---------------------------------------------------------------------- 23 USE wrk_nemo ! Memory Allocation 23 24 USE timing ! Timing 24 25 USE oce ! ocean dynamics and tracers variables … … 79 80 INTEGER :: jpbdtau, jpbdtas ! - - 80 81 INTEGER :: ib_bdy1, ib_bdy2, ib1, ib2 ! - - 82 INTEGER :: i_offset, j_offset ! - - 81 83 INTEGER, POINTER :: nbi, nbj, nbr ! short cuts 82 REAL , POINTER :: flagu, flagv ! - - 84 REAL(wp), POINTER :: flagu, flagv ! - - 85 REAL(wp), POINTER, DIMENSION(:,:) :: pmask ! pointer to 2D mask fields 83 86 REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars 84 87 INTEGER, DIMENSION (2) :: kdimsz … … 90 93 INTEGER :: com_east_b, com_west_b, com_south_b, com_north_b ! Flags for boundaries receiving 91 94 INTEGER :: iw_b(4), ie_b(4), is_b(4), in_b(4) ! Arrays for neighbours coordinates 95 REAL(wp), POINTER, DIMENSION(:,:) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) 92 96 93 97 !! 94 NAMELIST/nambdy/ nb_bdy, ln_coords_file, cn_coords_file, &95 & ln_mask_file, cn_mask_file, nn_dyn2d, nn_dyn2d_dta,&96 & nn_dyn3d, nn_dyn3d_dta, nn_tra, nn_tra_dta,&97 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, 98 #if defined key_lim299 & nn_ice_lim2, nn_ice_lim2_dta,&98 NAMELIST/nambdy/ nb_bdy, ln_coords_file, cn_coords_file, & 99 & ln_mask_file, cn_mask_file, cn_dyn2d, nn_dyn2d_dta, & 100 & cn_dyn3d, nn_dyn3d_dta, cn_tra, nn_tra_dta, & 101 & ln_tra_dmp, ln_dyn3d_dmp, rn_time_dmp, rn_time_dmp_out, & 102 #if ( defined key_lim2 || defined key_lim3 ) 103 & cn_ice_lim, nn_ice_lim_dta, & 100 104 #endif 101 105 & ln_vol, nn_volctl, nn_rimwidth … … 156 160 157 161 IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution: ' 158 SELECT CASE( nn_dyn2d(ib_bdy) ) 159 CASE(jp_none) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 160 CASE(jp_frs) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 161 CASE(jp_flather) ; IF(lwp) WRITE(numout,*) ' Flather radiation condition' 162 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_dyn2d' ) 162 SELECT CASE( cn_dyn2d(ib_bdy) ) 163 CASE('none') 164 IF(lwp) WRITE(numout,*) ' no open boundary condition' 165 dta_bdy(ib_bdy)%ll_ssh = .false. 166 dta_bdy(ib_bdy)%ll_u2d = .false. 167 dta_bdy(ib_bdy)%ll_v2d = .false. 168 CASE('frs') 169 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 170 dta_bdy(ib_bdy)%ll_ssh = .false. 171 dta_bdy(ib_bdy)%ll_u2d = .true. 172 dta_bdy(ib_bdy)%ll_v2d = .true. 173 CASE('flather') 174 IF(lwp) WRITE(numout,*) ' Flather radiation condition' 175 dta_bdy(ib_bdy)%ll_ssh = .true. 176 dta_bdy(ib_bdy)%ll_u2d = .true. 177 dta_bdy(ib_bdy)%ll_v2d = .true. 178 CASE('orlanski') 179 IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' 180 dta_bdy(ib_bdy)%ll_ssh = .false. 181 dta_bdy(ib_bdy)%ll_u2d = .true. 182 dta_bdy(ib_bdy)%ll_v2d = .true. 183 CASE('orlanski_npo') 184 IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' 185 dta_bdy(ib_bdy)%ll_ssh = .false. 186 dta_bdy(ib_bdy)%ll_u2d = .true. 187 dta_bdy(ib_bdy)%ll_v2d = .true. 188 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn2d' ) 163 189 END SELECT 164 IF( nn_dyn2d(ib_bdy) .gt. 0) THEN190 IF( cn_dyn2d(ib_bdy) /= 'none' ) THEN 165 191 SELECT CASE( nn_dyn2d_dta(ib_bdy) ) ! 166 192 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' … … 177 203 178 204 IF(lwp) WRITE(numout,*) 'Boundary conditions for baroclinic velocities: ' 179 SELECT CASE( nn_dyn3d(ib_bdy) ) 180 CASE(jp_none) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 181 CASE(jp_frs) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 182 CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' Specified value' 183 CASE( 3 ) ; IF(lwp) WRITE(numout,*) ' Zero baroclinic velocities (runoff case)' 184 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_dyn3d' ) 205 SELECT CASE( cn_dyn3d(ib_bdy) ) 206 CASE('none') 207 IF(lwp) WRITE(numout,*) ' no open boundary condition' 208 dta_bdy(ib_bdy)%ll_u3d = .false. 209 dta_bdy(ib_bdy)%ll_v3d = .false. 210 CASE('frs') 211 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 212 dta_bdy(ib_bdy)%ll_u3d = .true. 213 dta_bdy(ib_bdy)%ll_v3d = .true. 214 CASE('specified') 215 IF(lwp) WRITE(numout,*) ' Specified value' 216 dta_bdy(ib_bdy)%ll_u3d = .true. 217 dta_bdy(ib_bdy)%ll_v3d = .true. 218 CASE('zero') 219 IF(lwp) WRITE(numout,*) ' Zero baroclinic velocities (runoff case)' 220 dta_bdy(ib_bdy)%ll_u3d = .false. 221 dta_bdy(ib_bdy)%ll_v3d = .false. 222 CASE('orlanski') 223 IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' 224 dta_bdy(ib_bdy)%ll_u3d = .true. 225 dta_bdy(ib_bdy)%ll_v3d = .true. 226 CASE('orlanski_npo') 227 IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' 228 dta_bdy(ib_bdy)%ll_u3d = .true. 229 dta_bdy(ib_bdy)%ll_v3d = .true. 230 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn3d' ) 185 231 END SELECT 186 IF( nn_dyn3d(ib_bdy) .gt. 0) THEN232 IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN 187 233 SELECT CASE( nn_dyn3d_dta(ib_bdy) ) ! 188 234 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' … … 193 239 194 240 IF ( ln_dyn3d_dmp(ib_bdy) ) THEN 195 IF ( nn_dyn3d(ib_bdy).EQ.0) THEN241 IF ( cn_dyn3d(ib_bdy) == 'none' ) THEN 196 242 IF(lwp) WRITE(numout,*) 'No open boundary condition for baroclinic velocities: ln_dyn3d_dmp is set to .false.' 197 243 ln_dyn3d_dmp(ib_bdy)=.false. 198 ELSEIF ( nn_dyn3d(ib_bdy).EQ.1) THEN244 ELSEIF ( cn_dyn3d(ib_bdy) == 'frs' ) THEN 199 245 CALL ctl_stop( 'Use FRS OR relaxation' ) 200 246 ELSE … … 202 248 IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' 203 249 IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 250 dta_bdy(ib_bdy)%ll_u3d = .true. 251 dta_bdy(ib_bdy)%ll_v3d = .true. 204 252 ENDIF 205 253 ELSE … … 209 257 210 258 IF(lwp) WRITE(numout,*) 'Boundary conditions for temperature and salinity: ' 211 SELECT CASE( nn_tra(ib_bdy) ) 212 CASE(jp_none) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 213 CASE(jp_frs) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 214 CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' Specified value' 215 CASE( 3 ) ; IF(lwp) WRITE(numout,*) ' Neumann conditions' 216 CASE( 4 ) ; IF(lwp) WRITE(numout,*) ' Runoff conditions : Neumann for T and specified to 0.1 for salinity' 217 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_tra' ) 259 SELECT CASE( cn_tra(ib_bdy) ) 260 CASE('none') 261 IF(lwp) WRITE(numout,*) ' no open boundary condition' 262 dta_bdy(ib_bdy)%ll_tem = .false. 263 dta_bdy(ib_bdy)%ll_sal = .false. 264 CASE('frs') 265 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 266 dta_bdy(ib_bdy)%ll_tem = .true. 267 dta_bdy(ib_bdy)%ll_sal = .true. 268 CASE('specified') 269 IF(lwp) WRITE(numout,*) ' Specified value' 270 dta_bdy(ib_bdy)%ll_tem = .true. 271 dta_bdy(ib_bdy)%ll_sal = .true. 272 CASE('neumann') 273 IF(lwp) WRITE(numout,*) ' Neumann conditions' 274 dta_bdy(ib_bdy)%ll_tem = .false. 275 dta_bdy(ib_bdy)%ll_sal = .false. 276 CASE('runoff') 277 IF(lwp) WRITE(numout,*) ' Runoff conditions : Neumann for T and specified to 0.1 for salinity' 278 dta_bdy(ib_bdy)%ll_tem = .false. 279 dta_bdy(ib_bdy)%ll_sal = .false. 280 CASE('orlanski') 281 IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' 282 dta_bdy(ib_bdy)%ll_tem = .true. 283 dta_bdy(ib_bdy)%ll_sal = .true. 284 CASE('orlanski_npo') 285 IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' 286 dta_bdy(ib_bdy)%ll_tem = .true. 287 dta_bdy(ib_bdy)%ll_sal = .true. 288 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_tra' ) 218 289 END SELECT 219 IF( nn_tra(ib_bdy) .gt. 0) THEN290 IF( cn_tra(ib_bdy) /= 'none' ) THEN 220 291 SELECT CASE( nn_tra_dta(ib_bdy) ) ! 221 292 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' … … 226 297 227 298 IF ( ln_tra_dmp(ib_bdy) ) THEN 228 IF ( nn_tra(ib_bdy).EQ.0) THEN299 IF ( cn_tra(ib_bdy) == 'none' ) THEN 229 300 IF(lwp) WRITE(numout,*) 'No open boundary condition for tracers: ln_tra_dmp is set to .false.' 230 301 ln_tra_dmp(ib_bdy)=.false. 231 ELSEIF ( nn_tra(ib_bdy).EQ.1) THEN302 ELSEIF ( cn_tra(ib_bdy) == 'frs' ) THEN 232 303 CALL ctl_stop( 'Use FRS OR relaxation' ) 233 304 ELSE 234 305 IF(lwp) WRITE(numout,*) ' + T/S relaxation zone' 235 306 IF(lwp) WRITE(numout,*) ' Damping time scale: ',rn_time_dmp(ib_bdy),' days' 307 IF(lwp) WRITE(numout,*) ' Outflow damping time scale: ',rn_time_dmp_out(ib_bdy),' days' 236 308 IF((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) 309 dta_bdy(ib_bdy)%ll_tem = .true. 310 dta_bdy(ib_bdy)%ll_sal = .true. 237 311 ENDIF 238 312 ELSE … … 243 317 #if defined key_lim2 244 318 IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: ' 245 SELECT CASE( nn_ice_lim2(ib_bdy) ) 246 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' no open boundary condition' 247 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 248 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_tra' ) 319 SELECT CASE( cn_ice_lim(ib_bdy) ) 320 CASE('none') 321 IF(lwp) WRITE(numout,*) ' no open boundary condition' 322 dta_bdy(ib_bdy)%ll_frld = .false. 323 dta_bdy(ib_bdy)%ll_hicif = .false. 324 dta_bdy(ib_bdy)%ll_hsnif = .false. 325 CASE('frs') 326 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 327 dta_bdy(ib_bdy)%ll_frld = .true. 328 dta_bdy(ib_bdy)%ll_hicif = .true. 329 dta_bdy(ib_bdy)%ll_hsnif = .true. 330 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) 249 331 END SELECT 250 IF( nn_ice_lim2(ib_bdy) .gt. 0) THEN251 SELECT CASE( nn_ice_lim 2_dta(ib_bdy) ) !332 IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN 333 SELECT CASE( nn_ice_lim_dta(ib_bdy) ) ! 252 334 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' 253 335 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' 254 CASE DEFAULT ; CALL ctl_stop( 'nn_ice_lim2_dta must be 0 or 1' ) 336 CASE DEFAULT ; CALL ctl_stop( 'nn_ice_lim_dta must be 0 or 1' ) 337 END SELECT 338 ENDIF 339 IF(lwp) WRITE(numout,*) 340 #elif defined key_lim3 341 IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: ' 342 SELECT CASE( cn_ice_lim(ib_bdy) ) 343 CASE('none') 344 IF(lwp) WRITE(numout,*) ' no open boundary condition' 345 dta_bdy(ib_bdy)%ll_a_i = .false. 346 dta_bdy(ib_bdy)%ll_ht_i = .false. 347 dta_bdy(ib_bdy)%ll_ht_s = .false. 348 CASE('frs') 349 IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' 350 dta_bdy(ib_bdy)%ll_a_i = .true. 351 dta_bdy(ib_bdy)%ll_ht_i = .true. 352 dta_bdy(ib_bdy)%ll_ht_s = .true. 353 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) 354 END SELECT 355 IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN 356 SELECT CASE( nn_ice_lim_dta(ib_bdy) ) ! 357 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' 358 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' 359 CASE DEFAULT ; CALL ctl_stop( 'nn_ice_lim_dta must be 0 or 1' ) 255 360 END SELECT 256 361 ENDIF … … 740 845 IF(lwp) THEN ! Since all procs read global data only need to do this check on one proc... 741 846 IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ibm1,igrd,ib_bdy) ) THEN 742 CALL ctl_stop('bdy_init : ERROR : boundary data in file & 743 must be defined in order of distance from edge nbr.', & 744 'A utility for re-ordering boundary coordinates and data & 745 files exists in the TOOLS/OBC directory') 847 CALL ctl_stop('bdy_init : ERROR : boundary data in file must be defined in order of distance from edge nbr.', & 848 'A utility for re-ordering boundary coordinates and data files exists in the TOOLS/OBC directory') 746 849 ENDIF 747 850 ENDIF … … 766 869 ALLOCATE( idx_bdy(ib_bdy)%nbr(ilen1,jpbgrd) ) 767 870 ALLOCATE( idx_bdy(ib_bdy)%nbd(ilen1,jpbgrd) ) 871 ALLOCATE( idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) ) 768 872 ALLOCATE( idx_bdy(ib_bdy)%nbmap(ilen1,jpbgrd) ) 769 873 ALLOCATE( idx_bdy(ib_bdy)%nbw(ilen1,jpbgrd) ) 770 ALLOCATE( idx_bdy(ib_bdy)%flagu(ilen1 ) )771 ALLOCATE( idx_bdy(ib_bdy)%flagv(ilen1 ) )874 ALLOCATE( idx_bdy(ib_bdy)%flagu(ilen1,jpbgrd) ) 875 ALLOCATE( idx_bdy(ib_bdy)%flagv(ilen1,jpbgrd) ) 772 876 773 877 ! Dispatch mapping indices and discrete distances on each processor … … 937 1041 ENDDO 938 1042 ENDDO 1043 939 1044 ! definition of the i- and j- direction local boundaries arrays 940 1045 ! used for sending the boudaries … … 990 1095 nbr => idx_bdy(ib_bdy)%nbr(ib,igrd) 991 1096 idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) & 1097 & *(FLOAT(nn_rimwidth(ib_bdy)+1-nbr)/FLOAT(nn_rimwidth(ib_bdy)))**2. ! quadratic 1098 idx_bdy(ib_bdy)%nbdout(ib,igrd) = 1. / ( rn_time_dmp_out(ib_bdy) * rday ) & 992 1099 & *(FLOAT(nn_rimwidth(ib_bdy)+1-nbr)/FLOAT(nn_rimwidth(ib_bdy)))**2. ! quadratic 993 1100 END DO … … 1092 1199 ENDDO 1093 1200 1201 ! For the flagu/flagv calculation below we require a version of fmask without 1202 ! the land boundary condition (shlat) included: 1203 CALL wrk_alloc(jpi,jpj,zfmask) 1204 DO ij = 2, jpjm1 1205 DO ii = 2, jpim1 1206 zfmask(ii,ij) = tmask(ii,ij ,1) * tmask(ii+1,ij ,1) & 1207 & * tmask(ii,ij+1,1) * tmask(ii+1,ij+1,1) 1208 END DO 1209 END DO 1210 1094 1211 ! Lateral boundary conditions 1212 CALL lbc_lnk( zfmask , 'F', 1. ) 1095 1213 CALL lbc_lnk( fmask , 'F', 1. ) ; CALL lbc_lnk( bdytmask(:,:), 'T', 1. ) 1096 1214 CALL lbc_lnk( bdyumask(:,:), 'U', 1. ) ; CALL lbc_lnk( bdyvmask(:,:), 'V', 1. ) … … 1098 1216 DO ib_bdy = 1, nb_bdy ! Indices and directions of rim velocity components 1099 1217 1100 idx_bdy(ib_bdy)%flagu(: ) = 0.e01101 idx_bdy(ib_bdy)%flagv(: ) = 0.e01218 idx_bdy(ib_bdy)%flagu(:,:) = 0.e0 1219 idx_bdy(ib_bdy)%flagv(:,:) = 0.e0 1102 1220 icount = 0 1103 1221 1104 !flagu = -1 : u component is normal to the dynamical boundary but its direction is outward 1105 !flagu = 0 : u is tangential 1106 !flagu = 1 : u is normal to the boundary and is direction is inward 1222 ! Calculate relationship of U direction to the local orientation of the boundary 1223 ! flagu = -1 : u component is normal to the dynamical boundary and its direction is outward 1224 ! flagu = 0 : u is tangential 1225 ! flagu = 1 : u is normal to the boundary and is direction is inward 1107 1226 1108 igrd = 2 ! u-component 1109 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1110 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 1111 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 1112 zefl = bdytmask(nbi ,nbj) 1113 zwfl = bdytmask(nbi+1,nbj) 1114 IF( zefl + zwfl == 2 ) THEN 1115 icount = icount + 1 1116 ELSE 1117 idx_bdy(ib_bdy)%flagu(ib)=-zefl+zwfl 1118 ENDIF 1227 DO igrd = 1,jpbgrd 1228 SELECT CASE( igrd ) 1229 CASE( 1 ) 1230 pmask => umask(:,:,1) 1231 i_offset = 0 1232 CASE( 2 ) 1233 pmask => bdytmask 1234 i_offset = 1 1235 CASE( 3 ) 1236 pmask => zfmask(:,:) 1237 i_offset = 0 1238 END SELECT 1239 icount = 0 1240 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1241 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 1242 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 1243 zefl = pmask(nbi+i_offset-1,nbj) 1244 zwfl = pmask(nbi+i_offset,nbj) 1245 ! This error check only works if you are using the bdyXmask arrays 1246 IF( i_offset == 1 .and. zefl + zwfl == 2 ) THEN 1247 icount = icount + 1 1248 IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(nbi),mjg(nbj) 1249 ELSE 1250 idx_bdy(ib_bdy)%flagu(ib,igrd) = -zefl + zwfl 1251 ENDIF 1252 END DO 1253 IF( icount /= 0 ) THEN 1254 IF(lwp) WRITE(numout,*) 1255 IF(lwp) WRITE(numout,*) ' E R R O R : Some ',cgrid(igrd),' grid points,', & 1256 ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 1257 IF(lwp) WRITE(numout,*) ' ========== ' 1258 IF(lwp) WRITE(numout,*) 1259 nstop = nstop + 1 1260 ENDIF 1119 1261 END DO 1120 1262 1121 !flagv = -1 : u component is normal to the dynamical boundary but its direction is outward 1122 !flagv = 0 : u is tangential 1123 !flagv = 1 : u is normal to the boundary and is direction is inward 1124 1125 igrd = 3 ! v-component 1126 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1127 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 1128 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 1129 znfl = bdytmask(nbi,nbj ) 1130 zsfl = bdytmask(nbi,nbj+1) 1131 IF( znfl + zsfl == 2 ) THEN 1132 icount = icount + 1 1133 ELSE 1134 idx_bdy(ib_bdy)%flagv(ib) = -znfl + zsfl 1135 END IF 1263 ! Calculate relationship of V direction to the local orientation of the boundary 1264 ! flagv = -1 : v component is normal to the dynamical boundary but its direction is outward 1265 ! flagv = 0 : v is tangential 1266 ! flagv = 1 : v is normal to the boundary and is direction is inward 1267 1268 DO igrd = 1,jpbgrd 1269 SELECT CASE( igrd ) 1270 CASE( 1 ) 1271 pmask => vmask(:,:,1) 1272 j_offset = 0 1273 CASE( 2 ) 1274 pmask => zfmask(:,:) 1275 j_offset = 0 1276 CASE( 3 ) 1277 pmask => bdytmask 1278 j_offset = 1 1279 END SELECT 1280 icount = 0 1281 DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) 1282 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 1283 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 1284 znfl = pmask(nbi,nbj+j_offset-1 ) 1285 zsfl = pmask(nbi,nbj+j_offset) 1286 ! This error check only works if you are using the bdyXmask arrays 1287 IF( j_offset == 1 .and. znfl + zsfl == 2 ) THEN 1288 IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(nbi),mjg(nbj) 1289 icount = icount + 1 1290 ELSE 1291 idx_bdy(ib_bdy)%flagv(ib,igrd) = -znfl + zsfl 1292 END IF 1293 END DO 1294 IF( icount /= 0 ) THEN 1295 IF(lwp) WRITE(numout,*) 1296 IF(lwp) WRITE(numout,*) ' E R R O R : Some ',cgrid(igrd),' grid points,', & 1297 ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy 1298 IF(lwp) WRITE(numout,*) ' ========== ' 1299 IF(lwp) WRITE(numout,*) 1300 nstop = nstop + 1 1301 ENDIF 1136 1302 END DO 1137 1303 1138 IF( icount /= 0 ) THEN 1139 IF(lwp) WRITE(numout,*) 1140 IF(lwp) WRITE(numout,*) ' E R R O R : Some data velocity points,', & 1141 ' are not boundary points. Check nbi, nbj, indices for boundary set ',ib_bdy 1142 IF(lwp) WRITE(numout,*) ' ========== ' 1143 IF(lwp) WRITE(numout,*) 1144 nstop = nstop + 1 1145 ENDIF 1146 1147 ENDDO 1304 END DO 1148 1305 1149 1306 ! Compute total lateral surface for volume correction: … … 1157 1314 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 1158 1315 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 1159 flagu => idx_bdy(ib_bdy)%flagu(ib )1316 flagu => idx_bdy(ib_bdy)%flagu(ib,igrd) 1160 1317 bdysurftot = bdysurftot + hu (nbi , nbj) & 1161 1318 & * e2u (nbi , nbj) * ABS( flagu ) & … … 1170 1327 nbi => idx_bdy(ib_bdy)%nbi(ib,igrd) 1171 1328 nbj => idx_bdy(ib_bdy)%nbj(ib,igrd) 1172 flagv => idx_bdy(ib_bdy)%flagv(ib )1329 flagv => idx_bdy(ib_bdy)%flagv(ib,igrd) 1173 1330 bdysurftot = bdysurftot + hv (nbi, nbj ) & 1174 1331 & * e1v (nbi, nbj ) * ABS( flagv ) & … … 1186 1343 DEALLOCATE(nbidta, nbjdta, nbrdta) 1187 1344 ENDIF 1345 1346 CALL wrk_dealloc(jpi,jpj,zfmask) 1188 1347 1189 1348 IF( nn_timing == 1 ) CALL timing_stop('bdy_init') … … 1580 1739 itest = 0 1581 1740 1582 IF ( nn_dyn2d(ib1)/=nn_dyn2d(ib2)) itest = itest + 11583 IF ( nn_dyn3d(ib1)/=nn_dyn3d(ib2)) itest = itest + 11584 IF ( nn_tra(ib1)/=nn_tra(ib2)) itest = itest + 11741 IF (cn_dyn2d(ib1)/=cn_dyn2d(ib2)) itest = itest + 1 1742 IF (cn_dyn3d(ib1)/=cn_dyn3d(ib2)) itest = itest + 1 1743 IF (cn_tra(ib1)/=cn_tra(ib2)) itest = itest + 1 1585 1744 ! 1586 1745 IF (nn_dyn2d_dta(ib1)/=nn_dyn2d_dta(ib2)) itest = itest + 1 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90
r4147 r4292 9 9 !! 3.3 ! 2010-09 (D.Storkey and E.O'Dea) bug fixes 10 10 !! 3.4 ! 2012-09 (G. Reffray and J. Chanut) New inputs + mods 11 !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes 11 12 !!---------------------------------------------------------------------- 12 13 #if defined key_bdy … … 32 33 ! USE tide_mod ! Useless ?? 33 34 USE fldread, ONLY: fld_map 35 USE dynspg_oce, ONLY: lk_dynspg_ts 34 36 35 37 IMPLICIT NONE … … 38 40 PUBLIC bdytide_init ! routine called in bdy_init 39 41 PUBLIC bdytide_update ! routine called in bdy_dta 42 PUBLIC bdy_dta_tides ! routine called in dyn_spg_ts 40 43 41 44 TYPE, PUBLIC :: TIDES_DATA !: Storage for external tidal harmonics data … … 49 52 50 53 TYPE(TIDES_DATA), PUBLIC, DIMENSION(jp_bdy), TARGET :: tides !: External tidal harmonics data 54 TYPE(OBC_DATA) , PRIVATE, DIMENSION(jp_bdy) :: dta_bdy_s !: bdy external data (slow component) 51 55 52 56 !!---------------------------------------------------------------------- … … 131 135 ! JC: If FRS scheme is used, we assume that tidal is needed over the whole 132 136 ! relaxation area 133 IF( nn_dyn2d(ib_bdy) .eq. jp_frs) THEN137 IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN 134 138 ilen0(:)=nblen(:) 135 139 ELSE … … 146 150 ALLOCATE( td%v ( ilen0(3), nb_harmo, 2 ) ) 147 151 148 td%ssh0(:,:,:) = 0. e0149 td%ssh (:,:,:) = 0.e0150 td%u0 (:,:,:) = 0.e0151 td%u (:,:,:) = 0.e0152 td%v0 (:,:,:) = 0.e0153 td%v (:,:,:) = 0.e0152 td%ssh0(:,:,:) = 0._wp 153 td%ssh (:,:,:) = 0._wp 154 td%u0 (:,:,:) = 0._wp 155 td%u (:,:,:) = 0._wp 156 td%v0 (:,:,:) = 0._wp 157 td%v (:,:,:) = 0._wp 154 158 155 159 IF (ln_bdytide_2ddta) THEN … … 255 259 ENDIF 256 260 ! 261 IF ( lk_dynspg_ts ) THEN ! Allocate arrays to save slowly varying boundary data during 262 ! time splitting integration 263 ALLOCATE( dta_bdy_s(ib_bdy)%ssh ( ilen0(1) ) ) 264 ALLOCATE( dta_bdy_s(ib_bdy)%u2d ( ilen0(2) ) ) 265 ALLOCATE( dta_bdy_s(ib_bdy)%v2d ( ilen0(3) ) ) 266 dta_bdy_s(ib_bdy)%ssh(:) = 0.e0 267 dta_bdy_s(ib_bdy)%u2d(:) = 0.e0 268 dta_bdy_s(ib_bdy)%v2d(:) = 0.e0 269 ENDIF 270 ! 257 271 ENDIF ! nn_dyn2d_dta(ib_bdy) .ge. 2 258 272 ! … … 300 314 ENDIF 301 315 302 IF ( nsec_day == NINT(0.5 * rdttra(1)) .AND. zflag==1 ) THEN316 IF ( nsec_day == NINT(0.5_wp * rdttra(1)) .AND. zflag==1 ) THEN 303 317 ! 304 318 kt_tide = kt … … 321 335 322 336 IF( PRESENT(jit) ) THEN 323 z_arg = ( ((kt-kt_tide)-1) * rdt + (jit+time_add) * rdt / REAL(nn_baro,wp) )337 z_arg = ((kt-kt_tide) * rdt + (jit+0.5_wp*(time_add-1)) * rdt / REAL(nn_baro,wp) ) 324 338 ELSE 325 339 z_arg = ((kt-kt_tide)+time_add) * rdt … … 327 341 328 342 ! Linear ramp on tidal component at open boundaries 329 zramp = 1. 330 IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg + (kt_tide-nit000)*rdt)/(rdttideramp*rday),0. ),1.)343 zramp = 1._wp 344 IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg + (kt_tide-nit000)*rdt)/(rdttideramp*rday),0._wp),1._wp) 331 345 332 346 DO itide = 1, nb_harmo … … 354 368 ! 355 369 END SUBROUTINE bdytide_update 370 371 SUBROUTINE bdy_dta_tides( kt, kit, time_offset ) 372 !!---------------------------------------------------------------------- 373 !! *** SUBROUTINE bdy_dta_tides *** 374 !! 375 !! ** Purpose : - Add tidal forcing to ssh, u2d and v2d OBC data arrays. 376 !! 377 !!---------------------------------------------------------------------- 378 INTEGER, INTENT( in ) :: kt ! Main timestep counter 379 INTEGER, INTENT( in ),OPTIONAL :: kit ! Barotropic timestep counter (for timesplitting option) 380 INTEGER, INTENT( in ),OPTIONAL :: time_offset ! time offset in units of timesteps. NB. if kit 381 ! is present then units = subcycle timesteps. 382 ! time_offset = 0 => get data at "now" time level 383 ! time_offset = -1 => get data at "before" time level 384 ! time_offset = +1 => get data at "after" time level 385 ! etc. 386 !! 387 LOGICAL :: lk_first_btstp ! =.TRUE. if time splitting and first barotropic step 388 INTEGER, DIMENSION(jpbgrd) :: ilen0 389 INTEGER, DIMENSION(1:jpbgrd) :: nblen, nblenrim ! short cuts 390 INTEGER :: itide, ib_bdy, ib, igrd ! loop indices 391 INTEGER :: time_add ! time offset in units of timesteps 392 REAL(wp) :: z_arg, z_sarg, zramp, zoff, z_cost, z_sist 393 !!---------------------------------------------------------------------- 394 395 IF( nn_timing == 1 ) CALL timing_start('bdy_dta_tides') 396 397 lk_first_btstp=.TRUE. 398 IF ( PRESENT(kit).AND.( kit /= 1 ) ) THEN ; lk_first_btstp=.FALSE. ; ENDIF 399 400 time_add = 0 401 IF( PRESENT(time_offset) ) THEN 402 time_add = time_offset 403 ENDIF 404 405 ! Absolute time from model initialization: 406 IF( PRESENT(kit) ) THEN 407 z_arg = ( kt + (kit+0.5_wp*(time_add-1)) / REAL(nn_baro,wp) ) * rdt 408 ELSE 409 z_arg = ( kt + time_add ) * rdt 410 ENDIF 411 412 ! Linear ramp on tidal component at open boundaries 413 zramp = 1. 414 IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg - nit000*rdt)/(rdttideramp*rday),0.),1.) 415 416 DO ib_bdy = 1,nb_bdy 417 418 ! line below should be simplified (runoff case) 419 !! CHANUT: TO BE SORTED OUT 420 !! IF (( nn_dyn2d_dta(ib_bdy) .ge. 2 ).AND.(nn_tra(ib_bdy).NE.4)) THEN 421 IF ( nn_dyn2d_dta(ib_bdy) .ge. 2 ) THEN 422 423 nblen(1:jpbgrd) = idx_bdy(ib_bdy)%nblen(1:jpbgrd) 424 nblenrim(1:jpbgrd) = idx_bdy(ib_bdy)%nblenrim(1:jpbgrd) 425 426 IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN 427 ilen0(:)=nblen(:) 428 ELSE 429 ilen0(:)=nblenrim(:) 430 ENDIF 431 432 ! We refresh nodal factors every day below 433 ! This should be done somewhere else 434 IF ( nsec_day == NINT(0.5_wp * rdttra(1)) .AND. lk_first_btstp ) THEN 435 ! 436 kt_tide = kt 437 ! 438 IF(lwp) THEN 439 WRITE(numout,*) 440 WRITE(numout,*) 'bdy_tide_dta : Refresh nodal factors for tidal open bdy data at kt=',kt 441 WRITE(numout,*) '~~~~~~~~~~~~~~ ' 442 ENDIF 443 ! 444 CALL tide_init_elevation ( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) ) 445 CALL tide_init_velocities( idx=idx_bdy(ib_bdy), td=tides(ib_bdy) ) 446 ! 447 ENDIF 448 zoff = -kt_tide * rdt ! time offset relative to nodal factor computation time 449 ! 450 ! If time splitting, save data at first barotropic iteration 451 IF ( PRESENT(kit) ) THEN 452 IF ( lk_first_btstp ) THEN ! Save slow varying open boundary data: 453 dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy(ib_bdy)%ssh(1:ilen0(1)) 454 dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy(ib_bdy)%u2d(1:ilen0(2)) 455 dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy(ib_bdy)%v2d(1:ilen0(3)) 456 457 ELSE ! Initialize arrays from slow varying open boundary data: 458 dta_bdy(ib_bdy)%ssh(1:ilen0(1)) = dta_bdy_s(ib_bdy)%ssh(1:ilen0(1)) 459 dta_bdy(ib_bdy)%u2d(1:ilen0(2)) = dta_bdy_s(ib_bdy)%u2d(1:ilen0(2)) 460 dta_bdy(ib_bdy)%v2d(1:ilen0(3)) = dta_bdy_s(ib_bdy)%v2d(1:ilen0(3)) 461 ENDIF 462 ENDIF 463 ! 464 ! Update open boundary data arrays: 465 DO itide = 1, nb_harmo 466 ! 467 z_sarg = (z_arg + zoff) * omega_tide(itide) 468 z_cost = zramp * COS( z_sarg ) 469 z_sist = zramp * SIN( z_sarg ) 470 ! 471 igrd=1 ! SSH on tracer grid 472 DO ib = 1, ilen0(igrd) 473 dta_bdy(ib_bdy)%ssh(ib) = dta_bdy(ib_bdy)%ssh(ib) + & 474 & ( tides(ib_bdy)%ssh(ib,itide,1)*z_cost + & 475 & tides(ib_bdy)%ssh(ib,itide,2)*z_sist ) 476 END DO 477 ! 478 igrd=2 ! U grid 479 DO ib = 1, ilen0(igrd) 480 dta_bdy(ib_bdy)%u2d(ib) = dta_bdy(ib_bdy)%u2d(ib) + & 481 & ( tides(ib_bdy)%u(ib,itide,1)*z_cost + & 482 & tides(ib_bdy)%u(ib,itide,2)*z_sist ) 483 END DO 484 ! 485 igrd=3 ! V grid 486 DO ib = 1, ilen0(igrd) 487 dta_bdy(ib_bdy)%v2d(ib) = dta_bdy(ib_bdy)%v2d(ib) + & 488 & ( tides(ib_bdy)%v(ib,itide,1)*z_cost + & 489 & tides(ib_bdy)%v(ib,itide,2)*z_sist ) 490 END DO 491 END DO 492 END IF 493 END DO 494 ! 495 IF( nn_timing == 1 ) CALL timing_stop('bdy_dta_tides') 496 ! 497 END SUBROUTINE bdy_dta_tides 356 498 357 499 SUBROUTINE tide_init_elevation( idx, td ) … … 460 602 WRITE(*,*) 'bdytide_update: You should not have seen this print! error?', kt, jit 461 603 END SUBROUTINE bdytide_update 604 SUBROUTINE bdy_dta_tides( kt, kit, time_offset ) ! Empty routine 605 INTEGER, INTENT( in ) :: kt ! Dummy argument empty routine 606 INTEGER, INTENT( in ),OPTIONAL :: kit ! Dummy argument empty routine 607 INTEGER, INTENT( in ),OPTIONAL :: time_offset ! Dummy argument empty routine 608 WRITE(*,*) 'bdy_dta_tides: You should not have seen this print! error?', kt, jit 609 END SUBROUTINE bdy_dta_tides 462 610 #endif 463 611 464 612 !!====================================================================== 465 613 END MODULE bdytides 614 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdytra.F90
r3777 r4292 20 20 USE dom_oce ! ocean space and time domain variables 21 21 USE bdy_oce ! ocean open boundary conditions 22 USE bdylib ! for orlanski library routines 22 23 USE bdydta, ONLY: bf 23 24 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 51 52 DO ib_bdy=1, nb_bdy 52 53 53 SELECT CASE( nn_tra(ib_bdy) )54 CASE( jp_none)54 SELECT CASE( cn_tra(ib_bdy) ) 55 CASE('none') 55 56 CYCLE 56 CASE( jp_frs)57 CASE('frs') 57 58 CALL bdy_tra_frs( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 58 CASE( 2)59 CASE('specified') 59 60 CALL bdy_tra_spe( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 60 CASE( 3)61 CASE('neumann') 61 62 CALL bdy_tra_nmn( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 62 CASE(4) 63 CASE('orlanski') 64 CALL bdy_tra_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ll_npo=.false. ) 65 CASE('orlanski_npo') 66 CALL bdy_tra_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ll_npo=.true. ) 67 CASE('runoff') 63 68 CALL bdy_tra_rnf( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt ) 64 69 CASE DEFAULT … … 196 201 ! 197 202 END SUBROUTINE bdy_tra_nmn 203 204 205 SUBROUTINE bdy_tra_orlanski( idx, dta, ll_npo ) 206 !!---------------------------------------------------------------------- 207 !! *** SUBROUTINE bdy_tra_orlanski *** 208 !! 209 !! - Apply Orlanski radiation to temperature and salinity. 210 !! - Wrapper routine for bdy_orlanski_3d 211 !! 212 !! 213 !! References: Marchesiello, McWilliams and Shchepetkin, Ocean Modelling vol. 3 (2001) 214 !!---------------------------------------------------------------------- 215 TYPE(OBC_INDEX), INTENT(in) :: idx ! OBC indices 216 TYPE(OBC_DATA), INTENT(in) :: dta ! OBC external data 217 LOGICAL, INTENT(in) :: ll_npo ! switch for NPO version 218 219 INTEGER :: igrd ! grid index 220 !!---------------------------------------------------------------------- 221 222 IF( nn_timing == 1 ) CALL timing_start('bdy_tra_orlanski') 223 ! 224 igrd = 1 ! Orlanski bc on temperature; 225 ! 226 CALL bdy_orlanski_3d( idx, igrd, tsb(:,:,:,jp_tem), tsa(:,:,:,jp_tem), dta%tem, ll_npo ) 227 228 igrd = 1 ! Orlanski bc on salinity; 229 ! 230 CALL bdy_orlanski_3d( idx, igrd, tsb(:,:,:,jp_sal), tsa(:,:,:,jp_sal), dta%sal, ll_npo ) 231 ! 232 IF( nn_timing == 1 ) CALL timing_stop('bdy_tra_orlanski') 233 ! 234 235 END SUBROUTINE bdy_tra_orlanski 236 198 237 199 238 SUBROUTINE bdy_tra_rnf( idx, dta, kt ) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/BDY/bdyvol.F90
r3294 r4292 104 104 ii = idx%nbi(jb,jgrd) 105 105 ij = idx%nbj(jb,jgrd) 106 zubtpecor = zubtpecor + idx%flagu(jb ) * ua(ii,ij, jk) * e2u(ii,ij) * fse3u(ii,ij,jk)106 zubtpecor = zubtpecor + idx%flagu(jb,jgrd) * ua(ii,ij, jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 107 107 END DO 108 108 END DO … … 112 112 ii = idx%nbi(jb,jgrd) 113 113 ij = idx%nbj(jb,jgrd) 114 zubtpecor = zubtpecor + idx%flagv(jb ) * va(ii,ij, jk) * e1v(ii,ij) * fse3v(ii,ij,jk)114 zubtpecor = zubtpecor + idx%flagv(jb,jgrd) * va(ii,ij, jk) * e1v(ii,ij) * fse3v(ii,ij,jk) 115 115 END DO 116 116 END DO … … 136 136 ii = idx%nbi(jb,jgrd) 137 137 ij = idx%nbj(jb,jgrd) 138 ua(ii,ij,jk) = ua(ii,ij,jk) - idx%flagu(jb ) * zubtpecor * umask(ii,ij,jk)139 ztranst = ztranst + idx%flagu(jb ) * ua(ii,ij,jk) * e2u(ii,ij) * fse3u(ii,ij,jk)138 ua(ii,ij,jk) = ua(ii,ij,jk) - idx%flagu(jb,jgrd) * zubtpecor * umask(ii,ij,jk) 139 ztranst = ztranst + idx%flagu(jb,jgrd) * ua(ii,ij,jk) * e2u(ii,ij) * fse3u(ii,ij,jk) 140 140 END DO 141 141 END DO … … 145 145 ii = idx%nbi(jb,jgrd) 146 146 ij = idx%nbj(jb,jgrd) 147 va(ii,ij,jk) = va(ii,ij,jk) -idx%flagv(jb ) * zubtpecor * vmask(ii,ij,jk)148 ztranst = ztranst + idx%flagv(jb ) * va(ii,ij,jk) * e1v(ii,ij) * fse3v(ii,ij,jk)147 va(ii,ij,jk) = va(ii,ij,jk) -idx%flagv(jb,jgrd) * zubtpecor * vmask(ii,ij,jk) 148 ztranst = ztranst + idx%flagv(jb,jgrd) * va(ii,ij,jk) * e1v(ii,ij) * fse3v(ii,ij,jk) 149 149 END DO 150 150 END DO -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90
r3294 r4292 196 196 thick0(:,:) = 0._wp 197 197 DO jk = 1, jpkm1 198 vol0 = vol0 + SUM( area (:,:) * tmask(:,:,jk) * fse3t_0(:,:,jk) )199 thick0(:,:) = thick0(:,:) + tmask_i(:,:) * tmask(:,:,jk) * fse3t_0(:,:,jk)198 vol0 = vol0 + SUM( area (:,:) * tmask(:,:,jk) * e3t_0(:,:,jk) ) 199 thick0(:,:) = thick0(:,:) + tmask_i(:,:) * tmask(:,:,jk) * e3t_0(:,:,jk) 200 200 END DO 201 201 IF( lk_mpp ) CALL mpp_sum( vol0 ) … … 212 212 ik = mbkt(ji,jj) 213 213 IF( ik > 1 ) THEN 214 zztmp = ( gdept_ 0(ik) - fsdept_0(ji,jj,ik) ) / ( gdept_0(ik) - gdept_0(ik-1) )214 zztmp = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 215 215 sn0(ji,jj,ik) = ( 1._wp - zztmp ) * sn0(ji,jj,ik) + zztmp * sn0(ji,jj,ik-1) 216 216 ENDIF -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90
r3294 r4292 112 112 113 113 CASE ( 'T') 114 z4dep(:)=gdept_ 0(:)114 z4dep(:)=gdept_1d(:) 115 115 116 116 CASE ( 'W' ) 117 z4dep(:)=gdepw_ 0(:)117 z4dep(:)=gdepw_1d(:) 118 118 119 119 CASE ( '2' ) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90
r4147 r4292 1 1 MODULE diaharm 2 3 #if defined key_diaharm && defined key_tide 4 !!================================================================================= 2 !!====================================================================== 5 3 !! *** MODULE diaharm *** 6 4 !! Harmonic analysis of tidal constituents 7 !!================================================================================= 8 !! * Modules used 5 !!====================================================================== 6 !! History : 3.1 ! 2007 (O. Le Galloudec, J. Chanut) Original code 7 !!---------------------------------------------------------------------- 8 #if defined key_diaharm && defined key_tide 9 !!---------------------------------------------------------------------- 10 !! 'key_diaharm' 11 !! 'key_tide' 12 !!---------------------------------------------------------------------- 9 13 USE oce ! ocean dynamics and tracers variables 10 14 USE dom_oce ! ocean space and time domain 11 USE in_out_manager ! I/O units12 USE lbclnk ! ocean lateral boundary conditions (or mpp link)13 USE ioipsl ! NetCDF IPSL library14 USE diadimg ! To write dimg15 15 USE phycst 16 16 USE dynspg_oce … … 18 18 USE daymod 19 19 USE tide_mod 20 USE iom 20 USE in_out_manager ! I/O units 21 USE iom ! I/0 library 22 USE ioipsl ! NetCDF IPSL library 23 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 24 USE diadimg ! To write dimg 21 25 USE timing ! preformance summary 22 26 USE wrk_nemo ! working arrays … … 30 34 INTEGER, PARAMETER :: jpdimsparse = jpincomax*300*24 31 35 32 INTEGER :: & !! namelist variables 33 nit000_han , & ! First time step used for harmonic analysis 34 nitend_han , & ! Last time step used for harmonic analysis 35 nstep_han , & ! Time step frequency for harmonic analysis 36 nb_ana ! Number of harmonics to analyse 37 38 INTEGER , ALLOCATABLE, DIMENSION(:) :: name 39 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ana_temp 40 REAL(wp), ALLOCATABLE, DIMENSION(:) :: ana_freq, vt, ut, ft 41 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: out_eta, & 42 out_u , & 43 out_v 44 45 INTEGER :: ninco, nsparse 46 INTEGER , DIMENSION(jpdimsparse) :: njsparse, nisparse 47 INTEGER , SAVE, DIMENSION(jpincomax) :: ipos1 48 REAL(wp), DIMENSION(jpdimsparse) :: valuesparse 49 REAL(wp), DIMENSION(jpincomax) :: ztmp4 , ztmp7 50 REAL(wp), SAVE, DIMENSION(jpincomax,jpincomax) :: ztmp3 , zpilier 51 REAL(wp), SAVE, DIMENSION(jpincomax) :: zpivot 52 53 CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: & 54 tname ! Names of tidal constituents ('M2', 'K1',...) 55 56 57 !! * Routine accessibility 58 PUBLIC dia_harm ! routine called by step.F90 59 60 !!--------------------------------------------------------------------------------- 61 !! 62 !!--------------------------------------------------------------------------------- 63 36 ! !!!namelist variables 37 INTEGER :: nit000_han ! First time step used for harmonic analysis 38 INTEGER :: nitend_han ! Last time step used for harmonic analysis 39 INTEGER :: nstep_han ! Time step frequency for harmonic analysis 40 INTEGER :: nb_ana ! Number of harmonics to analyse 41 42 INTEGER , ALLOCATABLE, DIMENSION(:) :: name 43 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ana_temp 44 REAL(wp), ALLOCATABLE, DIMENSION(:) :: ana_freq, ut , vt , ft 45 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: out_eta , out_u, out_v 46 47 INTEGER :: ninco, nsparse 48 INTEGER , DIMENSION(jpdimsparse) :: njsparse, nisparse 49 INTEGER , SAVE, DIMENSION(jpincomax) :: ipos1 50 REAL(wp), DIMENSION(jpdimsparse) :: valuesparse 51 REAL(wp), DIMENSION(jpincomax) :: ztmp4 , ztmp7 52 REAL(wp), SAVE, DIMENSION(jpincomax,jpincomax) :: ztmp3 , zpilier 53 REAL(wp), SAVE, DIMENSION(jpincomax) :: zpivot 54 55 CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: tname ! Names of tidal constituents ('M2', 'K1',...) 56 57 PUBLIC dia_harm ! routine called by step.F90 58 59 !!---------------------------------------------------------------------- 60 !! NEMO/OPA 3.5 , NEMO Consortium (2013) 61 !! $Id:$ 62 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 63 !!---------------------------------------------------------------------- 64 64 CONTAINS 65 65 … … 67 67 !!---------------------------------------------------------------------- 68 68 !! *** ROUTINE dia_harm_init *** 69 !!----------------------------------------------------------------------70 69 !! 71 70 !! ** Purpose : Initialization of tidal harmonic analysis … … 73 72 !! ** Method : Initialize frequency array and nodal factor for nit000_han 74 73 !! 75 !! History : 76 !! 9.0 O. Le Galloudec and J. Chanut (Original) 77 !!-------------------------------------------------------------------- 78 !! * Local declarations 74 !!-------------------------------------------------------------------- 79 75 INTEGER :: jh, nhan, jk, ji 80 76 INTEGER :: ios ! Local integer output status for namelist read … … 108 104 ! Basic checks on harmonic analysis time window: 109 105 ! ---------------------------------------------- 110 IF (nit000 > nit000_han) THEN 111 IF(lwp) WRITE(numout,*) ' E R R O R dia_harm_init : nit000_han must be greater than nit000, stop' 112 IF(lwp) WRITE(numout,*) ' restart capability not implemented' 113 nstop = nstop + 1 114 ENDIF 115 IF (nitend < nitend_han) THEN 116 IF(lwp) WRITE(numout,*) ' E R R O R dia_harm_init : nitend_han must be lower than nitend, stop' 117 IF(lwp) WRITE(numout,*) ' restart capability not implemented' 118 nstop = nstop + 1 119 ENDIF 120 121 IF (MOD(nitend_han-nit000_han+1,nstep_han).NE.0) THEN 122 IF(lwp) WRITE(numout,*) ' E R R O R dia_harm_init : analysis time span must be a multiple of nstep_han, stop' 123 nstop = nstop + 1 124 END IF 125 126 nb_ana=0 106 IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & 107 & ' restart capability not implemented' ) 108 IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & 109 & 'restart capability not implemented' ) 110 111 IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & 112 & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 113 114 nb_ana = 0 127 115 DO jk=1,jpmax_harmo 128 116 DO ji=1,jpmax_harmo … … 157 145 ! Initialize frequency array: 158 146 ! --------------------------- 159 ALLOCATE(ana_freq(nb_ana)) 160 ALLOCATE(vt (nb_ana)) 161 ALLOCATE(ut (nb_ana)) 162 ALLOCATE(ft (nb_ana)) 163 164 CALL tide_harmo(ana_freq, vt, ut , ft, name ,nb_ana) 147 ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) ) 148 149 CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana ) 165 150 166 151 IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency ' … … 172 157 ! Initialize temporary arrays: 173 158 ! ---------------------------- 174 ALLOCATE( ana_temp(jpi,jpj, nb_ana*2,3))159 ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) 175 160 ana_temp(:,:,:,:) = 0.e0 176 161 177 162 END SUBROUTINE dia_harm_init 178 163 164 179 165 SUBROUTINE dia_harm ( kt ) 180 166 !!---------------------------------------------------------------------- 181 167 !! *** ROUTINE dia_harm *** 182 !!----------------------------------------------------------------------183 168 !! 184 169 !! ** Purpose : Tidal harmonic analysis main routine … … 186 171 !! ** Action : Sums ssh/u/v over time analysis [nit000_han,nitend_han] 187 172 !! 188 !! History : 189 !! 9.0 O. Le Galloudec and J. Chanut (Original) 190 !!-------------------------------------------------------------------- 191 !! * Argument: 173 !!-------------------------------------------------------------------- 192 174 INTEGER, INTENT( IN ) :: kt 193 194 !! * Local declarations 175 ! 195 176 INTEGER :: ji, jj, jh, jc, nhc 196 177 REAL(wp) :: ztime, ztemp … … 198 179 IF( nn_timing == 1 ) CALL timing_start('dia_harm') 199 180 200 IF ( kt .EQ.nit000 ) CALL dia_harm_init181 IF ( kt == nit000 ) CALL dia_harm_init 201 182 202 183 IF ( ((kt.GE.nit000_han).AND.(kt.LE.nitend_han)).AND. & … … 215 196 DO ji = 1,jpi 216 197 ! Elevation 217 ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) & 218 + ztemp*sshn(ji,jj)*tmask(ji,jj,1) 198 ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj) *tmask(ji,jj,1) 219 199 #if defined key_dynspg_ts 220 ! ubar 221 ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) & 222 + ztemp*un_b(ji,jj)*hur(ji,jj)*umask(ji,jj,1) 223 ! vbar 224 ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) & 225 + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask(ji,jj,1) 200 ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*hur(ji,jj)*umask(ji,jj,1) 201 ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask(ji,jj,1) 226 202 #endif 227 203 END DO … … 233 209 END IF 234 210 235 IF ( kt .EQ. nitend_han )CALL dia_harm_end211 IF ( kt == nitend_han ) CALL dia_harm_end 236 212 237 213 IF( nn_timing == 1 ) CALL timing_stop('dia_harm') … … 239 215 END SUBROUTINE dia_harm 240 216 217 241 218 SUBROUTINE dia_harm_end 242 219 !!---------------------------------------------------------------------- 243 220 !! *** ROUTINE diaharm_end *** 244 !!----------------------------------------------------------------------245 221 !! 246 222 !! ** Purpose : Compute the Real and Imaginary part of tidal constituents … … 248 224 !! ** Action : Decompose the signal on the harmonic constituents 249 225 !! 250 !! History : 251 !! 9.0 O. Le Galloudec and J. Chanut (Original) 252 !!-------------------------------------------------------------------- 253 254 !! * Local declarations 226 !!-------------------------------------------------------------------- 255 227 INTEGER :: ji, jj, jh, jc, jn, nhan, jl 256 228 INTEGER :: ksp, kun, keq … … 283 255 nisparse(ksp) = keq 284 256 njsparse(ksp) = kun 285 valuesparse(ksp)= & 286 +( MOD(jc,2) * ft(jh) * COS(ana_freq(jh)*ztime + vt(jh) + ut(jh)) & 287 +(1.-MOD(jc,2))* ft(jh) * SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh))) 257 valuesparse(ksp) = ( MOD(jc,2) * ft(jh) * COS(ana_freq(jh)*ztime + vt(jh) + ut(jh)) & 258 & + (1.-MOD(jc,2))* ft(jh) * SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh)) ) 288 259 END DO 289 260 END DO 290 261 END DO 291 262 292 nsparse =ksp263 nsparse = ksp 293 264 294 265 ! Elevation: … … 296 267 DO ji = 1, jpi 297 268 ! Fill input array 298 kun =0299 DO jh = 1, nb_ana300 DO jc = 1, 2269 kun = 0 270 DO jh = 1, nb_ana 271 DO jc = 1, 2 301 272 kun = kun + 1 302 273 ztmp4(kun)=ana_temp(ji,jj,kun,1) 303 END DO304 END DO274 END DO 275 END DO 305 276 306 277 CALL SUR_DETERMINE(jj) … … 314 285 END DO 315 286 316 ALLOCATE( out_eta(jpi,jpj,2*nb_ana))317 ALLOCATE(out_u (jpi,jpj,2*nb_ana))318 ALLOCATE(out_v (jpi,jpj,2*nb_ana))287 ALLOCATE( out_eta(jpi,jpj,2*nb_ana), & 288 & out_u (jpi,jpj,2*nb_ana), & 289 & out_v (jpi,jpj,2*nb_ana) ) 319 290 320 291 DO jj = 1, jpj 321 292 DO ji = 1, jpi 322 293 DO jh = 1, nb_ana 323 X1 =ana_amp(ji,jj,jh,1)324 X2 =-ana_amp(ji,jj,jh,2)325 out_eta(ji,jj,jh )=X1 * tmask(ji,jj,1)326 out_eta(ji,jj, nb_ana+jh)=X2 * tmask(ji,jj,1)294 X1 = ana_amp(ji,jj,jh,1) 295 X2 =-ana_amp(ji,jj,jh,2) 296 out_eta(ji,jj,jh ) = X1 * tmask(ji,jj,1) 297 out_eta(ji,jj,jh+nb_ana) = X2 * tmask(ji,jj,1) 327 298 ENDDO 328 299 ENDDO … … 402 373 END SUBROUTINE dia_harm_end 403 374 375 404 376 SUBROUTINE dia_wri_harm 405 377 !!-------------------------------------------------------------------- 406 378 !! *** ROUTINE dia_wri_harm *** 407 !!--------------------------------------------------------------------408 379 !! 409 380 !! ** Purpose : Write tidal harmonic analysis results in a netcdf file 410 !! 411 !! 412 !! History : 413 !! 9.0 O. Le Galloudec and J. Chanut (Original) 414 !!-------------------------------------------------------------------- 415 416 !! * Local declarations 381 !!-------------------------------------------------------------------- 417 382 CHARACTER(LEN=lc) :: cltext 418 383 CHARACTER(LEN=lc) :: & … … 472 437 #else 473 438 DO jh = 1, nb_ana 474 CALL iom_put( TRIM(tname(jh))//'x_v', out_u(:,:,jh) )475 CALL iom_put( TRIM(tname(jh))//'y_v', out_u(:,:,nb_ana+jh) )439 CALL iom_put( TRIM(tname(jh))//'x_v', out_u(:,:,jh ) ) 440 CALL iom_put( TRIM(tname(jh))//'y_v', out_u(:,:,jh+nb_ana) ) 476 441 END DO 477 442 #endif 478 443 479 444 END SUBROUTINE dia_wri_harm 445 480 446 481 447 SUBROUTINE SUR_DETERMINE(init) … … 486 452 !! 487 453 !!--------------------------------------------------------------------------------- 488 INTEGER, INTENT(in) :: init489 454 INTEGER, INTENT(in) :: init 455 ! 490 456 INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, jk1_sd, jk2_sd 491 457 REAL(wp) :: zval1, zval2, zx1 … … 496 462 CALL wrk_alloc( jpincomax , ipos2 , ipivot ) 497 463 498 IF( init==1 )THEN 499 500 IF( nsparse .GT. jpdimsparse ) & 501 CALL ctl_stop( 'STOP', 'SUR_DETERMINE : nsparse .GT. jpdimsparse') 502 503 IF( ninco .GT. jpincomax ) & 504 CALL ctl_stop( 'STOP', 'SUR_DETERMINE : ninco .GT. jpincomax') 505 506 ztmp3(:,:)=0.e0 507 464 IF( init == 1 ) THEN 465 IF( nsparse > jpdimsparse ) CALL ctl_stop( 'STOP', 'SUR_DETERMINE : nsparse .GT. jpdimsparse') 466 IF( ninco > jpincomax ) CALL ctl_stop( 'STOP', 'SUR_DETERMINE : ninco .GT. jpincomax') 467 ! 468 ztmp3(:,:) = 0._wp 469 ! 508 470 DO jk1_sd = 1, nsparse 509 471 DO jk2_sd = 1, nsparse 510 511 nisparse(jk2_sd)=nisparse(jk2_sd) 512 njsparse(jk2_sd)=njsparse(jk2_sd) 513 472 nisparse(jk2_sd) = nisparse(jk2_sd) 473 njsparse(jk2_sd) = njsparse(jk2_sd) 514 474 IF( nisparse(jk2_sd) == nisparse(jk1_sd) ) THEN 515 475 ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) & 516 476 + valuesparse(jk1_sd)*valuesparse(jk2_sd) 517 477 ENDIF 518 519 ENDDO 520 ENDDO 478 END DO 479 END DO 521 480 522 481 DO jj_sd = 1 ,ninco … … 588 547 ENDDO 589 548 590 591 549 CALL wrk_dealloc( jpincomax , ztmpx , zcol1 , zcol2 ) 592 550 CALL wrk_dealloc( jpincomax , ipos2 , ipivot ) … … 594 552 END SUBROUTINE SUR_DETERMINE 595 553 596 597 554 #else 598 555 !!---------------------------------------------------------------------- … … 601 558 LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .FALSE. 602 559 CONTAINS 603 604 560 SUBROUTINE dia_harm ( kt ) ! Empty routine 605 561 INTEGER, INTENT( IN ) :: kt 606 562 WRITE(*,*) 'dia_harm: you should not have seen this print' 607 563 END SUBROUTINE dia_harm 608 609 610 #endif 564 #endif 565 611 566 !!====================================================================== 612 567 END MODULE diaharm -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diahth.F90
r3764 r4292 304 304 ! ----------------------------- ! 305 305 306 ! find ilevel with (ilevel+1) the deepest W-level above 300m (we assume we can use e3t_ 0to do this search...)306 ! find ilevel with (ilevel+1) the deepest W-level above 300m (we assume we can use e3t_1d to do this search...) 307 307 ilevel = 0 308 308 zthick_0 = 0._wp 309 309 DO jk = 1, jpkm1 310 zthick_0 = zthick_0 + e3t_ 0(jk)310 zthick_0 = zthick_0 + e3t_1d(jk) 311 311 IF( zthick_0 < 300. ) ilevel = jk 312 312 END DO … … 326 326 htc3(ji,jj) = htc3(ji,jj) + tsn(ji,jj,ilevel+1,jp_tem) * MIN( fse3t(ji,jj,ilevel+1), zthick(ji,jj) ) & 327 327 * tmask(ji,jj,ilevel+1) 328 htc3(ji,jj) = htc3(ji,jj) + tsn(ji,jj,ilevel+1,jp_tem) * MIN( fse3t(ji,jj,ilevel+1), zthick(ji,jj) ) &329 & * tmask(ji,jj,ilevel+1)330 328 END DO 331 329 END DO -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r4148 r4292 259 259 ! 260 260 #if defined key_mpp_mpi 261 ijpjjpk = jpj*jpk 261 262 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk 262 263 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) … … 314 315 END DO 315 316 #if defined key_mpp_mpi 317 ijpjjpk = jpj*jpk 316 318 ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk 317 319 zwork(1:ijpjjpk)= RESHAPE( p_fval, ish ) … … 670 672 CALL histbeg(clhstnam, 1, zfoo, jpj, zphi, & 671 673 1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr) 672 ! Vertical grids : gdept_ 0, gdepw_0674 ! Vertical grids : gdept_1d, gdepw_1d 673 675 CALL histvert( numptr, "deptht", "Vertical T levels", & 674 & "m", jpk, gdept_ 0, ndepidzt, "down" )676 & "m", jpk, gdept_1d, ndepidzt, "down" ) 675 677 CALL histvert( numptr, "depthw", "Vertical W levels", & 676 & "m", jpk, gdepw_ 0, ndepidzw, "down" )678 & "m", jpk, gdepw_1d, ndepidzw, "down" ) 677 679 ! 678 680 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex , ndim ) ! Lat-Depth -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r4161 r4292 25 25 USE oce ! ocean dynamics and tracers 26 26 USE dom_oce ! ocean space and time domain 27 USE dynadv, ONLY: ln_dynadv_vec 27 28 USE zdf_oce ! ocean vertical physics 28 29 USE ldftra_oce ! ocean active tracers: lateral physics … … 44 45 USE diadimg ! dimg direct access file format output 45 46 USE diaar5, ONLY : lk_diaar5 47 USE dynadv, ONLY : ln_dynadv_vec 46 48 USE iom 47 49 USE ioipsl … … 144 146 ENDIF 145 147 146 CALL iom_put( "toce" , tsn(:,:,:,jp_tem) ) ! temperature 147 CALL iom_put( "soce" , tsn(:,:,:,jp_sal) ) ! salinity 148 CALL iom_put( "sst" , tsn(:,:,1,jp_tem) ) ! sea surface temperature 149 CALL iom_put( "sst2" , tsn(:,:,1,jp_tem) * tsn(:,:,1,jp_tem) ) ! square of sea surface temperature 150 CALL iom_put( "sss" , tsn(:,:,1,jp_sal) ) ! sea surface salinity 151 CALL iom_put( "sss2" , tsn(:,:,1,jp_sal) * tsn(:,:,1,jp_sal) ) ! square of sea surface salinity 152 CALL iom_put( "uoce" , un ) ! i-current 153 CALL iom_put( "suoce" , un(:,:,1) ) ! surface i-current 154 CALL iom_put( "voce" , vn ) ! j-current 155 CALL iom_put( "svoce" , vn(:,:,1) ) ! surface j-current 156 157 CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. 158 CALL iom_put( "avm" , avmu ) ! T vert. eddy visc. coef. 148 IF( lk_vvl ) THEN 149 z3d(:,:,:) = tsn(:,:,:,jp_tem) * fse3t_n(:,:,:) 150 CALL iom_put( "toce" , z3d ) ! heat content 151 CALL iom_put( "sst" , z3d(:,:,1) ) ! sea surface heat content 152 z3d(:,:,1) = tsn(:,:,1,jp_tem) * z3d(:,:,1) 153 CALL iom_put( "sst2" , z3d(:,:,1) ) ! sea surface content of squared temperature 154 z3d(:,:,:) = tsn(:,:,:,jp_sal) * fse3t_n(:,:,:) 155 CALL iom_put( "soce" , z3d ) ! salinity content 156 CALL iom_put( "sss" , z3d(:,:,1) ) ! sea surface salinity content 157 z3d(:,:,1) = tsn(:,:,1,jp_sal) * z3d(:,:,1) 158 CALL iom_put( "sss2" , z3d(:,:,1) ) ! sea surface content of squared salinity 159 ELSE 160 CALL iom_put( "toce" , tsn(:,:,:,jp_tem) ) ! temperature 161 CALL iom_put( "sst" , tsn(:,:,1,jp_tem) ) ! sea surface temperature 162 CALL iom_put( "sst2" , tsn(:,:,1,jp_tem) * tsn(:,:,1,jp_tem) ) ! square of sea surface temperature 163 CALL iom_put( "soce" , tsn(:,:,:,jp_sal) ) ! salinity 164 CALL iom_put( "sss" , tsn(:,:,1,jp_sal) ) ! sea surface salinity 165 CALL iom_put( "sss2" , tsn(:,:,1,jp_sal) * tsn(:,:,1,jp_sal) ) ! square of sea surface salinity 166 END IF 167 IF( lk_vvl .AND. (.NOT. ln_dynadv_vec) ) THEN 168 CALL iom_put( "uoce" , un(:,:,:) * fse3u_n(:,:,:) ) ! i-transport 169 CALL iom_put( "voce" , vn(:,:,:) * fse3v_n(:,:,:) ) ! j-transport 170 ELSE 171 CALL iom_put( "uoce" , un ) ! i-current 172 CALL iom_put( "voce" , vn ) ! j-current 173 END IF 174 CALL iom_put( "avt" , avt ) ! T vert. eddy diff. coef. 175 CALL iom_put( "avm" , avmu ) ! T vert. eddy visc. coef. 159 176 IF( lk_zdfddm ) THEN 160 177 CALL iom_put( "avs" , fsavs(:,:,:) ) ! S vert. eddy diff. coef. … … 252 269 ! 253 270 CALL wrk_alloc( jpi , jpj , zw2d ) 254 IF ( ln_traldf_gdia ) call wrk_alloc( jpi , jpj , jpk , zw3d )271 IF ( ln_traldf_gdia .OR. lk_vvl ) call wrk_alloc( jpi , jpj , jpk , zw3d ) 255 272 ! 256 273 ! Output the initial state and forcings … … 325 342 & nit000-1, zjulian, zdt, nh_T, nid_T, domain_id=nidom, snc4chunks=snc4set ) 326 343 CALL histvert( nid_T, "deptht", "Vertical T levels", & ! Vertical grid: gdept 327 & "m", ipk, gdept_ 0, nz_T, "down" )344 & "m", ipk, gdept_1d, nz_T, "down" ) 328 345 ! ! Index of ocean points 329 346 CALL wheneq( jpi*jpj*ipk, tmask, 1, 1., ndex_T , ndim_T ) ! volume … … 361 378 & nit000-1, zjulian, zdt, nh_U, nid_U, domain_id=nidom, snc4chunks=snc4set ) 362 379 CALL histvert( nid_U, "depthu", "Vertical U levels", & ! Vertical grid: gdept 363 & "m", ipk, gdept_ 0, nz_U, "down" )380 & "m", ipk, gdept_1d, nz_U, "down" ) 364 381 ! ! Index of ocean points 365 382 CALL wheneq( jpi*jpj*ipk, umask, 1, 1., ndex_U , ndim_U ) ! volume … … 374 391 & nit000-1, zjulian, zdt, nh_V, nid_V, domain_id=nidom, snc4chunks=snc4set ) 375 392 CALL histvert( nid_V, "depthv", "Vertical V levels", & ! Vertical grid : gdept 376 & "m", ipk, gdept_ 0, nz_V, "down" )393 & "m", ipk, gdept_1d, nz_V, "down" ) 377 394 ! ! Index of ocean points 378 395 CALL wheneq( jpi*jpj*ipk, vmask, 1, 1., ndex_V , ndim_V ) ! volume … … 387 404 & nit000-1, zjulian, zdt, nh_W, nid_W, domain_id=nidom, snc4chunks=snc4set ) 388 405 CALL histvert( nid_W, "depthw", "Vertical W levels", & ! Vertical grid: gdepw 389 & "m", ipk, gdepw_ 0, nz_W, "down" )406 & "m", ipk, gdepw_1d, nz_W, "down" ) 390 407 391 408 … … 397 414 CALL histdef( nid_T, "vosaline", "Salinity" , "PSU" , & ! sn 398 415 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 416 IF( lk_vvl ) THEN 417 CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! e3t_n 418 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 419 CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! e3t_n 420 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 421 CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! e3t_n 422 & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) 423 ENDIF 399 424 ! !!! nid_T : 2D 400 425 CALL histdef( nid_T, "sosstsst", "Sea Surface temperature" , "C" , & ! sst … … 408 433 CALL histdef( nid_T, "sosfldow", "downward salt flux" , "PSU/m2/s", & ! sfx 409 434 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 410 #if ! defined key_vvl 411 CALL histdef( nid_T, "sosst_cd", "Concentration/Dilution term on temperature"& ! emp * tsn(:,:,1,jp_tem)435 IF( .NOT. lk_vvl ) THEN 436 CALL histdef( nid_T, "sosst_cd", "Concentration/Dilution term on temperature" & ! emp * tsn(:,:,1,jp_tem) 412 437 & , "KgC/m2/s", & ! sosst_cd 413 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )414 CALL histdef( nid_T, "sosss_cd", "Concentration/Dilution term on salinity"& ! emp * tsn(:,:,1,jp_sal)438 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 439 CALL histdef( nid_T, "sosss_cd", "Concentration/Dilution term on salinity" & ! emp * tsn(:,:,1,jp_sal) 415 440 & , "KgPSU/m2/s",& ! sosss_cd 416 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout )417 #endif 441 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 442 ENDIF 418 443 CALL histdef( nid_T, "sohefldo", "Net Downward Heat Flux" , "W/m2" , & ! qns + qsr 419 444 & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) … … 587 612 ! --------------------- 588 613 589 ! ndex(1) est utilise ssi l'avant dernier argument est diff ferent de614 ! ndex(1) est utilise ssi l'avant dernier argument est different de 590 615 ! la taille du tableau en sortie. Dans ce cas , l'avant dernier argument 591 616 ! donne le nombre d'elements, et ndex la liste des indices a sortir … … 597 622 598 623 ! Write fields on T grid 599 CALL histwrite( nid_T, "votemper", it, tsn(:,:,:,jp_tem), ndim_T , ndex_T ) ! temperature 600 CALL histwrite( nid_T, "vosaline", it, tsn(:,:,:,jp_sal), ndim_T , ndex_T ) ! salinity 601 CALL histwrite( nid_T, "sosstsst", it, tsn(:,:,1,jp_tem), ndim_hT, ndex_hT ) ! sea surface temperature 602 CALL histwrite( nid_T, "sosaline", it, tsn(:,:,1,jp_sal), ndim_hT, ndex_hT ) ! sea surface salinity 624 IF( lk_vvl ) THEN 625 CALL histwrite( nid_T, "votemper", it, tsn(:,:,:,jp_tem) * fse3t_n(:,:,:) , ndim_T , ndex_T ) ! heat content 626 CALL histwrite( nid_T, "vosaline", it, tsn(:,:,:,jp_sal) * fse3t_n(:,:,:) , ndim_T , ndex_T ) ! salt content 627 CALL histwrite( nid_T, "sosstsst", it, tsn(:,:,1,jp_tem) * fse3t_n(:,:,1) , ndim_hT, ndex_hT ) ! sea surface heat content 628 CALL histwrite( nid_T, "sosaline", it, tsn(:,:,1,jp_sal) * fse3t_n(:,:,1) , ndim_hT, ndex_hT ) ! sea surface salinity content 629 ELSE 630 CALL histwrite( nid_T, "votemper", it, tsn(:,:,:,jp_tem) , ndim_T , ndex_T ) ! temperature 631 CALL histwrite( nid_T, "vosaline", it, tsn(:,:,:,jp_sal) , ndim_T , ndex_T ) ! salinity 632 CALL histwrite( nid_T, "sosstsst", it, tsn(:,:,1,jp_tem) , ndim_hT, ndex_hT ) ! sea surface temperature 633 CALL histwrite( nid_T, "sosaline", it, tsn(:,:,1,jp_sal) , ndim_hT, ndex_hT ) ! sea surface salinity 634 635 ENDIF 636 IF( lk_vvl ) THEN 637 zw3d(:,:,:) = ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 638 CALL histwrite( nid_T, "vovvle3t", it, fse3t_n (:,:,:) , ndim_T , ndex_T ) ! level thickness 639 CALL histwrite( nid_T, "vovvldep", it, fsdept_n(:,:,:) , ndim_T , ndex_T ) ! t-point depth 640 CALL histwrite( nid_T, "vovvldef", it, zw3d , ndim_T , ndex_T ) ! level thickness deformation 641 ENDIF 603 642 CALL histwrite( nid_T, "sossheig", it, sshn , ndim_hT, ndex_hT ) ! sea surface height 604 643 CALL histwrite( nid_T, "sowaflup", it, ( emp-rnf ) , ndim_hT, ndex_hT ) ! upward water flux … … 606 645 ! (includes virtual salt flux beneath ice 607 646 ! in linear free surface case) 608 #if ! defined key_vvl 609 zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_tem)610 CALL histwrite( nid_T, "sosst_cd", it, zw2d, ndim_hT, ndex_hT )! c/d term on sst611 zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_sal)612 CALL histwrite( nid_T, "sosss_cd", it, zw2d, ndim_hT, ndex_hT )! c/d term on sss613 #endif 647 IF( .NOT. lk_vvl ) THEN 648 zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_tem) 649 CALL histwrite( nid_T, "sosst_cd", it, zw2d, ndim_hT, ndex_hT ) ! c/d term on sst 650 zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_sal) 651 CALL histwrite( nid_T, "sosss_cd", it, zw2d, ndim_hT, ndex_hT ) ! c/d term on sss 652 ENDIF 614 653 CALL histwrite( nid_T, "sohefldo", it, qns + qsr , ndim_hT, ndex_hT ) ! total heat flux 615 654 CALL histwrite( nid_T, "soshfldo", it, qsr , ndim_hT, ndex_hT ) ! solar heat flux … … 752 791 ! 753 792 CALL wrk_dealloc( jpi , jpj , zw2d ) 754 IF ( ln_traldf_gdia ) call wrk_dealloc( jpi , jpj , jpk , zw3d )793 IF ( ln_traldf_gdia .OR. lk_vvl ) call wrk_dealloc( jpi , jpj , jpk , zw3d ) 755 794 ! 756 795 IF( nn_timing == 1 ) CALL timing_stop('dia_wri') … … 813 852 1, jpi, 1, jpj, nit000-1, zjulian, zdt, nh_i, id_i, domain_id=nidom, snc4chunks=snc4set ) ! Horizontal grid : glamt and gphit 814 853 CALL histvert( id_i, "deptht", "Vertical T levels", & ! Vertical grid : gdept 815 "m", jpk, gdept_ 0, nz_i, "down")854 "m", jpk, gdept_1d, nz_i, "down") 816 855 817 856 ! Declare all the output fields as NetCDF variables … … 841 880 CALL histdef( id_i, "sometauy", "Meridional Wind Stress", "N/m2" , & ! j-wind stress 842 881 & jpi, jpj, nh_i, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) 882 IF( lk_vvl ) THEN 883 CALL histdef( id_i, "vovvldep", "T point depth" , "m" , & ! t-point depth 884 & jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 885 END IF 843 886 844 887 #if defined key_lim2 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90
r4247 r4292 152 152 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gphit, gphiu !: latitude of t-, u-, v- and f-points (degre) 153 153 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: gphiv, gphif !: 154 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e1t, e2t !: horizontal scale factors at t-point (m)155 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e1u, e2u !: horizontal scale factors at u-point (m)156 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e1v, e2v !: horizontal scale factors at v-point (m)157 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e1f, e2f !: horizontal scale factors at f-point (m)154 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1t, e2t !: horizontal scale factors at t-point (m) 155 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u, e2u !: horizontal scale factors at u-point (m) 156 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1v, e2v !: horizontal scale factors at v-point (m) 157 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f, e2f !: horizontal scale factors at f-point (m) 158 158 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e1e2t !: surface at t-point (m2) 159 159 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ff !: coriolis factor (2.*omega*sin(yphi) ) (s-1) … … 169 169 !! All coordinates 170 170 !! --------------- 171 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdep3w !: depth of T-points (sum of e3w) (m)172 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept , gdepw !: analytical depth at T-Wpoints (m)173 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3v , e3f !: analytical vertical scale factors at V--F174 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t , e3u !: T--Upoints (m)175 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw !: analytical vertical scale factors at VW--176 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w , e3uw !: W--UWpoints (m)171 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdep3w_0 !: depth of t-points (sum of e3w) (m) 172 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0, gdepw_0 !: analytical (time invariant) depth at t-w points (m) 173 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3v_0 , e3f_0 !: analytical (time invariant) vertical scale factors at v-f 174 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_0 , e3u_0 !: t-u points (m) 175 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0 !: analytical (time invariant) vertical scale factors at vw 176 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w_0 , e3uw_0 !: w-uw points (m) 177 177 #if defined key_vvl 178 178 LOGICAL, PUBLIC, PARAMETER :: lk_vvl = .TRUE. !: variable grid flag … … 180 180 !! All coordinates 181 181 !! --------------- 182 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdep3w_1 !: depth of T-points (sum of e3w) (m) 183 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_1, gdepw_1 !: analytical depth at T-W points (m) 184 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3v_1 , e3f_1 !: analytical vertical scale factors at V--F 185 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_1 , e3u_1 !: T--U points (m) 186 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_1 !: analytical vertical scale factors at VW-- 187 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w_1 , e3uw_1 !: W--UW points (m) 188 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_b !: before - - - - T points (m) 189 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_b , e3v_b !: - - - - - U--V points (m) 182 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdep3w_n !: now depth of T-points (sum of e3w) (m) 183 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_n, gdepw_n !: now depth at T-W points (m) 184 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_n !: now vertical scale factors at t point (m) 185 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_n , e3v_n !: - - - - u --v points (m) 186 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w_n , e3f_n !: - - - - w --f points (m) 187 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_n , e3vw_n !: - - - - uw--vw points (m) 188 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_b !: before - - - - t points (m) 189 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_b , e3v_b !: - - - - - u --v points (m) 190 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_b , e3vw_b !: - - - - - uw--vw points (m) 191 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_a !: after - - - - t point (m) 192 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_a , e3v_a !: - - - - - u --v points (m) 190 193 #else 191 194 LOGICAL, PUBLIC, PARAMETER :: lk_vvl = .FALSE. !: fixed grid flag 192 195 #endif 193 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: hur , hvr !: inverse of u and v-points ocean depth (1/m) 194 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu , hv !: depth at u- and v-points (meters) 195 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0 , hv_0 !: refernce depth at u- and v-points (meters) 196 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: hur , hvr !: inverse of u and v-points ocean depth (1/m) 197 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu , hv !: depth at u- and v-points (meters) 198 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0 !: reference depth at t- points (meters) 199 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0 , hv_0 !: reference depth at u- and v-points (meters) 200 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: re2u_e1u !: scale factor coeffs at u points (e2u/e1u) 201 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: re1v_e2v !: scale factor coeffs at v points (e1v/e2v) 202 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e12t , r1_e12t !: horizontal cell surface and inverse at t points 203 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e12u , r1_e12u !: horizontal cell surface and inverse at u points 204 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e12v , r1_e12v !: horizontal cell surface and inverse at v points 205 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e12f , r1_e12f !: horizontal cell surface and inverse at f points 196 206 197 207 INTEGER, PUBLIC :: nla10 !: deepest W level Above ~10m (nlb10 - 1) … … 200 210 !! z-coordinate with full steps (also used in the other cases as reference z-coordinate) 201 211 !! =-----------------====------ 202 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gdept_0, gdepw_0!: reference depth of t- and w-points (m)203 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_0 , e3w_0!: reference vertical scale factors at T- and W-pts (m)204 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3tp , e3wp!: ocean bottom level thickness at T and W points212 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gdept_1d, gdepw_1d !: reference depth of t- and w-points (m) 213 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_1d , e3w_1d !: reference vertical scale factors at T- and W-pts (m) 214 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3tp , e3wp !: ocean bottom level thickness at T and W points 205 215 206 216 !! s-coordinate and hybrid z-s-coordinate 207 217 !! =----------------======--------------- 208 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gsigt, gsigw!: model level depth coefficient at t-, w-levels (analytic)209 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gsi3w!: model level depth coefficient at w-level (sum of gsigw)210 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: esigt, esigw!: vertical scale factor coef. at t-, w-levels211 212 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbatv , hbatf !: ocean depth at the vertical of V--F213 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbatt , hbatu !: T--Upoints (m)214 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: scosrf, scobot !: ocean surface and bottom topographies215 ! ! (if deviating from coordinate surfaces in HYBRID)216 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hifv , hiff !: interface depth between stretching at V--F217 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hift , hifu !: and quasi-uniform spacing T--Upoints (m)218 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rx1 !: Maximum grid stiffness ratio218 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gsigt, gsigw !: model level depth coefficient at t-, w-levels (analytic) 219 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gsi3w !: model level depth coefficient at w-level (sum of gsigw) 220 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: esigt, esigw !: vertical scale factor coef. at t-, w-levels 221 222 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbatv , hbatf !: ocean depth at the vertical of v--f 223 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbatt , hbatu !: t--u points (m) 224 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: scosrf, scobot !: ocean surface and bottom topographies 225 ! ! (if deviating from coordinate surfaces in HYBRID) 226 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hifv , hiff !: interface depth between stretching at v--f 227 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hift , hifu !: and quasi-uniform spacing t--u points (m) 228 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rx1 !: Maximum grid stiffness ratio 219 229 220 230 !!---------------------------------------------------------------------- 221 231 !! masks, bathymetry 222 232 !! --------------------------------------------------------------------- 223 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbathy !: number of ocean level (=0, 1, ... , jpk-1)224 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt !: vertical index of the bottom last T- ocean level225 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbku, mbkv !: vertical index of the bottom last U- and W- ocean level226 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bathy !: ocean depth (meters)227 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior domain T-point mask228 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bmask !: land/ocean mask of barotropic stream function229 230 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tmask, umask, vmask, fmask !: land/ocean mask at T-, U-, V- and F-pts233 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbathy !: number of ocean level (=0, 1, ... , jpk-1) 234 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbkt !: vertical index of the bottom last T- ocean level 235 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mbku, mbkv !: vertical index of the bottom last U- and W- ocean level 236 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bathy !: ocean depth (meters) 237 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior domain T-point mask 238 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: bmask !: land/ocean mask of barotropic stream function 239 240 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: tmask, umask, vmask, fmask !: land/ocean mask at T-, U-, V- and F-pts 231 241 232 242 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tpol, fpol !: north fold mask (jperio= 3 or 4) 233 243 234 244 #if defined key_noslip_accurate 235 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,: ) :: npcoa!: ???236 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: nicoa, njcoa!: ???245 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,: ) :: npcoa !: ??? 246 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: nicoa, njcoa !: ??? 237 247 #endif 238 248 … … 316 326 & glamf(jpi,jpj) , gphif(jpi,jpj) , e1f(jpi,jpj) , e2f(jpi,jpj) , ff (jpi,jpj) , STAT=ierr(3) ) 317 327 ! 318 ALLOCATE( gdep3w (jpi,jpj,jpk) , e3v(jpi,jpj,jpk) , e3f(jpi,jpj,jpk) , &319 & gdept (jpi,jpj,jpk) , e3t(jpi,jpj,jpk) , e3u(jpi,jpj,jpk) , &320 & gdepw (jpi,jpj,jpk) , e3w(jpi,jpj,jpk) , e3vw(jpi,jpj,jpk) , e3uw(jpi,jpj,jpk) , STAT=ierr(4) )328 ALLOCATE( gdep3w_0(jpi,jpj,jpk) , e3v_0(jpi,jpj,jpk) , e3f_0 (jpi,jpj,jpk) , & 329 & gdept_0 (jpi,jpj,jpk) , e3t_0(jpi,jpj,jpk) , e3u_0 (jpi,jpj,jpk) , & 330 & gdepw_0 (jpi,jpj,jpk) , e3w_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , e3uw_0(jpi,jpj,jpk) , STAT=ierr(4) ) 321 331 ! 322 332 #if defined key_vvl 323 ALLOCATE( gdep3w_1(jpi,jpj,jpk) , e3v_1(jpi,jpj,jpk) , e3f_1 (jpi,jpj,jpk) , & 324 & gdept_1 (jpi,jpj,jpk) , e3t_1(jpi,jpj,jpk) , e3u_1 (jpi,jpj,jpk) , & 325 & gdepw_1 (jpi,jpj,jpk) , e3w_1(jpi,jpj,jpk) , e3vw_1(jpi,jpj,jpk) , e3uw_1(jpi,jpj,jpk) , & 326 & e3t_b (jpi,jpj,jpk) , e3u_b(jpi,jpj,jpk) , e3v_b (jpi,jpj,jpk) , STAT=ierr(5) ) 327 #endif 328 ! 329 ALLOCATE( hu(jpi,jpj) , hur(jpi,jpj) , hu_0(jpi,jpj) , & 330 & hv(jpi,jpj) , hvr(jpi,jpj) , hv_0(jpi,jpj) , STAT=ierr(6) ) 331 ! 332 ALLOCATE( gdept_0(jpk) , gdepw_0(jpk) , & 333 & e3t_0 (jpk) , e3w_0 (jpk) , e3tp (jpi,jpj), e3wp(jpi,jpj) , & 334 & gsigt (jpk) , gsigw (jpk) , gsi3w(jpk) , & 335 & esigt (jpk) , esigw (jpk) , STAT=ierr(7) ) 333 ALLOCATE( gdep3w_n(jpi,jpj,jpk) , e3t_n (jpi,jpj,jpk) , e3u_n (jpi,jpj,jpk) , & 334 & gdept_n (jpi,jpj,jpk) , e3v_n (jpi,jpj,jpk) , e3w_n (jpi,jpj,jpk) , & 335 & gdepw_n (jpi,jpj,jpk) , e3f_n (jpi,jpj,jpk) , e3vw_n(jpi,jpj,jpk) , e3uw_n(jpi,jpj,jpk) , & 336 & e3t_b (jpi,jpj,jpk) , e3u_b (jpi,jpj,jpk) , e3v_b (jpi,jpj,jpk) , & 337 & e3uw_b (jpi,jpj,jpk) , e3vw_b(jpi,jpj,jpk) , & 338 & e3t_a (jpi,jpj,jpk) , e3u_a (jpi,jpj,jpk) , e3v_a (jpi,jpj,jpk) , STAT=ierr(5) ) 339 #endif 340 ! 341 ALLOCATE( hu (jpi,jpj) , hur (jpi,jpj) , hu_0(jpi,jpj) , ht_0 (jpi,jpj) , & 342 & hv (jpi,jpj) , hvr (jpi,jpj) , hv_0(jpi,jpj) , & 343 & re2u_e1u(jpi,jpj) , re1v_e2v(jpi,jpj) , & 344 & e12t (jpi,jpj) , r1_e12t (jpi,jpj) , & 345 & e12u (jpi,jpj) , r1_e12u (jpi,jpj) , & 346 & e12v (jpi,jpj) , r1_e12v (jpi,jpj) , & 347 & e12f (jpi,jpj) , r1_e12f (jpi,jpj) , STAT=ierr(6) ) 348 ! 349 ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , & 350 & e3t_1d (jpk) , e3w_1d (jpk) , e3tp (jpi,jpj), e3wp(jpi,jpj) , & 351 & gsigt (jpk) , gsigw (jpk) , gsi3w(jpk) , & 352 & esigt (jpk) , esigw (jpk) , STAT=ierr(7) ) 336 353 ! 337 354 ALLOCATE( hbatv (jpi,jpj) , hbatf (jpi,jpj) , & -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90
r4245 r4292 87 87 CALL dom_msk ! Masks 88 88 IF( ln_sco ) CALL dom_stiff ! Maximum stiffness ratio/hydrostatic consistency 89 IF( lk_vvl ) CALL dom_vvl! Vertical variable mesh89 IF( lk_vvl ) CALL dom_vvl_init ! Vertical variable mesh 90 90 ! 91 91 IF( lk_c1d ) CALL cor_c1d ! 1D configuration: Coriolis set at T-point 92 ! 93 ! - ML - Used in dom_vvl_sf_nxt and lateral diffusion routines 94 ! but could be usefull in many other routines 95 e12t (:,:) = e1t(:,:) * e2t(:,:) 96 e12u (:,:) = e1u(:,:) * e2u(:,:) 97 e12v (:,:) = e1v(:,:) * e2v(:,:) 98 e12f (:,:) = e1f(:,:) * e2f(:,:) 99 r1_e12t (:,:) = 1._wp / e12t(:,:) 100 r1_e12u (:,:) = 1._wp / e12u(:,:) 101 r1_e12v (:,:) = 1._wp / e12v(:,:) 102 r1_e12f (:,:) = 1._wp / e12f(:,:) 103 re2u_e1u(:,:) = e2u(:,:) / e1u(:,:) 104 re1v_e2v(:,:) = e1v(:,:) / e2v(:,:) 92 105 ! 93 106 hu(:,:) = 0._wp ! Ocean depth at U- and V-points 94 107 hv(:,:) = 0._wp 95 108 DO jk = 1, jpk 96 hu(:,:) = hu(:,:) + fse3u (:,:,jk) * umask(:,:,jk)97 hv(:,:) = hv(:,:) + fse3v (:,:,jk) * vmask(:,:,jk)109 hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk) 110 hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk) 98 111 END DO 99 112 ! ! Inverse of the local depth … … 407 420 DO jj = 2, jpjm1 408 421 DO jk = 1, jpkm1 409 zr1(1) = umask(ji-1,jj ,jk) *abs( (gdepw (ji ,jj ,jk )-gdepw(ji-1,jj ,jk ) &410 & +gdepw (ji ,jj ,jk+1)-gdepw(ji-1,jj ,jk+1)) &411 & /(gdepw (ji ,jj ,jk )+gdepw(ji-1,jj ,jk ) &412 & -gdepw (ji ,jj ,jk+1)-gdepw(ji-1,jj ,jk+1) + rsmall) )413 zr1(2) = umask(ji ,jj ,jk) *abs( (gdepw (ji+1,jj ,jk )-gdepw(ji ,jj ,jk ) &414 & +gdepw (ji+1,jj ,jk+1)-gdepw(ji ,jj ,jk+1)) &415 & /(gdepw (ji+1,jj ,jk )+gdepw(ji ,jj ,jk ) &416 & -gdepw (ji+1,jj ,jk+1)-gdepw(ji ,jj ,jk+1) + rsmall) )417 zr1(3) = vmask(ji ,jj ,jk) *abs( (gdepw (ji ,jj+1,jk )-gdepw(ji ,jj ,jk ) &418 & +gdepw (ji ,jj+1,jk+1)-gdepw(ji ,jj ,jk+1)) &419 & /(gdepw (ji ,jj+1,jk )+gdepw(ji ,jj ,jk ) &420 & -gdepw (ji ,jj+1,jk+1)-gdepw(ji ,jj ,jk+1) + rsmall) )421 zr1(4) = vmask(ji ,jj-1,jk) *abs( (gdepw (ji ,jj ,jk )-gdepw(ji ,jj-1,jk ) &422 & +gdepw (ji ,jj ,jk+1)-gdepw(ji ,jj-1,jk+1)) &423 & /(gdepw (ji ,jj ,jk )+gdepw(ji ,jj-1,jk ) &424 & -gdepw (ji, jj ,jk+1)-gdepw(ji ,jj-1,jk+1) + rsmall) )422 zr1(1) = umask(ji-1,jj ,jk) *abs( (gdepw_0(ji ,jj ,jk )-gdepw_0(ji-1,jj ,jk ) & 423 & +gdepw_0(ji ,jj ,jk+1)-gdepw_0(ji-1,jj ,jk+1)) & 424 & /(gdepw_0(ji ,jj ,jk )+gdepw_0(ji-1,jj ,jk ) & 425 & -gdepw_0(ji ,jj ,jk+1)-gdepw_0(ji-1,jj ,jk+1) + rsmall) ) 426 zr1(2) = umask(ji ,jj ,jk) *abs( (gdepw_0(ji+1,jj ,jk )-gdepw_0(ji ,jj ,jk ) & 427 & +gdepw_0(ji+1,jj ,jk+1)-gdepw_0(ji ,jj ,jk+1)) & 428 & /(gdepw_0(ji+1,jj ,jk )+gdepw_0(ji ,jj ,jk ) & 429 & -gdepw_0(ji+1,jj ,jk+1)-gdepw_0(ji ,jj ,jk+1) + rsmall) ) 430 zr1(3) = vmask(ji ,jj ,jk) *abs( (gdepw_0(ji ,jj+1,jk )-gdepw_0(ji ,jj ,jk ) & 431 & +gdepw_0(ji ,jj+1,jk+1)-gdepw_0(ji ,jj ,jk+1)) & 432 & /(gdepw_0(ji ,jj+1,jk )+gdepw_0(ji ,jj ,jk ) & 433 & -gdepw_0(ji ,jj+1,jk+1)-gdepw_0(ji ,jj ,jk+1) + rsmall) ) 434 zr1(4) = vmask(ji ,jj-1,jk) *abs( (gdepw_0(ji ,jj ,jk )-gdepw_0(ji ,jj-1,jk ) & 435 & +gdepw_0(ji ,jj ,jk+1)-gdepw_0(ji ,jj-1,jk+1)) & 436 & /(gdepw_0(ji ,jj ,jk )+gdepw_0(ji ,jj-1,jk ) & 437 & -gdepw_0(ji, jj ,jk+1)-gdepw_0(ji ,jj-1,jk+1) + rsmall) ) 425 438 zrxmax = MAXVAL(zr1(1:4)) 426 439 rx1(ji,jj) = MAX(rx1(ji,jj), zrxmax) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domstp.F90
r2715 r4292 90 90 91 91 DO jk = 1, jpk 92 IF( gdept_ 0(jk) <= rdth ) rdttra(jk) = rdtmin93 IF( gdept_ 0(jk) > rdth ) THEN92 IF( gdept_1d(jk) <= rdth ) rdttra(jk) = rdtmin 93 IF( gdept_1d(jk) > rdth ) THEN 94 94 rdttra(jk) = rdtmin + ( rdtmax - rdtmin ) & 95 * ( EXP( ( gdept_ 0(jk ) - rdth ) / rdth ) - 1. ) &96 / ( EXP( ( gdept_ 0(jpk) - rdth ) / rdth ) - 1. )95 * ( EXP( ( gdept_1d(jk ) - rdth ) / rdth ) - 1. ) & 96 / ( EXP( ( gdept_1d(jpk) - rdth ) / rdth ) - 1. ) 97 97 ENDIF 98 98 IF(lwp) WRITE(numout,"(36x,f5.2,5x,i3)") rdttra(jk)/3600., jk -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r4153 r4292 6 6 !! History : 2.0 ! 2006-06 (B. Levier, L. Marie) original code 7 7 !! 3.1 ! 2009-02 (G. Madec, M. Leclair, R. Benshila) pure z* coordinate 8 !! ----------------------------------------------------------------------9 #if defined key_vvl 8 !! 3.3 ! 2011-10 (M. Leclair) totally rewrote domvvl: 9 !! vvl option includes z_star and z_tilde coordinates 10 10 !!---------------------------------------------------------------------- 11 11 !! 'key_vvl' variable volume 12 12 !!---------------------------------------------------------------------- 13 !! dom_vvl : defined coefficients to distribute ssh on each layers14 13 !!---------------------------------------------------------------------- 14 !! dom_vvl_init : define initial vertical scale factors, depths and column thickness 15 !! dom_vvl_sf_nxt : Compute next vertical scale factors 16 !! dom_vvl_sf_swp : Swap vertical scale factors and update the vertical grid 17 !! dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another 18 !! dom_vvl_rst : read/write restart file 19 !! dom_vvl_ctl : Check the vvl options 20 !! dom_vvl_orca_fix : Recompute some area-weighted interpolations of vertical scale factors 21 !! : to account for manual changes to e[1,2][u,v] in some Straits 22 !!---------------------------------------------------------------------- 23 !! * Modules used 15 24 USE oce ! ocean dynamics and tracers 16 25 USE dom_oce ! ocean space and time domain 17 USE sbc_oce ! surface boundary condition: ocean 18 USE phycst ! physical constants 26 USE sbc_oce ! ocean surface boundary condition 19 27 USE in_out_manager ! I/O manager 28 USE iom ! I/O manager library 29 USE restart ! ocean restart 20 30 USE lib_mpp ! distributed memory computing library 21 31 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 26 36 PRIVATE 27 37 28 PUBLIC dom_vvl ! called by domain.F90 29 PUBLIC dom_vvl_2 ! called by domain.F90 30 PUBLIC dom_vvl_alloc ! called by nemogcm.F90 31 32 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: mut , muu , muv , muf !: 1/H_0 at t-,u-,v-,f-points 33 34 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: r2dt ! vertical profile time-step, = 2 rdttra 35 ! ! except at nit000 (=rdttra) if neuler=0 38 !! * Routine accessibility 39 PUBLIC dom_vvl_init ! called by domain.F90 40 PUBLIC dom_vvl_sf_nxt ! called by step.F90 41 PUBLIC dom_vvl_sf_swp ! called by step.F90 42 PUBLIC dom_vvl_interpol ! called by dynnxt.F90 43 PRIVATE dom_vvl_orca_fix ! called by dom_vvl_interpol 44 45 !!* Namelist nam_vvl 46 LOGICAL , PUBLIC :: ln_vvl_zstar = .FALSE. ! zstar vertical coordinate 47 LOGICAL , PUBLIC :: ln_vvl_ztilde = .FALSE. ! ztilde vertical coordinate 48 LOGICAL , PUBLIC :: ln_vvl_layer = .FALSE. ! level vertical coordinate 49 LOGICAL , PUBLIC :: ln_vvl_ztilde_as_zstar = .FALSE. ! ztilde vertical coordinate 50 LOGICAL , PUBLIC :: ln_vvl_zstar_at_eqtor = .FALSE. ! ztilde vertical coordinate 51 LOGICAL , PUBLIC :: ln_vvl_kepe = .FALSE. ! kinetic/potential energy transfer 52 ! ! conservation: not used yet 53 REAL(wp) :: rn_ahe3 = 0.0_wp ! thickness diffusion coefficient 54 REAL(wp) :: rn_rst_e3t = 30._wp ! ztilde to zstar restoration timescale [days] 55 REAL(wp) :: rn_lf_cutoff = 5.0_wp ! cutoff frequency for low-pass filter [days] 56 REAL(wp) :: rn_zdef_max = 0.9_wp ! maximum fractional e3t deformation 57 LOGICAL , PUBLIC :: ln_vvl_dbg = .FALSE. ! debug control prints 58 59 !! * Module variables 60 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: un_td, vn_td ! thickness diffusion transport 61 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv_lf ! low frequency part of hz divergence 62 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_b, tilde_e3t_n ! baroclinic scale factors 63 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tilde_e3t_a ! baroclinic scale factors 64 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_e3t ! retoring period for scale factors 65 REAL(wp) , ALLOCATABLE, SAVE, DIMENSION(:,:) :: frq_rst_hdv ! retoring period for low freq. divergence 36 66 37 67 !! * Substitutions … … 39 69 # include "vectopt_loop_substitute.h90" 40 70 !!---------------------------------------------------------------------- 41 !! NEMO/OPA 4.0 , NEMO Consortium (2011)71 !! NEMO/OPA 3.3 , NEMO-Consortium (2010) 42 72 !! $Id$ 43 73 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 44 74 !!---------------------------------------------------------------------- 45 CONTAINS 75 76 CONTAINS 46 77 47 78 INTEGER FUNCTION dom_vvl_alloc() 48 79 !!---------------------------------------------------------------------- 49 !! *** ROUTINE dom_vvl_alloc *** 50 !!---------------------------------------------------------------------- 80 !! *** FUNCTION dom_vvl_alloc *** 81 !!---------------------------------------------------------------------- 82 IF( ln_vvl_zstar ) dom_vvl_alloc = 0 83 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 84 ALLOCATE( tilde_e3t_b(jpi,jpj,jpk) , tilde_e3t_n(jpi,jpj,jpk) , tilde_e3t_a(jpi,jpj,jpk) , & 85 & un_td (jpi,jpj,jpk) , vn_td (jpi,jpj,jpk) , STAT = dom_vvl_alloc ) 86 IF( lk_mpp ) CALL mpp_sum ( dom_vvl_alloc ) 87 IF( dom_vvl_alloc /= 0 ) CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays') 88 un_td = 0.0_wp 89 vn_td = 0.0_wp 90 ENDIF 91 IF( ln_vvl_ztilde ) THEN 92 ALLOCATE( frq_rst_e3t(jpi,jpj) , frq_rst_hdv(jpi,jpj) , hdiv_lf(jpi,jpj,jpk) , STAT= dom_vvl_alloc ) 93 IF( lk_mpp ) CALL mpp_sum ( dom_vvl_alloc ) 94 IF( dom_vvl_alloc /= 0 ) CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays') 95 ENDIF 96 97 END FUNCTION dom_vvl_alloc 98 99 100 SUBROUTINE dom_vvl_init 101 !!---------------------------------------------------------------------- 102 !! *** ROUTINE dom_vvl_init *** 103 !! 104 !! ** Purpose : Initialization of all scale factors, depths 105 !! and water column heights 106 !! 107 !! ** Method : - use restart file and/or initialize 108 !! - interpolate scale factors 109 !! 110 !! ** Action : - fse3t_(n/b) and tilde_e3t_(n/b) 111 !! - Regrid: fse3(u/v)_n 112 !! fse3(u/v)_b 113 !! fse3w_n 114 !! fse3(u/v)w_b 115 !! fse3(u/v)w_n 116 !! fsdept_n, fsdepw_n and fsde3w_n 117 !! - h(t/u/v)_0 118 !! - frq_rst_e3t and frq_rst_hdv 119 !! 120 !! Reference : Leclair, M., and G. Madec, 2011, Ocean Modelling. 121 !!---------------------------------------------------------------------- 122 USE phycst, ONLY : rpi, rsmall, rad 123 !! * Local declarations 124 INTEGER :: ji,jj,jk 125 INTEGER :: ii0, ii1, ij0, ij1 126 !!---------------------------------------------------------------------- 127 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_init') 128 129 IF(lwp) WRITE(numout,*) 130 IF(lwp) WRITE(numout,*) 'dom_vvl_init : Variable volume activated' 131 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' 132 133 ! choose vertical coordinate (z_star, z_tilde or layer) 134 ! ========================== 135 CALL dom_vvl_ctl 136 137 ! Allocate module arrays 138 ! ====================== 139 IF( dom_vvl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl_init : unable to allocate arrays' ) 140 141 ! Read or initialize fse3t_(b/n), tilde_e3t_(b/n) and hdiv_lf (and e3t_a(jpk)) 142 ! ============================================================================ 143 CALL dom_vvl_rst( nit000, 'READ' ) 144 fse3t_a(:,:,jpk) = e3t_0(:,:,jpk) 145 146 ! Reconstruction of all vertical scale factors at now and before time steps 147 ! ============================================================================= 148 ! Horizontal scale factor interpolations 149 ! -------------------------------------- 150 CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3u_b(:,:,:), 'U' ) 151 CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3v_b(:,:,:), 'V' ) 152 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3u_n(:,:,:), 'U' ) 153 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3v_n(:,:,:), 'V' ) 154 CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3f_n(:,:,:), 'F' ) 155 ! Vertical scale factor interpolations 156 ! ------------------------------------ 157 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n (:,:,:), 'W' ) 158 CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3uw_n(:,:,:), 'UW' ) 159 CALL dom_vvl_interpol( fse3v_n(:,:,:), fse3vw_n(:,:,:), 'VW' ) 160 CALL dom_vvl_interpol( fse3u_b(:,:,:), fse3uw_b(:,:,:), 'UW' ) 161 CALL dom_vvl_interpol( fse3v_b(:,:,:), fse3vw_b(:,:,:), 'VW' ) 162 ! t- and w- points depth 163 ! ---------------------- 164 fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 165 fsdepw_n(:,:,1) = 0.0_wp 166 fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 167 DO jk = 2, jpk 168 fsdept_n(:,:,jk) = fsdept_n(:,:,jk-1) + fse3w_n(:,:,jk) 169 fsdepw_n(:,:,jk) = fsdepw_n(:,:,jk-1) + fse3t_n(:,:,jk-1) 170 fsde3w_n(:,:,jk) = fsdept_n(:,:,jk ) - sshn (:,:) 171 END DO 172 ! Reference water column height at t-, u- and v- point 173 ! ---------------------------------------------------- 174 ht_0(:,:) = 0.0_wp 175 hu_0(:,:) = 0.0_wp 176 hv_0(:,:) = 0.0_wp 177 DO jk = 1, jpk 178 ht_0(:,:) = ht_0(:,:) + e3t_0(:,:,jk) * tmask(:,:,jk) 179 hu_0(:,:) = hu_0(:,:) + e3u_0(:,:,jk) * umask(:,:,jk) 180 hv_0(:,:) = hv_0(:,:) + e3v_0(:,:,jk) * vmask(:,:,jk) 181 END DO 182 183 ! Restoring frequencies for z_tilde coordinate 184 ! ============================================ 185 IF( ln_vvl_ztilde ) THEN 186 ! Values in days provided via the namelist; use rsmall to avoid possible division by zero errors with faulty settings 187 frq_rst_e3t(:,:) = 2.0_wp * rpi / ( MAX( rn_rst_e3t , rsmall ) * 86400.0_wp ) 188 frq_rst_hdv(:,:) = 2.0_wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.0_wp ) 189 IF( ln_vvl_ztilde_as_zstar ) THEN 190 ! Ignore namelist settings and use these next two to emulate z-star using z-tilde 191 frq_rst_e3t(:,:) = 0.0_wp 192 frq_rst_hdv(:,:) = 1.0_wp / rdt 193 ENDIF 194 IF ( ln_vvl_zstar_at_eqtor ) THEN 195 DO jj = 1, jpj 196 DO ji = 1, jpi 197 IF( ABS(gphit(ji,jj)) >= 6.) THEN 198 ! values outside the equatorial band and transition zone (ztilde) 199 frq_rst_e3t(ji,jj) = 2.0_wp * rpi / ( MAX( rn_rst_e3t , rsmall ) * 86400.e0_wp ) 200 frq_rst_hdv(ji,jj) = 2.0_wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.e0_wp ) 201 ELSEIF( ABS(gphit(ji,jj)) <= 2.5) THEN 202 ! values inside the equatorial band (ztilde as zstar) 203 frq_rst_e3t(ji,jj) = 0.0_wp 204 frq_rst_hdv(ji,jj) = 1.0_wp / rdt 205 ELSE 206 ! values in the transition band (linearly vary from ztilde to ztilde as zstar values) 207 frq_rst_e3t(ji,jj) = 0.0_wp + (frq_rst_e3t(ji,jj)-0.0_wp)*0.5_wp & 208 & * ( 1.0_wp - COS( rad*(ABS(gphit(ji,jj))-2.5_wp) & 209 & * 180._wp / 3.5_wp ) ) 210 frq_rst_hdv(ji,jj) = (1.0_wp / rdt) & 211 & + ( frq_rst_hdv(ji,jj)-(1.e0_wp / rdt) )*0.5_wp & 212 & * ( 1._wp - COS( rad*(ABS(gphit(ji,jj))-2.5_wp) & 213 & * 180._wp / 3.5_wp ) ) 214 ENDIF 215 END DO 216 END DO 217 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN 218 ii0 = 103 ; ii1 = 111 ! Suppress ztilde in the Foxe Basin for ORCA2 219 ij0 = 128 ; ij1 = 135 ; 220 frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.0_wp 221 frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1.e0_wp / rdt 222 ENDIF 223 ENDIF 224 ENDIF 225 226 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_init') 227 228 END SUBROUTINE dom_vvl_init 229 230 231 SUBROUTINE dom_vvl_sf_nxt( kt ) 232 !!---------------------------------------------------------------------- 233 !! *** ROUTINE dom_vvl_sf_nxt *** 234 !! 235 !! ** Purpose : - compute the after scale factors used in tra_zdf, dynnxt, 236 !! tranxt and dynspg routines 237 !! 238 !! ** Method : - z_star case: Repartition of ssh INCREMENT proportionnaly to the level thickness. 239 !! - z_tilde_case: after scale factor increment = 240 !! high frequency part of horizontal divergence 241 !! + retsoring towards the background grid 242 !! + thickness difusion 243 !! Then repartition of ssh INCREMENT proportionnaly 244 !! to the "baroclinic" level thickness. 245 !! 246 !! ** Action : - hdiv_lf : restoring towards full baroclinic divergence in z_tilde case 247 !! - tilde_e3t_a: after increment of vertical scale factor 248 !! in z_tilde case 249 !! - fse3(t/u/v)_a 250 !! 251 !! Reference : Leclair, M., and Madec, G. 2011, Ocean Modelling. 252 !!---------------------------------------------------------------------- 253 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3t 254 REAL(wp), POINTER, DIMENSION(:,: ) :: zht, z_scale, zwu, zwv, zhdiv 255 !! * Arguments 256 INTEGER, INTENT( in ) :: kt ! time step 257 !! * Local declarations 258 INTEGER :: ji, jj, jk ! dummy loop indices 259 INTEGER , DIMENSION(3) :: ijk_max, ijk_min ! temporary integers 260 REAL(wp) :: z2dt ! temporary scalars 261 REAL(wp) :: z_tmin, z_tmax ! temporary scalars 262 !!---------------------------------------------------------------------- 263 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_sf_nxt') 264 CALL wrk_alloc( jpi, jpj, zht, z_scale, zwu, zwv, zhdiv ) 265 CALL wrk_alloc( jpi, jpj, jpk, ze3t ) 266 267 IF(kt == nit000) THEN 268 IF(lwp) WRITE(numout,*) 269 IF(lwp) WRITE(numout,*) 'dom_vvl_sf_nxt : compute after scale factors' 270 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' 271 ENDIF 272 273 ! ******************************* ! 274 ! After acale factors at t-points ! 275 ! ******************************* ! 276 277 ! ! ----------------- ! 278 IF( ln_vvl_zstar ) THEN ! z_star coordinate ! 279 ! ! ----------------- ! 280 281 z_scale(:,:) = ( ssha(:,:) - sshb(:,:) ) * tmask(:,:,1) / ( ht_0(:,:) + sshn(:,:) + 1. - tmask(:,:,1) ) 282 DO jk = 1, jpkm1 283 fse3t_a(:,:,jk) = fse3t_b(:,:,jk) + fse3t_n(:,:,jk) * z_scale(:,:) * tmask(:,:,jk) 284 END DO 285 286 ! ! --------------------------- ! 287 ELSEIF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde or layer coordinate ! 288 ! ! --------------------------- ! 289 290 ! I - initialization 291 ! ================== 292 293 ! 1 - barotropic divergence 294 ! ------------------------- 295 zhdiv(:,:) = 0. 296 zht(:,:) = 0. 297 DO jk = 1, jpkm1 298 zhdiv(:,:) = zhdiv(:,:) + fse3t_n(:,:,jk) * hdivn(:,:,jk) 299 zht (:,:) = zht (:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 300 END DO 301 zhdiv(:,:) = zhdiv(:,:) / ( zht(:,:) + 1. - tmask(:,:,1) ) 302 303 ! 2 - Low frequency baroclinic horizontal divergence (z-tilde case only) 304 ! -------------------------------------------------- 305 IF( ln_vvl_ztilde ) THEN 306 IF( kt .GT. nit000 ) THEN 307 DO jk = 1, jpkm1 308 hdiv_lf(:,:,jk) = hdiv_lf(:,:,jk) - rdt * frq_rst_hdv(:,:) & 309 & * ( hdiv_lf(:,:,jk) - fse3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) ) 310 END DO 311 ENDIF 312 END IF 313 314 ! II - after z_tilde increments of vertical scale factors 315 ! ======================================================= 316 tilde_e3t_a(:,:,:) = 0.0_wp ! tilde_e3t_a used to store tendency terms 317 318 ! 1 - High frequency divergence term 319 ! ---------------------------------- 320 IF( ln_vvl_ztilde ) THEN ! z_tilde case 321 DO jk = 1, jpkm1 322 tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - ( fse3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) - hdiv_lf(:,:,jk) ) 323 END DO 324 ELSE ! layer case 325 DO jk = 1, jpkm1 326 tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - fse3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) 327 END DO 328 END IF 329 330 ! 2 - Restoring term (z-tilde case only) 331 ! ------------------ 332 IF( ln_vvl_ztilde ) THEN 333 DO jk = 1, jpk 334 tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - frq_rst_e3t(:,:) * tilde_e3t_b(:,:,jk) 335 END DO 336 END IF 337 338 ! 3 - Thickness diffusion term 339 ! ---------------------------- 340 zwu(:,:) = 0.0_wp 341 zwv(:,:) = 0.0_wp 342 ! a - first derivative: diffusive fluxes 343 DO jk = 1, jpkm1 344 DO jj = 1, jpjm1 345 DO ji = 1, fs_jpim1 ! vector opt. 346 un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * re2u_e1u(ji,jj) & 347 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj ,jk) ) 348 vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * re1v_e2v(ji,jj) & 349 & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji ,jj+1,jk) ) 350 zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) 351 zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk) 352 END DO 353 END DO 354 END DO 355 ! b - correction for last oceanic u-v points 356 DO jj = 1, jpj 357 DO ji = 1, jpi 358 un_td(ji,jj,mbku(ji,jj)) = un_td(ji,jj,mbku(ji,jj)) - zwu(ji,jj) 359 vn_td(ji,jj,mbkv(ji,jj)) = vn_td(ji,jj,mbkv(ji,jj)) - zwv(ji,jj) 360 END DO 361 END DO 362 ! c - second derivative: divergence of diffusive fluxes 363 DO jk = 1, jpkm1 364 DO jj = 2, jpjm1 365 DO ji = fs_2, fs_jpim1 ! vector opt. 366 tilde_e3t_a(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) + ( un_td(ji-1,jj ,jk) - un_td(ji,jj,jk) & 367 & + vn_td(ji ,jj-1,jk) - vn_td(ji,jj,jk) & 368 & ) * r1_e12t(ji,jj) 369 END DO 370 END DO 371 END DO 372 ! d - thickness diffusion transport: boundary conditions 373 ! (stored for tracer advction and continuity equation) 374 CALL lbc_lnk( un_td , 'U' , -1.) 375 CALL lbc_lnk( vn_td , 'V' , -1.) 376 377 ! 4 - Time stepping of baroclinic scale factors 378 ! --------------------------------------------- 379 ! Leapfrog time stepping 380 ! ~~~~~~~~~~~~~~~~~~~~~~ 381 IF( neuler == 0 .AND. kt == nit000 ) THEN 382 z2dt = rdt 383 ELSE 384 z2dt = 2.0_wp * rdt 385 ENDIF 386 CALL lbc_lnk( tilde_e3t_a(:,:,:), 'T', 1. ) 387 tilde_e3t_a(:,:,:) = tilde_e3t_b(:,:,:) + z2dt * tmask(:,:,:) * tilde_e3t_a(:,:,:) 388 389 ! Maximum deformation control 390 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 391 ze3t(:,:,jpk) = 0.0_wp 392 DO jk = 1, jpkm1 393 ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) 394 END DO 395 z_tmax = MAXVAL( ze3t(:,:,:) ) 396 IF( lk_mpp ) CALL mpp_max( z_tmax ) ! max over the global domain 397 z_tmin = MINVAL( ze3t(:,:,:) ) 398 IF( lk_mpp ) CALL mpp_min( z_tmin ) ! min over the global domain 399 ! - ML - test: for the moment, stop simulation for too large e3_t variations 400 IF( ( z_tmax .GT. rn_zdef_max ) .OR. ( z_tmin .LT. - rn_zdef_max ) ) THEN 401 IF( lk_mpp ) THEN 402 CALL mpp_maxloc( ze3t, tmask, z_tmax, ijk_max(1), ijk_max(2), ijk_max(3) ) 403 CALL mpp_minloc( ze3t, tmask, z_tmin, ijk_min(1), ijk_min(2), ijk_min(3) ) 404 ELSE 405 ijk_max = MAXLOC( ze3t(:,:,:) ) 406 ijk_max(1) = ijk_max(1) + nimpp - 1 407 ijk_max(2) = ijk_max(2) + njmpp - 1 408 ijk_min = MINLOC( ze3t(:,:,:) ) 409 ijk_min(1) = ijk_min(1) + nimpp - 1 410 ijk_min(2) = ijk_min(2) + njmpp - 1 411 ENDIF 412 IF (lwp) THEN 413 WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax 414 WRITE(numout, *) 'at i, j, k=', ijk_max 415 WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin 416 WRITE(numout, *) 'at i, j, k=', ijk_min 417 CALL ctl_warn('MAX( ABS( tilde_e3t_a(:,:,:) ) / e3t_0(:,:,:) ) too high') 418 ENDIF 419 ENDIF 420 ! - ML - end test 421 ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below 422 tilde_e3t_a(:,:,:) = MIN( tilde_e3t_a(:,:,:), rn_zdef_max * e3t_0(:,:,:) ) 423 tilde_e3t_a(:,:,:) = MAX( tilde_e3t_a(:,:,:), - rn_zdef_max * e3t_0(:,:,:) ) 424 425 ! Add "tilda" part to the after scale factor 426 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 427 fse3t_a(:,:,:) = e3t_0(:,:,:) + tilde_e3t_a(:,:,:) 428 429 ! III - Barotropic repartition of the sea surface height over the baroclinic profile 430 ! ================================================================================== 431 ! add e3t(n-1) "star" Asselin-filtered 432 DO jk = 1, jpkm1 433 fse3t_a(:,:,jk) = fse3t_a(:,:,jk) + fse3t_b(:,:,jk) - e3t_0(:,:,jk) - tilde_e3t_b(:,:,jk) 434 END DO 435 ! add ( ssh increment + "baroclinicity error" ) proportionnaly to e3t(n) 436 ! - ML - baroclinicity error should be better treated in the future 437 ! i.e. locally and not spread over the water column. 438 ! (keep in mind that the idea is to reduce Eulerian velocity as much as possible) 439 zht(:,:) = 0. 440 DO jk = 1, jpkm1 441 zht(:,:) = zht(:,:) + tilde_e3t_a(:,:,jk) * tmask(:,:,jk) 442 END DO 443 z_scale(:,:) = ( ssha(:,:) - sshb(:,:) - zht(:,:) ) / ( ht_0(:,:) + sshn(:,:) + 1. - tmask(:,:,1) ) 444 DO jk = 1, jpkm1 445 fse3t_a(:,:,jk) = fse3t_a(:,:,jk) + fse3t_n(:,:,jk) * z_scale(:,:) * tmask(:,:,jk) 446 END DO 447 448 ENDIF 449 450 IF( ln_vvl_dbg ) THEN ! - ML - test: control prints for debuging 451 ! 452 IF( lwp ) WRITE(numout, *) 'kt =', kt 453 IF ( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 454 z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( zht(:,:) ) ) 455 IF( lk_mpp ) CALL mpp_max( z_tmax ) ! max over the global domain 456 IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(SUM(tilde_e3t_a))) =', z_tmax 457 END IF 458 ! 459 zht(:,:) = 0.0_wp 460 DO jk = 1, jpkm1 461 zht(:,:) = zht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 462 END DO 463 z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + sshn(:,:) - zht(:,:) ) ) 464 IF( lk_mpp ) CALL mpp_max( z_tmax ) ! max over the global domain 465 IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshn-SUM(fse3t_n))) =', z_tmax 466 ! 467 zht(:,:) = 0.0_wp 468 DO jk = 1, jpkm1 469 zht(:,:) = zht(:,:) + fse3t_a(:,:,jk) * tmask(:,:,jk) 470 END DO 471 z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + ssha(:,:) - zht(:,:) ) ) 472 IF( lk_mpp ) CALL mpp_max( z_tmax ) ! max over the global domain 473 IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+ssha-SUM(fse3t_a))) =', z_tmax 474 ! 475 zht(:,:) = 0.0_wp 476 DO jk = 1, jpkm1 477 zht(:,:) = zht(:,:) + fse3t_b(:,:,jk) * tmask(:,:,jk) 478 END DO 479 z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + sshb(:,:) - zht(:,:) ) ) 480 IF( lk_mpp ) CALL mpp_max( z_tmax ) ! max over the global domain 481 IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshb-SUM(fse3t_b))) =', z_tmax 482 ! 483 z_tmax = MAXVAL( tmask(:,:,1) * ABS( sshb(:,:) ) ) 484 IF( lk_mpp ) CALL mpp_max( z_tmax ) ! max over the global domain 485 IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(sshb))) =', z_tmax 486 ! 487 z_tmax = MAXVAL( tmask(:,:,1) * ABS( sshn(:,:) ) ) 488 IF( lk_mpp ) CALL mpp_max( z_tmax ) ! max over the global domain 489 IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(sshn))) =', z_tmax 490 ! 491 z_tmax = MAXVAL( tmask(:,:,1) * ABS( ssha(:,:) ) ) 492 IF( lk_mpp ) CALL mpp_max( z_tmax ) ! max over the global domain 493 IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ssha))) =', z_tmax 494 END IF 495 496 ! *********************************** ! 497 ! After scale factors at u- v- points ! 498 ! *********************************** ! 499 500 CALL dom_vvl_interpol( fse3t_a(:,:,:), fse3u_a(:,:,:), 'U' ) 501 CALL dom_vvl_interpol( fse3t_a(:,:,:), fse3v_a(:,:,:), 'V' ) 502 503 CALL wrk_dealloc( jpi, jpj, zht, z_scale, zwu, zwv, zhdiv ) 504 CALL wrk_dealloc( jpi, jpj, jpk, ze3t ) 505 506 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_sf_nxt') 507 508 END SUBROUTINE dom_vvl_sf_nxt 509 510 511 SUBROUTINE dom_vvl_sf_swp( kt ) 512 !!---------------------------------------------------------------------- 513 !! *** ROUTINE dom_vvl_sf_swp *** 514 !! 515 !! ** Purpose : compute time filter and swap of scale factors 516 !! compute all depths and related variables for next time step 517 !! write outputs and restart file 518 !! 519 !! ** Method : - swap of e3t with trick for volume/tracer conservation 520 !! - reconstruct scale factor at other grid points (interpolate) 521 !! - recompute depths and water height fields 522 !! 523 !! ** Action : - fse3t_(b/n), tilde_e3t_(b/n) and fse3(u/v)_n ready for next time step 524 !! - Recompute: 525 !! fse3(u/v)_b 526 !! fse3w_n 527 !! fse3(u/v)w_b 528 !! fse3(u/v)w_n 529 !! fsdept_n, fsdepw_n and fsde3w_n 530 !! h(u/v) and h(u/v)r 531 !! 532 !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. 533 !! Leclair, M., and G. Madec, 2011, Ocean Modelling. 534 !!---------------------------------------------------------------------- 535 !! * Arguments 536 INTEGER, INTENT( in ) :: kt ! time step 537 !! * Local declarations 538 REAL(wp), POINTER, DIMENSION(:,:,:) :: z_e3t_def 539 INTEGER :: jk ! dummy loop indices 540 !!---------------------------------------------------------------------- 541 542 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_sf_swp') 51 543 ! 52 ALLOCATE( mut (jpi,jpj,jpk) , muu (jpi,jpj,jpk) , muv (jpi,jpj,jpk) , muf (jpi,jpj,jpk) , & 53 & r2dt (jpk) , STAT=dom_vvl_alloc ) 54 ! 55 IF( lk_mpp ) CALL mpp_sum ( dom_vvl_alloc ) 56 IF( dom_vvl_alloc /= 0 ) CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays') 544 CALL wrk_alloc( jpi, jpj, jpk, z_e3t_def ) 57 545 ! 58 END FUNCTION dom_vvl_alloc 59 60 61 SUBROUTINE dom_vvl 62 !!---------------------------------------------------------------------- 63 !! *** ROUTINE dom_vvl *** 64 !! 65 !! ** Purpose : compute mu coefficients at t-, u-, v- and f-points to 66 !! spread ssh over the whole water column (scale factors) 67 !! set the before and now ssh at u- and v-points 68 !! (also f-point in now case) 69 !!---------------------------------------------------------------------- 546 IF( kt == nit000 ) THEN 547 IF(lwp) WRITE(numout,*) 548 IF(lwp) WRITE(numout,*) 'dom_vvl_sf_swp : - time filter and swap of scale factors' 549 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ - interpolate scale factors and compute depths for next time step' 550 ENDIF 70 551 ! 71 INTEGER :: ji, jj, jk ! dummy loop indices 72 REAL(wp) :: zcoefu, zcoefv , zcoeff ! local scalars 73 REAL(wp) :: zvt , zvt_ip1, zvt_jp1, zvt_ip1jp1 ! - - 74 REAL(wp), POINTER, DIMENSION(:,:) :: zee_t, zee_u, zee_v, zee_f ! 2D workspace 75 !!---------------------------------------------------------------------- 552 ! Time filter and swap of scale factors 553 ! ===================================== 554 ! - ML - fse3(t/u/v)_b are allready computed in dynnxt. 555 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 556 IF( neuler == 0 .AND. kt == nit000 ) THEN 557 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) 558 ELSE 559 tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & 560 & + atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) 561 ENDIF 562 tilde_e3t_n(:,:,:) = tilde_e3t_a(:,:,:) 563 ENDIF 564 fse3t_n(:,:,:) = fse3t_a(:,:,:) 565 fse3u_n(:,:,:) = fse3u_a(:,:,:) 566 fse3v_n(:,:,:) = fse3v_a(:,:,:) 567 568 ! Compute all missing vertical scale factor and depths 569 ! ==================================================== 570 ! Horizontal scale factor interpolations 571 ! -------------------------------------- 572 ! - ML - fse3u_b and fse3v_b are allready computed in dynnxt 573 CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3f_n (:,:,:), 'F' ) 574 ! Vertical scale factor interpolations 575 ! ------------------------------------ 576 CALL dom_vvl_interpol( fse3t_n(:,:,:), fse3w_n (:,:,:), 'W' ) 577 CALL dom_vvl_interpol( fse3u_n(:,:,:), fse3uw_n(:,:,:), 'UW' ) 578 CALL dom_vvl_interpol( fse3v_n(:,:,:), fse3vw_n(:,:,:), 'VW' ) 579 CALL dom_vvl_interpol( fse3u_b(:,:,:), fse3uw_b(:,:,:), 'UW' ) 580 CALL dom_vvl_interpol( fse3v_b(:,:,:), fse3vw_b(:,:,:), 'VW' ) 581 ! t- and w- points depth 582 ! ---------------------- 583 fsdept_n(:,:,1) = 0.5_wp * fse3w_n(:,:,1) 584 fsdepw_n(:,:,1) = 0.0_wp 585 fsde3w_n(:,:,1) = fsdept_n(:,:,1) - sshn(:,:) 586 DO jk = 2, jpk 587 fsdept_n(:,:,jk) = fsdept_n(:,:,jk-1) + fse3w_n(:,:,jk) 588 fsdepw_n(:,:,jk) = fsdepw_n(:,:,jk-1) + fse3t_n(:,:,jk-1) 589 fsde3w_n(:,:,jk) = fsdept_n(:,:,jk ) - sshn (:,:) 590 END DO 591 ! Local depth and Inverse of the local depth of the water column at u- and v- points 592 ! ---------------------------------------------------------------------------------- 593 hu(:,:) = 0. 594 hv(:,:) = 0. 595 DO jk = 1, jpk 596 hu(:,:) = hu(:,:) + fse3u_n(:,:,jk) * umask(:,:,jk) 597 hv(:,:) = hv(:,:) + fse3v_n(:,:,jk) * vmask(:,:,jk) 598 END DO 599 ! Inverse of the local depth 600 hur(:,:) = umask(:,:,1) / ( hu(:,:) + 1. - umask(:,:,1) ) 601 hvr(:,:) = vmask(:,:,1) / ( hv(:,:) + 1. - vmask(:,:,1) ) 602 603 ! Write outputs 604 ! ============= 605 z_e3t_def(:,:,:) = ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 606 CALL iom_put( "e3t_n" , fse3t_n (:,:,:) ) 607 CALL iom_put( "dept_n" , fsde3w_n (:,:,:) ) 608 CALL iom_put( "e3tdef" , z_e3t_def(:,:,:) ) 609 610 ! write restart file 611 ! ================== 612 IF( lrst_oce ) CALL dom_vvl_rst( kt, 'WRITE' ) 76 613 ! 77 IF( nn_timing == 1 ) CALL timing_start('dom_vvl')614 CALL wrk_dealloc( jpi, jpj, jpk, z_e3t_def ) 78 615 ! 79 CALL wrk_alloc( jpi, jpj, zee_t, zee_u, zee_v, zee_f ) 616 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_sf_swp') 617 618 END SUBROUTINE dom_vvl_sf_swp 619 620 621 SUBROUTINE dom_vvl_interpol( pe3_in, pe3_out, pout ) 622 !!--------------------------------------------------------------------- 623 !! *** ROUTINE dom_vvl__interpol *** 624 !! 625 !! ** Purpose : interpolate scale factors from one grid point to another 626 !! 627 !! ** Method : e3_out = e3_0 + interpolation(e3_in - e3_0) 628 !! - horizontal interpolation: grid cell surface averaging 629 !! - vertical interpolation: simple averaging 630 !!---------------------------------------------------------------------- 631 !! * Arguments 632 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pe3_in ! input e3 to be interpolated 633 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: pe3_out ! output interpolated e3 634 CHARACTER(LEN=*), INTENT( in ) :: pout ! grid point of out scale factors 635 ! ! = 'U', 'V', 'W, 'F', 'UW' or 'VW' 636 !! * Local declarations 637 INTEGER :: ji, jj, jk ! dummy loop indices 638 LOGICAL :: l_is_orca ! local logical 639 !!---------------------------------------------------------------------- 640 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_interpol') 641 ! 642 l_is_orca = .FALSE. 643 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) l_is_orca = .TRUE. ! ORCA R2 configuration - will need to correct some locations 644 645 SELECT CASE ( pout ) 646 ! ! ------------------------------------- ! 647 CASE( 'U' ) ! interpolation from T-point to U-point ! 648 ! ! ------------------------------------- ! 649 ! horizontal surface weighted interpolation 650 DO jk = 1, jpk 651 DO jj = 1, jpjm1 652 DO ji = 1, fs_jpim1 ! vector opt. 653 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * r1_e12u(ji,jj) & 654 & * ( e12t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 655 & + e12t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) ) 656 END DO 657 END DO 658 END DO 659 ! 660 IF( l_is_orca ) CALL dom_vvl_orca_fix( pe3_in, pe3_out, pout ) 661 ! boundary conditions 662 CALL lbc_lnk( pe3_out(:,:,:), 'U', 1. ) 663 pe3_out(:,:,:) = pe3_out(:,:,:) + e3u_0(:,:,:) 664 ! ! ------------------------------------- ! 665 CASE( 'V' ) ! interpolation from T-point to V-point ! 666 ! ! ------------------------------------- ! 667 ! horizontal surface weighted interpolation 668 DO jk = 1, jpk 669 DO jj = 1, jpjm1 670 DO ji = 1, fs_jpim1 ! vector opt. 671 pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) * r1_e12v(ji,jj) & 672 & * ( e12t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 673 & + e12t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) ) 674 END DO 675 END DO 676 END DO 677 ! 678 IF( l_is_orca ) CALL dom_vvl_orca_fix( pe3_in, pe3_out, pout ) 679 ! boundary conditions 680 CALL lbc_lnk( pe3_out(:,:,:), 'V', 1. ) 681 pe3_out(:,:,:) = pe3_out(:,:,:) + e3v_0(:,:,:) 682 ! ! ------------------------------------- ! 683 CASE( 'F' ) ! interpolation from U-point to F-point ! 684 ! ! ------------------------------------- ! 685 ! horizontal surface weighted interpolation 686 DO jk = 1, jpk 687 DO jj = 1, jpjm1 688 DO ji = 1, fs_jpim1 ! vector opt. 689 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) * r1_e12f(ji,jj) & 690 & * ( e12u(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3u_0(ji,jj ,jk) ) & 691 & + e12u(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3u_0(ji,jj+1,jk) ) ) 692 END DO 693 END DO 694 END DO 695 ! 696 IF( l_is_orca ) CALL dom_vvl_orca_fix( pe3_in, pe3_out, pout ) 697 ! boundary conditions 698 CALL lbc_lnk( pe3_out(:,:,:), 'F', 1. ) 699 pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:) 700 ! ! ------------------------------------- ! 701 CASE( 'W' ) ! interpolation from T-point to W-point ! 702 ! ! ------------------------------------- ! 703 ! vertical simple interpolation 704 pe3_out(:,:,1) = e3w_0(:,:,1) + pe3_in(:,:,1) - e3t_0(:,:,1) 705 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 706 DO jk = 2, jpk 707 pe3_out(:,:,jk) = e3w_0(:,:,jk) + ( 1.0_wp - 0.5_wp * tmask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3t_0(:,:,jk-1) ) & 708 & + 0.5_wp * tmask(:,:,jk) * ( pe3_in(:,:,jk ) - e3t_0(:,:,jk ) ) 709 END DO 710 ! ! -------------------------------------- ! 711 CASE( 'UW' ) ! interpolation from U-point to UW-point ! 712 ! ! -------------------------------------- ! 713 ! vertical simple interpolation 714 pe3_out(:,:,1) = e3uw_0(:,:,1) + pe3_in(:,:,1) - e3u_0(:,:,1) 715 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 716 DO jk = 2, jpk 717 pe3_out(:,:,jk) = e3uw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * umask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3u_0(:,:,jk-1) ) & 718 & + 0.5_wp * umask(:,:,jk) * ( pe3_in(:,:,jk ) - e3u_0(:,:,jk ) ) 719 END DO 720 ! ! -------------------------------------- ! 721 CASE( 'VW' ) ! interpolation from V-point to VW-point ! 722 ! ! -------------------------------------- ! 723 ! vertical simple interpolation 724 pe3_out(:,:,1) = e3vw_0(:,:,1) + pe3_in(:,:,1) - e3v_0(:,:,1) 725 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 726 DO jk = 2, jpk 727 pe3_out(:,:,jk) = e3vw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * vmask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3v_0(:,:,jk-1) ) & 728 & + 0.5_wp * vmask(:,:,jk) * ( pe3_in(:,:,jk ) - e3v_0(:,:,jk ) ) 729 END DO 730 END SELECT 80 731 ! 81 IF(lwp) THEN 732 733 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_interpol') 734 735 END SUBROUTINE dom_vvl_interpol 736 737 SUBROUTINE dom_vvl_rst( kt, cdrw ) 738 !!--------------------------------------------------------------------- 739 !! *** ROUTINE dom_vvl_rst *** 740 !! 741 !! ** Purpose : Read or write VVL file in restart file 742 !! 743 !! ** Method : use of IOM library 744 !! if the restart does not contain vertical scale factors, 745 !! they are set to the _0 values 746 !! if the restart does not contain vertical scale factors increments (z_tilde), 747 !! they are set to 0. 748 !!---------------------------------------------------------------------- 749 !! * Arguments 750 INTEGER , INTENT(in) :: kt ! ocean time-step 751 CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag 752 !! * Local declarations 753 INTEGER :: id1, id2, id3, id4, id5 ! local integers 754 !!---------------------------------------------------------------------- 755 ! 756 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_rst') 757 IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise 758 ! ! =============== 759 IF( ln_rstart ) THEN !* Read the restart file 760 CALL rst_read_open ! open the restart file if necessary 761 id1 = iom_varid( numror, 'fse3t_b', ldstop = .FALSE. ) 762 id2 = iom_varid( numror, 'fse3t_n', ldstop = .FALSE. ) 763 id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) 764 id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. ) 765 id5 = iom_varid( numror, 'hdif_lf', ldstop = .FALSE. ) 766 ! ! --------- ! 767 ! ! all cases ! 768 ! ! --------- ! 769 IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist 770 CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) ) 771 CALL iom_get( numror, jpdom_autoglo, 'fse3t_n', fse3t_n(:,:,:) ) 772 IF( neuler == 0 ) THEN 773 fse3t_b(:,:,:) = fse3t_n(:,:,:) 774 ENDIF 775 ELSE IF( id1 > 0 ) THEN 776 IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : fse3t_n not found in restart files' 777 IF(lwp) write(numout,*) 'fse3t_n set equal to fse3t_b.' 778 fse3t_b(:,:,:) = fse3t_n(:,:,:) 779 ELSE ! one at least array is missing 780 CALL ctl_stop( 'dom_vvl_rst: vvl cannot restart from a non vvl run' ) 781 ENDIF 782 ! ! ----------- ! 783 IF( ln_vvl_zstar ) THEN ! z_star case ! 784 ! ! ----------- ! 785 IF( MIN( id3, id4 ) > 0 ) THEN 786 CALL ctl_stop( 'dom_vvl_rst: z_star cannot restart from a z_tilde or layer run' ) 787 ENDIF 788 ! ! ----------------------- ! 789 ELSE ! z_tilde and layer cases ! 790 ! ! ----------------------- ! 791 IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist 792 CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 793 CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 794 ELSE ! one at least array is missing 795 tilde_e3t_b(:,:,:) = 0.0_wp 796 tilde_e3t_n(:,:,:) = 0.0_wp 797 ENDIF 798 ! ! ------------ ! 799 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 800 ! ! ------------ ! 801 IF( id5 > 0 ) THEN ! required array exists 802 CALL iom_get( numror, jpdom_autoglo, 'hdiv_lf', hdiv_lf(:,:,:) ) 803 ELSE ! array is missing 804 hdiv_lf(:,:,:) = 0.0_wp 805 ENDIF 806 ENDIF 807 ENDIF 808 ! 809 ELSE !* Initialize at "rest" 810 fse3t_b(:,:,:) = e3t_0(:,:,:) 811 fse3t_n(:,:,:) = e3t_0(:,:,:) 812 IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN 813 tilde_e3t_b(:,:,:) = 0.0_wp 814 tilde_e3t_n(:,:,:) = 0.0_wp 815 IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0.0_wp 816 END IF 817 ENDIF 818 819 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file 820 ! ! =================== 821 IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' 822 ! ! --------- ! 823 ! ! all cases ! 824 ! ! --------- ! 825 CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) ) 826 CALL iom_rstput( kt, nitrst, numrow, 'fse3t_n', fse3t_n(:,:,:) ) 827 ! ! ----------------------- ! 828 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! 829 ! ! ----------------------- ! 830 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:) ) 831 CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:) ) 832 END IF 833 ! ! -------------! 834 IF( ln_vvl_ztilde ) THEN ! z_tilde case ! 835 ! ! ------------ ! 836 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:) ) 837 ENDIF 838 839 ENDIF 840 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_rst') 841 842 END SUBROUTINE dom_vvl_rst 843 844 845 SUBROUTINE dom_vvl_ctl 846 !!--------------------------------------------------------------------- 847 !! *** ROUTINE dom_vvl_ctl *** 848 !! 849 !! ** Purpose : Control the consistency between namelist options 850 !! for vertical coordinate 851 !!---------------------------------------------------------------------- 852 INTEGER :: ioptio 853 854 NAMELIST/nam_vvl/ ln_vvl_zstar, ln_vvl_ztilde, ln_vvl_layer, ln_vvl_ztilde_as_zstar, & 855 & ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , & 856 & rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg ! not yet implemented: ln_vvl_kepe 857 !!---------------------------------------------------------------------- 858 859 REWIND ( numnam ) ! Read Namelist nam_vvl : vertical coordinate 860 READ ( numnam, nam_vvl ) 861 862 IF(lwp) THEN ! Namelist print 82 863 WRITE(numout,*) 83 WRITE(numout,*) 'dom_vvl : Variable volume initialization' 84 WRITE(numout,*) '~~~~~~~~ compute coef. used to spread ssh over each layers' 864 WRITE(numout,*) 'dom_vvl_ctl : choice/control of the variable vertical coordinate' 865 WRITE(numout,*) '~~~~~~~~~~~' 866 WRITE(numout,*) ' Namelist nam_vvl : chose a vertical coordinate' 867 WRITE(numout,*) ' zstar ln_vvl_zstar = ', ln_vvl_zstar 868 WRITE(numout,*) ' ztilde ln_vvl_ztilde = ', ln_vvl_ztilde 869 WRITE(numout,*) ' layer ln_vvl_layer = ', ln_vvl_layer 870 WRITE(numout,*) ' ztilde as zstar ln_vvl_ztilde_as_zstar = ', ln_vvl_ztilde_as_zstar 871 WRITE(numout,*) ' ztilde near the equator ln_vvl_zstar_at_eqtor = ', ln_vvl_zstar_at_eqtor 872 ! WRITE(numout,*) ' Namelist nam_vvl : chose kinetic-to-potential energy conservation' 873 ! WRITE(numout,*) ' ln_vvl_kepe = ', ln_vvl_kepe 874 WRITE(numout,*) ' Namelist nam_vvl : thickness diffusion coefficient' 875 WRITE(numout,*) ' rn_ahe3 = ', rn_ahe3 876 WRITE(numout,*) ' Namelist nam_vvl : maximum e3t deformation fractional change' 877 WRITE(numout,*) ' rn_zdef_max = ', rn_zdef_max 878 IF( ln_vvl_ztilde_as_zstar ) THEN 879 WRITE(numout,*) ' ztilde running in zstar emulation mode; ' 880 WRITE(numout,*) ' ignoring namelist timescale parameters and using:' 881 WRITE(numout,*) ' hard-wired : z-tilde to zstar restoration timescale (days)' 882 WRITE(numout,*) ' rn_rst_e3t = 0.0' 883 WRITE(numout,*) ' hard-wired : z-tilde cutoff frequency of low-pass filter (days)' 884 WRITE(numout,*) ' rn_lf_cutoff = 1.0/rdt' 885 ELSE 886 WRITE(numout,*) ' Namelist nam_vvl : z-tilde to zstar restoration timescale (days)' 887 WRITE(numout,*) ' rn_rst_e3t = ', rn_rst_e3t 888 WRITE(numout,*) ' Namelist nam_vvl : z-tilde cutoff frequency of low-pass filter (days)' 889 WRITE(numout,*) ' rn_lf_cutoff = ', rn_lf_cutoff 890 ENDIF 891 WRITE(numout,*) ' Namelist nam_vvl : debug prints' 892 WRITE(numout,*) ' ln_vvl_dbg = ', ln_vvl_dbg 85 893 ENDIF 86 87 IF( dom_vvl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl : unable to allocate arrays' ) 88 89 fsdept(:,:,:) = gdept (:,:,:) 90 fsdepw(:,:,:) = gdepw (:,:,:) 91 fsde3w(:,:,:) = gdep3w(:,:,:) 92 fse3t (:,:,:) = e3t (:,:,:) 93 fse3u (:,:,:) = e3u (:,:,:) 94 fse3v (:,:,:) = e3v (:,:,:) 95 fse3f (:,:,:) = e3f (:,:,:) 96 fse3w (:,:,:) = e3w (:,:,:) 97 fse3uw(:,:,:) = e3uw (:,:,:) 98 fse3vw(:,:,:) = e3vw (:,:,:) 99 100 ! !== mu computation ==! 101 zee_t(:,:) = fse3t_0(:,:,1) ! Lower bound : thickness of the first model level 102 zee_u(:,:) = fse3u_0(:,:,1) 103 zee_v(:,:) = fse3v_0(:,:,1) 104 zee_f(:,:) = fse3f_0(:,:,1) 105 DO jk = 2, jpkm1 ! Sum of the masked vertical scale factors 106 zee_t(:,:) = zee_t(:,:) + fse3t_0(:,:,jk) * tmask(:,:,jk) 107 zee_u(:,:) = zee_u(:,:) + fse3u_0(:,:,jk) * umask(:,:,jk) 108 zee_v(:,:) = zee_v(:,:) + fse3v_0(:,:,jk) * vmask(:,:,jk) 109 DO jj = 1, jpjm1 ! f-point : fmask=shlat at coasts, use the product of umask 110 zee_f(:,jj) = zee_f(:,jj) + fse3f_0(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 111 END DO 112 END DO 113 ! ! Compute and mask the inverse of the local depth at T, U, V and F points 114 zee_t(:,:) = 1._wp / zee_t(:,:) * tmask(:,:,1) 115 zee_u(:,:) = 1._wp / zee_u(:,:) * umask(:,:,1) 116 zee_v(:,:) = 1._wp / zee_v(:,:) * vmask(:,:,1) 117 DO jj = 1, jpjm1 ! f-point case fmask cannot be used 118 zee_f(:,jj) = 1._wp / zee_f(:,jj) * umask(:,jj,1) * umask(:,jj+1,1) 119 END DO 120 CALL lbc_lnk( zee_f, 'F', 1. ) ! lateral boundary condition on ee_f 121 ! 122 DO jk = 1, jpk ! mu coefficients 123 mut(:,:,jk) = zee_t(:,:) * tmask(:,:,jk) ! T-point at T levels 124 muu(:,:,jk) = zee_u(:,:) * umask(:,:,jk) ! U-point at T levels 125 muv(:,:,jk) = zee_v(:,:) * vmask(:,:,jk) ! V-point at T levels 126 END DO 127 DO jk = 1, jpk ! F-point : fmask=shlat at coasts, use the product of umask 128 DO jj = 1, jpjm1 129 muf(:,jj,jk) = zee_f(:,jj) * umask(:,jj,jk) * umask(:,jj+1,jk) ! at T levels 130 END DO 131 muf(:,jpj,jk) = 0._wp 132 END DO 133 CALL lbc_lnk( muf, 'F', 1. ) ! lateral boundary condition 134 135 136 hu_0(:,:) = 0.e0 ! Reference ocean depth at U- and V-points 137 hv_0(:,:) = 0.e0 138 DO jk = 1, jpk 139 hu_0(:,:) = hu_0(:,:) + fse3u_0(:,:,jk) * umask(:,:,jk) 140 hv_0(:,:) = hv_0(:,:) + fse3v_0(:,:,jk) * vmask(:,:,jk) 141 END DO 142 143 DO jj = 1, jpjm1 ! initialise before and now Sea Surface Height at u-, v-, f-points 144 DO ji = 1, jpim1 ! NO vector opt. 145 zcoefu = 0.50_wp / ( e1u(ji,jj) * e2u(ji,jj) ) * umask(ji,jj,1) 146 zcoefv = 0.50_wp / ( e1v(ji,jj) * e2v(ji,jj) ) * vmask(ji,jj,1) 147 zcoeff = 0.25_wp / ( e1f(ji,jj) * e2f(ji,jj) ) * umask(ji,jj,1) * umask(ji,jj+1,1) 148 ! 149 zvt = e1e2t(ji ,jj ) * sshb(ji ,jj ) ! before fields 150 zvt_ip1 = e1e2t(ji+1,jj ) * sshb(ji+1,jj ) 151 zvt_jp1 = e1e2t(ji ,jj+1) * sshb(ji ,jj+1) 152 sshu_b(ji,jj) = zcoefu * ( zvt + zvt_ip1 ) 153 sshv_b(ji,jj) = zcoefv * ( zvt + zvt_jp1 ) 154 ! 155 zvt = e1e2t(ji ,jj ) * sshn(ji ,jj ) ! now fields 156 zvt_ip1 = e1e2t(ji+1,jj ) * sshn(ji+1,jj ) 157 zvt_jp1 = e1e2t(ji ,jj+1) * sshn(ji ,jj+1) 158 zvt_ip1jp1 = e1e2t(ji+1,jj+1) * sshn(ji+1,jj+1) 159 sshu_n(ji,jj) = zcoefu * ( zvt + zvt_ip1 ) 160 sshv_n(ji,jj) = zcoefv * ( zvt + zvt_jp1 ) 161 sshf_n(ji,jj) = zcoeff * ( zvt + zvt_ip1 + zvt_jp1 + zvt_ip1jp1 ) 162 END DO 163 END DO 164 CALL lbc_lnk( sshu_n, 'U', 1. ) ; CALL lbc_lnk( sshu_b, 'U', 1. ) ! lateral boundary conditions 165 CALL lbc_lnk( sshv_n, 'V', 1. ) ; CALL lbc_lnk( sshv_b, 'V', 1. ) 166 CALL lbc_lnk( sshf_n, 'F', 1. ) 167 ! 168 CALL wrk_dealloc( jpi, jpj, zee_t, zee_u, zee_v, zee_f ) 169 ! 170 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl') 171 ! 172 END SUBROUTINE dom_vvl 173 174 175 SUBROUTINE dom_vvl_2( kt, pe3u_b, pe3v_b ) 176 !!---------------------------------------------------------------------- 177 !! *** ROUTINE dom_vvl_2 *** 178 !! 179 !! ** Purpose : compute the vertical scale factors at u- and v-points 180 !! in variable volume case. 181 !! 182 !! ** Method : In variable volume case (non linear sea surface) the 183 !! the vertical scale factor at velocity points is computed 184 !! as the average of the cell surface weighted e3t. 185 !! It uses the sea surface heigth so it have to be initialized 186 !! after ssh is read/set 187 !!---------------------------------------------------------------------- 188 INTEGER , INTENT(in ) :: kt ! ocean time-step index 189 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pe3u_b, pe3v_b ! before vertical scale factor at u- & v-pts 190 ! 191 INTEGER :: ji, jj, jk ! dummy loop indices 192 INTEGER :: iku, ikv ! local integers 193 INTEGER :: ii0, ii1, ij0, ij1 ! temporary integers 194 REAL(wp) :: zvt, zvtip1, zvtjp1 ! local scalars 195 !!---------------------------------------------------------------------- 196 ! 197 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_2') 198 ! 199 IF( lwp .AND. kt == nit000 ) THEN 894 895 ioptio = 0 ! Parameter control 896 IF( ln_vvl_ztilde_as_zstar ) ln_vvl_ztilde = .true. 897 IF( ln_vvl_zstar ) ioptio = ioptio + 1 898 IF( ln_vvl_ztilde ) ioptio = ioptio + 1 899 IF( ln_vvl_layer ) ioptio = ioptio + 1 900 901 IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' ) 902 903 IF(lwp) THEN ! Print the choice 200 904 WRITE(numout,*) 201 WRITE(numout,*) 'dom_vvl_2 : Variable volume, fse3t_b initialization' 202 WRITE(numout,*) '~~~~~~~~~ ' 203 pe3u_b(:,:,jpk) = fse3u_0(:,:,jpk) 204 pe3v_b(:,:,jpk) = fse3v_0(:,:,jpk) 905 IF( ln_vvl_zstar ) WRITE(numout,*) ' zstar vertical coordinate is used' 906 IF( ln_vvl_ztilde ) WRITE(numout,*) ' ztilde vertical coordinate is used' 907 IF( ln_vvl_layer ) WRITE(numout,*) ' layer vertical coordinate is used' 908 IF( ln_vvl_ztilde_as_zstar ) WRITE(numout,*) ' to emulate a zstar coordinate' 909 ! - ML - Option not developed yet 910 ! IF( ln_vvl_kepe ) WRITE(numout,*) ' kinetic to potential energy transfer : option used' 911 ! IF( .NOT. ln_vvl_kepe ) WRITE(numout,*) ' kinetic to potential energy transfer : option not used' 205 912 ENDIF 206 207 DO jk = 1, jpkm1 ! set the before scale factors at u- & v-points 208 DO jj = 2, jpjm1 209 DO ji = fs_2, fs_jpim1 210 zvt = ( fse3t_b(ji ,jj ,jk) - fse3t_0(ji ,jj ,jk) ) * e1e2t(ji ,jj ) 211 zvtip1 = ( fse3t_b(ji+1,jj ,jk) - fse3t_0(ji+1,jj ,jk) ) * e1e2t(ji+1,jj ) 212 zvtjp1 = ( fse3t_b(ji ,jj+1,jk) - fse3t_0(ji ,jj+1,jk) ) * e1e2t(ji ,jj+1) 213 pe3u_b(ji,jj,jk) = fse3u_0(ji,jj,jk) + 0.5_wp * ( zvt + zvtip1 ) / ( e1u(ji,jj) * e2u(ji,jj) ) 214 pe3v_b(ji,jj,jk) = fse3v_0(ji,jj,jk) + 0.5_wp * ( zvt + zvtjp1 ) / ( e1v(ji,jj) * e2v(ji,jj) ) 215 END DO 216 END DO 217 END DO 218 219 ! Correct scale factors at locations that have been individually modified in domhgr 220 ! Such modifications break the relationship between e1e2t and e1u*e2u etc. Recompute 221 ! scale factors ignoring the modified metric. 913 914 END SUBROUTINE dom_vvl_ctl 915 916 SUBROUTINE dom_vvl_orca_fix( pe3_in, pe3_out, pout ) 917 !!--------------------------------------------------------------------- 918 !! *** ROUTINE dom_vvl_orca_fix *** 919 !! 920 !! ** Purpose : Correct surface weighted, horizontally interpolated, 921 !! scale factors at locations that have been individually 922 !! modified in domhgr. Such modifications break the 923 !! relationship between e12t and e1u*e2u etc. 924 !! Recompute some scale factors ignoring the modified metric. 925 !!---------------------------------------------------------------------- 926 !! * Arguments 927 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pe3_in ! input e3 to be interpolated 928 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: pe3_out ! output interpolated e3 929 CHARACTER(LEN=*), INTENT( in ) :: pout ! grid point of out scale factors 930 ! ! = 'U', 'V', 'W, 'F', 'UW' or 'VW' 931 !! * Local declarations 932 INTEGER :: ji, jj, jk ! dummy loop indices 933 INTEGER :: ij0, ij1, ii0, ii1 ! dummy loop indices 934 !! acc 935 !! Hmm with the time splitting these "fixes" seem to do more harm than good. Temporarily disabled for 936 !! the ORCA2 tests (by changing jp_cfg test from 2 to 3) pending further investigations 937 !! 222 938 ! ! ===================== 223 939 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA R2 configuration 224 940 ! ! ===================== 941 !! acc 225 942 IF( nn_cla == 0 ) THEN 226 943 ! 227 944 ii0 = 139 ; ii1 = 140 ! Gibraltar Strait (e2u was modified) 228 ij0 = 102 ; ij1 = 102 229 DO jk = 1, jpkm1 ! set the before scale factors at u-points945 ij0 = 102 ; ij1 = 102 946 DO jk = 1, jpkm1 230 947 DO jj = mj0(ij0), mj1(ij1) 231 948 DO ji = mi0(ii0), mi1(ii1) 232 zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 233 pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 949 SELECT CASE ( pout ) 950 CASE( 'U' ) 951 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) & 952 & * ( e1t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 953 & + e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 954 & ) / e1u(ji,jj) + e3u_0(ji,jj,jk) 955 CASE( 'F' ) 956 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) & 957 & * ( e1u(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3u_0(ji ,jj,jk) ) & 958 & + e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 959 & ) / e1f(ji,jj) + e3f_0(ji,jj,jk) 960 END SELECT 234 961 END DO 235 962 END DO … … 237 964 ! 238 965 ii0 = 160 ; ii1 = 160 ! Bab el Mandeb (e2u and e1v were modified) 239 ij0 = 88 ; ij1 = 88 240 DO jk = 1, jpkm1 ! set the before scale factors at u-points966 ij0 = 88 ; ij1 = 88 967 DO jk = 1, jpkm1 241 968 DO jj = mj0(ij0), mj1(ij1) 242 969 DO ji = mi0(ii0), mi1(ii1) 243 zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 244 pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 970 SELECT CASE ( pout ) 971 CASE( 'U' ) 972 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) & 973 & * ( e1t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 974 & + e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 975 & ) / e1u(ji,jj) + e3u_0(ji,jj,jk) 976 CASE( 'V' ) 977 pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) & 978 & * ( e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 979 & + e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 980 & ) / e2v(ji,jj) + e3v_0(ji,jj,jk) 981 CASE( 'F' ) 982 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) & 983 & * ( e1u(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3u_0(ji ,jj,jk) ) & 984 & + e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 985 & ) / e1f(ji,jj) + e3f_0(ji,jj,jk) 986 END SELECT 245 987 END DO 246 988 END DO 247 989 END DO 248 DO jk = 1, jpkm1 ! set the before scale factors at v-points249 DO jj = mj0(ij0), mj1(ij1)250 DO ji = mi0(ii0), mi1(ii1)251 zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj)252 pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) )253 END DO254 END DO255 END DO256 990 ENDIF 257 991 258 992 ii0 = 145 ; ii1 = 146 ! Danish Straits (e2u was modified) 259 ij0 = 116 ; ij1 = 116 260 DO jk = 1, jpkm1 ! set the before scale factors at u-points 261 DO jj = mj0(ij0), mj1(ij1) 262 DO ji = mi0(ii0), mi1(ii1) 263 zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 264 pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 265 END DO 266 END DO 267 END DO 268 ! 993 ij0 = 116 ; ij1 = 116 994 DO jk = 1, jpkm1 995 DO jj = mj0(ij0), mj1(ij1) 996 DO ji = mi0(ii0), mi1(ii1) 997 SELECT CASE ( pout ) 998 CASE( 'U' ) 999 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) & 1000 & * ( e1t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 1001 & + e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 1002 & ) / e1u(ji,jj) + e3u_0(ji,jj,jk) 1003 CASE( 'F' ) 1004 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) & 1005 & * ( e1u(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3u_0(ji ,jj,jk) ) & 1006 & + e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 1007 & ) / e1f(ji,jj) + e3f_0(ji,jj,jk) 1008 END SELECT 1009 END DO 1010 END DO 1011 END DO 269 1012 ENDIF 1013 ! 270 1014 ! ! ===================== 271 1015 IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN ! ORCA R1 configuration 272 1016 ! ! ===================== 273 1017 ! 274 1018 ii0 = 281 ; ii1 = 282 ! Gibraltar Strait (e2u was modified) 275 ij0 = 200 ; ij1 = 200 276 DO jk = 1, jpkm1 ! set the before scale factors at u-points 277 DO jj = mj0(ij0), mj1(ij1) 278 DO ji = mi0(ii0), mi1(ii1) 279 zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 280 pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 281 END DO 282 END DO 283 END DO 284 1019 ij0 = 200 ; ij1 = 200 1020 DO jk = 1, jpkm1 1021 DO jj = mj0(ij0), mj1(ij1) 1022 DO ji = mi0(ii0), mi1(ii1) 1023 SELECT CASE ( pout ) 1024 CASE( 'U' ) 1025 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) & 1026 & * ( e1t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 1027 & + e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 1028 & ) / e1u(ji,jj) + e3u_0(ji,jj,jk) 1029 CASE( 'F' ) 1030 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) & 1031 & * ( e1u(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3u_0(ji ,jj,jk) ) & 1032 & + e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 1033 & ) / e1f(ji,jj) + e3f_0(ji,jj,jk) 1034 END SELECT 1035 END DO 1036 END DO 1037 END DO 1038 ! 285 1039 ii0 = 314 ; ii1 = 315 ! Bhosporus Strait (e2u was modified) 286 ij0 = 208 ; ij1 = 208 287 DO jk = 1, jpkm1 ! set the before scale factors at u-points 288 DO jj = mj0(ij0), mj1(ij1) 289 DO ji = mi0(ii0), mi1(ii1) 290 zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 291 pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 292 END DO 293 END DO 294 END DO 295 1040 ij0 = 208 ; ij1 = 208 1041 DO jk = 1, jpkm1 1042 DO jj = mj0(ij0), mj1(ij1) 1043 DO ji = mi0(ii0), mi1(ii1) 1044 SELECT CASE ( pout ) 1045 CASE( 'U' ) 1046 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) & 1047 & * ( e1t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 1048 & + e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 1049 & ) / e1u(ji,jj) + e3u_0(ji,jj,jk) 1050 CASE( 'F' ) 1051 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) & 1052 & * ( e1u(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3u_0(ji ,jj,jk) ) & 1053 & + e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 1054 & ) / e1f(ji,jj) + e3f_0(ji,jj,jk) 1055 END SELECT 1056 END DO 1057 END DO 1058 END DO 1059 ! 296 1060 ii0 = 44 ; ii1 = 44 ! Lombok Strait (e1v was modified) 297 ij0 = 124 ; ij1 = 125 298 DO jk = 1, jpkm1 ! set the before scale factors at v-points 299 DO jj = mj0(ij0), mj1(ij1) 300 DO ji = mi0(ii0), mi1(ii1) 301 zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 302 pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 303 END DO 304 END DO 305 END DO 306 1061 ij0 = 124 ; ij1 = 125 1062 DO jk = 1, jpkm1 1063 DO jj = mj0(ij0), mj1(ij1) 1064 DO ji = mi0(ii0), mi1(ii1) 1065 SELECT CASE ( pout ) 1066 CASE( 'V' ) 1067 pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) & 1068 & * ( e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 1069 & + e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 1070 & ) / e2v(ji,jj) + e3v_0(ji,jj,jk) 1071 END SELECT 1072 END DO 1073 END DO 1074 END DO 1075 ! 307 1076 ii0 = 48 ; ii1 = 48 ! Sumba Strait (e1v was modified) [closed from bathy_11 on] 308 ij0 = 124 ; ij1 = 125 309 DO jk = 1, jpkm1 ! set the before scale factors at v-points 310 DO jj = mj0(ij0), mj1(ij1) 311 DO ji = mi0(ii0), mi1(ii1) 312 zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 313 pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 314 END DO 315 END DO 316 END DO 317 1077 ij0 = 124 ; ij1 = 125 1078 DO jk = 1, jpkm1 1079 DO jj = mj0(ij0), mj1(ij1) 1080 DO ji = mi0(ii0), mi1(ii1) 1081 SELECT CASE ( pout ) 1082 CASE( 'V' ) 1083 pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) & 1084 & * ( e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 1085 & + e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 1086 & ) / e2v(ji,jj) + e3v_0(ji,jj,jk) 1087 END SELECT 1088 END DO 1089 END DO 1090 END DO 1091 ! 318 1092 ii0 = 53 ; ii1 = 53 ! Ombai Strait (e1v was modified) 319 ij0 = 124 ; ij1 = 125 320 DO jk = 1, jpkm1 ! set the before scale factors at v-points 321 DO jj = mj0(ij0), mj1(ij1) 322 DO ji = mi0(ii0), mi1(ii1) 323 zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 324 pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 325 END DO 326 END DO 327 END DO 328 1093 ij0 = 124 ; ij1 = 125 1094 DO jk = 1, jpkm1 1095 DO jj = mj0(ij0), mj1(ij1) 1096 DO ji = mi0(ii0), mi1(ii1) 1097 SELECT CASE ( pout ) 1098 CASE( 'V' ) 1099 pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) & 1100 & * ( e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 1101 & + e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 1102 & ) / e2v(ji,jj) + e3v_0(ji,jj,jk) 1103 END SELECT 1104 END DO 1105 END DO 1106 END DO 1107 ! 329 1108 ii0 = 56 ; ii1 = 56 ! Timor Passage (e1v was modified) 330 ij0 = 124 ; ij1 = 125 331 DO jk = 1, jpkm1 ! set the before scale factors at v-points 332 DO jj = mj0(ij0), mj1(ij1) 333 DO ji = mi0(ii0), mi1(ii1) 334 zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 335 pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 336 END DO 337 END DO 338 END DO 339 1109 ij0 = 124 ; ij1 = 125 1110 DO jk = 1, jpkm1 1111 DO jj = mj0(ij0), mj1(ij1) 1112 DO ji = mi0(ii0), mi1(ii1) 1113 SELECT CASE ( pout ) 1114 CASE( 'V' ) 1115 pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) & 1116 & * ( e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 1117 & + e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 1118 & ) / e2v(ji,jj) + e3v_0(ji,jj,jk) 1119 END SELECT 1120 END DO 1121 END DO 1122 END DO 1123 ! 340 1124 ii0 = 55 ; ii1 = 55 ! West Halmahera Strait (e1v was modified) 341 ij0 = 141 ; ij1 = 142 342 DO jk = 1, jpkm1 ! set the before scale factors at v-points 343 DO jj = mj0(ij0), mj1(ij1) 344 DO ji = mi0(ii0), mi1(ii1) 345 zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 346 pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 347 END DO 348 END DO 349 END DO 350 1125 ij0 = 141 ; ij1 = 142 1126 DO jk = 1, jpkm1 1127 DO jj = mj0(ij0), mj1(ij1) 1128 DO ji = mi0(ii0), mi1(ii1) 1129 SELECT CASE ( pout ) 1130 CASE( 'V' ) 1131 pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) & 1132 & * ( e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 1133 & + e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 1134 & ) / e2v(ji,jj) + e3v_0(ji,jj,jk) 1135 END SELECT 1136 END DO 1137 END DO 1138 END DO 1139 ! 351 1140 ii0 = 58 ; ii1 = 58 ! East Halmahera Strait (e1v was modified) 352 ij0 = 141 ; ij1 = 142 353 DO jk = 1, jpkm1 ! set the before scale factors at v-points 354 DO jj = mj0(ij0), mj1(ij1) 355 DO ji = mi0(ii0), mi1(ii1) 356 zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 357 pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 358 END DO 359 END DO 360 END DO 361 362 ! 1141 ij0 = 141 ; ij1 = 142 1142 DO jk = 1, jpkm1 1143 DO jj = mj0(ij0), mj1(ij1) 1144 DO ji = mi0(ii0), mi1(ii1) 1145 SELECT CASE ( pout ) 1146 CASE( 'V' ) 1147 pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) & 1148 & * ( e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 1149 & + e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 1150 & ) / e2v(ji,jj) + e3v_0(ji,jj,jk) 1151 END SELECT 1152 END DO 1153 END DO 1154 END DO 363 1155 ENDIF 364 ! ! ======================1156 ! ! ===================== 365 1157 IF( cp_cfg == "orca" .AND. jp_cfg == 05 ) THEN ! ORCA R05 configuration 366 ! ! ====================== 1158 ! ! ===================== 1159 ! 367 1160 ii0 = 563 ; ii1 = 564 ! Gibraltar Strait (e2u was modified) 368 ij0 = 327 ; ij1 = 327 369 DO jk = 1, jpkm1 ! set the before scale factors at u-points 370 DO jj = mj0(ij0), mj1(ij1) 371 DO ji = mi0(ii0), mi1(ii1) 372 zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 373 pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 374 END DO 375 END DO 376 END DO 377 ! 378 ii0 = 627 ; ii1 = 628 ! Bosphore Strait (e2u was modified) 379 ij0 = 343 ; ij1 = 343 380 DO jk = 1, jpkm1 ! set the before scale factors at u-points 381 DO jj = mj0(ij0), mj1(ij1) 382 DO ji = mi0(ii0), mi1(ii1) 383 zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 384 pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 1161 ij0 = 327 ; ij1 = 327 1162 DO jk = 1, jpkm1 1163 DO jj = mj0(ij0), mj1(ij1) 1164 DO ji = mi0(ii0), mi1(ii1) 1165 SELECT CASE ( pout ) 1166 CASE( 'U' ) 1167 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) & 1168 & * ( e1t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 1169 & + e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 1170 & ) / e1u(ji,jj) + e3u_0(ji,jj,jk) 1171 CASE( 'F' ) 1172 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) & 1173 & * ( e1u(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3u_0(ji ,jj,jk) ) & 1174 & + e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 1175 & ) / e1f(ji,jj) + e3f_0(ji,jj,jk) 1176 END SELECT 1177 END DO 1178 END DO 1179 END DO 1180 ! 1181 ii0 = 627 ; ii1 = 628 ! Bosphorus Strait (e2u was modified) 1182 ij0 = 343 ; ij1 = 343 1183 DO jk = 1, jpkm1 1184 DO jj = mj0(ij0), mj1(ij1) 1185 DO ji = mi0(ii0), mi1(ii1) 1186 SELECT CASE ( pout ) 1187 CASE( 'U' ) 1188 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) & 1189 & * ( e1t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 1190 & + e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 1191 & ) / e1u(ji,jj) + e3u_0(ji,jj,jk) 1192 CASE( 'F' ) 1193 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) & 1194 & * ( e1u(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3u_0(ji ,jj,jk) ) & 1195 & + e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 1196 & ) / e1f(ji,jj) + e3f_0(ji,jj,jk) 1197 END SELECT 385 1198 END DO 386 1199 END DO … … 388 1201 ! 389 1202 ii0 = 93 ; ii1 = 94 ! Sumba Strait (e2u was modified) 390 ij0 = 232 ; ij1 = 232 391 DO jk = 1, jpkm1 ! set the before scale factors at u-points 392 DO jj = mj0(ij0), mj1(ij1) 393 DO ji = mi0(ii0), mi1(ii1) 394 zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 395 pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 1203 ij0 = 232 ; ij1 = 232 1204 DO jk = 1, jpkm1 1205 DO jj = mj0(ij0), mj1(ij1) 1206 DO ji = mi0(ii0), mi1(ii1) 1207 SELECT CASE ( pout ) 1208 CASE( 'U' ) 1209 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) & 1210 & * ( e1t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 1211 & + e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 1212 & ) / e1u(ji,jj) + e3u_0(ji,jj,jk) 1213 CASE( 'F' ) 1214 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) & 1215 & * ( e1u(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3u_0(ji ,jj,jk) ) & 1216 & + e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 1217 & ) / e1f(ji,jj) + e3f_0(ji,jj,jk) 1218 END SELECT 396 1219 END DO 397 1220 END DO … … 399 1222 ! 400 1223 ii0 = 103 ; ii1 = 103 ! Ombai Strait (e2u was modified) 401 ij0 = 232 ; ij1 = 232 402 DO jk = 1, jpkm1 ! set the before scale factors at u-points 403 DO jj = mj0(ij0), mj1(ij1) 404 DO ji = mi0(ii0), mi1(ii1) 405 zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 406 pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 1224 ij0 = 232 ; ij1 = 232 1225 DO jk = 1, jpkm1 1226 DO jj = mj0(ij0), mj1(ij1) 1227 DO ji = mi0(ii0), mi1(ii1) 1228 SELECT CASE ( pout ) 1229 CASE( 'U' ) 1230 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) & 1231 & * ( e1t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 1232 & + e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 1233 & ) / e1u(ji,jj) + e3u_0(ji,jj,jk) 1234 CASE( 'F' ) 1235 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) & 1236 & * ( e1u(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3u_0(ji ,jj,jk) ) & 1237 & + e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 1238 & ) / e1f(ji,jj) + e3f_0(ji,jj,jk) 1239 END SELECT 407 1240 END DO 408 1241 END DO … … 410 1243 ! 411 1244 ii0 = 15 ; ii1 = 15 ! Palk Strait (e2u was modified) 412 ij0 = 270 ; ij1 = 270 413 DO jk = 1, jpkm1 ! set the before scale factors at u-points 414 DO jj = mj0(ij0), mj1(ij1) 415 DO ji = mi0(ii0), mi1(ii1) 416 zvt = fse3t_b(ji,jj,jk) * e1t(ji,jj) 417 pe3u_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji+1,jj,jk) * e1t(ji+1,jj) ) / ( e1u(ji,jj) ) 1245 ij0 = 270 ; ij1 = 270 1246 DO jk = 1, jpkm1 1247 DO jj = mj0(ij0), mj1(ij1) 1248 DO ji = mi0(ii0), mi1(ii1) 1249 SELECT CASE ( pout ) 1250 CASE( 'U' ) 1251 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) & 1252 & * ( e1t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 1253 & + e1t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) & 1254 & ) / e1u(ji,jj) + e3u_0(ji,jj,jk) 1255 CASE( 'F' ) 1256 pe3_out(ji,jj,jk) = 0.5_wp * umask(ji,jj,jk) * umask(ji,jj+1,jk) & 1257 & * ( e1u(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3u_0(ji ,jj,jk) ) & 1258 & + e1u(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3u_0(ji+1,jj,jk) ) & 1259 & ) / e1f(ji,jj) + e3f_0(ji,jj,jk) 1260 END SELECT 418 1261 END DO 419 1262 END DO … … 421 1264 ! 422 1265 ii0 = 87 ; ii1 = 87 ! Lombok Strait (e1v was modified) 423 ij0 = 232 ; ij1 = 233 424 DO jk = 1, jpkm1 ! set the before scale factors at v-points 425 DO jj = mj0(ij0), mj1(ij1) 426 DO ji = mi0(ii0), mi1(ii1) 427 zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 428 pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 1266 ij0 = 232 ; ij1 = 233 1267 DO jk = 1, jpkm1 1268 DO jj = mj0(ij0), mj1(ij1) 1269 DO ji = mi0(ii0), mi1(ii1) 1270 SELECT CASE ( pout ) 1271 CASE( 'V' ) 1272 pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) & 1273 & * ( e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 1274 & + e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 1275 & ) / e2v(ji,jj) + e3v_0(ji,jj,jk) 1276 END SELECT 429 1277 END DO 430 1278 END DO … … 432 1280 ! 433 1281 ii0 = 662 ; ii1 = 662 ! Bab el Mandeb (e1v was modified) 434 ij0 = 276 ; ij1 = 276 435 DO jk = 1, jpkm1 ! set the before scale factors at v-points 436 DO jj = mj0(ij0), mj1(ij1) 437 DO ji = mi0(ii0), mi1(ii1) 438 zvt = fse3t_b(ji,jj,jk) * e2t(ji,jj) 439 pe3v_b(ji,jj,jk) = 0.5_wp * ( zvt + fse3t_b(ji,jj+1,jk) * e2t(ji,jj+1) ) / ( e2v(ji,jj) ) 440 END DO 441 END DO 442 END DO 443 ! 1282 ij0 = 276 ; ij1 = 276 1283 DO jk = 1, jpkm1 1284 DO jj = mj0(ij0), mj1(ij1) 1285 DO ji = mi0(ii0), mi1(ii1) 1286 SELECT CASE ( pout ) 1287 CASE( 'V' ) 1288 pe3_out(ji,jj,jk) = 0.5_wp * vmask(ji,jj,jk) & 1289 & * ( e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 1290 & + e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) & 1291 & ) / e2v(ji,jj) + e3v_0(ji,jj,jk) 1292 END SELECT 1293 END DO 1294 END DO 1295 END DO 444 1296 ENDIF 445 ! End of individual corrections to scale factors 446 447 IF( ln_zps ) THEN ! minimum of the e3t at partial cell level 448 DO jj = 2, jpjm1 449 DO ji = fs_2, fs_jpim1 450 iku = mbku(ji,jj) 451 ikv = mbkv(ji,jj) 452 pe3u_b(ji,jj,iku) = MIN( fse3t_b(ji,jj,iku), fse3t_b(ji+1,jj ,iku) ) 453 pe3v_b(ji,jj,ikv) = MIN( fse3t_b(ji,jj,ikv), fse3t_b(ji ,jj+1,ikv) ) 454 END DO 455 END DO 456 ENDIF 457 458 pe3u_b(:,:,:) = pe3u_b(:,:,:) - fse3u_0(:,:,:) ! anomaly to avoid zero along closed boundary/extra halos 459 pe3v_b(:,:,:) = pe3v_b(:,:,:) - fse3v_0(:,:,:) 460 CALL lbc_lnk( pe3u_b(:,:,:), 'U', 1. ) ! lateral boundary conditions 461 CALL lbc_lnk( pe3v_b(:,:,:), 'V', 1. ) 462 pe3u_b(:,:,:) = pe3u_b(:,:,:) + fse3u_0(:,:,:) ! recover the full scale factor 463 pe3v_b(:,:,:) = pe3v_b(:,:,:) + fse3v_0(:,:,:) 464 ! 465 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_2') 466 ! 467 END SUBROUTINE dom_vvl_2 468 469 #else 470 !!---------------------------------------------------------------------- 471 !! Default option : Empty routine 472 !!---------------------------------------------------------------------- 473 CONTAINS 474 SUBROUTINE dom_vvl 475 END SUBROUTINE dom_vvl 476 SUBROUTINE dom_vvl_2(kdum, pudum, pvdum ) 477 USE par_kind 478 INTEGER , INTENT(in ) :: kdum 479 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pudum, pvdum 480 END SUBROUTINE dom_vvl_2 481 #endif 1297 END SUBROUTINE dom_vvl_orca_fix 482 1298 483 1299 !!====================================================================== -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90
r3680 r4292 183 183 CALL iom_rstput( 0, 0, inum4, 'esigw', esigw ) 184 184 ! 185 CALL iom_rstput( 0, 0, inum4, 'e3t ', e3t )! ! scale factors186 CALL iom_rstput( 0, 0, inum4, 'e3u ', e3u)187 CALL iom_rstput( 0, 0, inum4, 'e3v ', e3v)188 CALL iom_rstput( 0, 0, inum4, 'e3w ', e3w)185 CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 ) ! ! scale factors 186 CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 ) 187 CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 ) 188 CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 ) 189 189 CALL iom_rstput( 0, 0, inum4, 'rx1', rx1 ) ! ! Max. grid stiffness ratio 190 190 ! 191 CALL iom_rstput( 0, 0, inum4, 'gdept ' , gdept )! ! stretched system192 CALL iom_rstput( 0, 0, inum4, 'gdepw ' , gdepw)191 CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d ) ! ! stretched system 192 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 193 193 ENDIF 194 194 … … 196 196 ! 197 197 IF( nmsh <= 6 ) THEN ! ! 3D vertical scale factors 198 CALL iom_rstput( 0, 0, inum4, 'e3t ', e3t)199 CALL iom_rstput( 0, 0, inum4, 'e3u ', e3u)200 CALL iom_rstput( 0, 0, inum4, 'e3v ', e3v)201 CALL iom_rstput( 0, 0, inum4, 'e3w ', e3w)198 CALL iom_rstput( 0, 0, inum4, 'e3t_0', e3t_0 ) 199 CALL iom_rstput( 0, 0, inum4, 'e3u_0', e3u_0 ) 200 CALL iom_rstput( 0, 0, inum4, 'e3v_0', e3v_0 ) 201 CALL iom_rstput( 0, 0, inum4, 'e3w_0', e3w_0 ) 202 202 ELSE ! ! 2D masked bottom ocean scale factors 203 203 DO jj = 1,jpj 204 204 DO ji = 1,jpi 205 e3tp(ji,jj) = e3t (ji,jj,mbkt(ji,jj)) * tmask(ji,jj,1)206 e3wp(ji,jj) = e3w (ji,jj,mbkt(ji,jj)) * tmask(ji,jj,1)205 e3tp(ji,jj) = e3t_0(ji,jj,mbkt(ji,jj)) * tmask(ji,jj,1) 206 e3wp(ji,jj) = e3w_0(ji,jj,mbkt(ji,jj)) * tmask(ji,jj,1) 207 207 END DO 208 208 END DO … … 212 212 ! 213 213 IF( nmsh <= 3 ) THEN ! ! 3D depth 214 CALL iom_rstput( 0, 0, inum4, 'gdept ', gdept, ktype = jp_r4 )214 CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 ) 215 215 DO jk = 1,jpk 216 216 DO jj = 1, jpjm1 217 217 DO ji = 1, fs_jpim1 ! vector opt. 218 zdepu(ji,jj,jk) = MIN( gdept (ji,jj,jk) , gdept(ji+1,jj ,jk) )219 zdepv(ji,jj,jk) = MIN( gdept (ji,jj,jk) , gdept(ji ,jj+1,jk) )218 zdepu(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji+1,jj ,jk) ) 219 zdepv(ji,jj,jk) = MIN( gdept_0(ji,jj,jk) , gdept_0(ji ,jj+1,jk) ) 220 220 END DO 221 221 END DO … … 224 224 CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r4 ) 225 225 CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r4 ) 226 CALL iom_rstput( 0, 0, inum4, 'gdepw ', gdepw, ktype = jp_r4 )226 CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 ) 227 227 ELSE ! ! 2D bottom depth 228 228 DO jj = 1,jpj 229 229 DO ji = 1,jpi 230 zprt(ji,jj) = gdept (ji,jj,mbkt(ji,jj) ) * tmask(ji,jj,1)231 zprw(ji,jj) = gdepw (ji,jj,mbkt(ji,jj)+1) * tmask(ji,jj,1)230 zprt(ji,jj) = gdept_0(ji,jj,mbkt(ji,jj) ) * tmask(ji,jj,1) 231 zprw(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) * tmask(ji,jj,1) 232 232 END DO 233 233 END DO … … 236 236 ENDIF 237 237 ! 238 CALL iom_rstput( 0, 0, inum4, 'gdept_ 0', gdept_0 )! ! reference z-coord.239 CALL iom_rstput( 0, 0, inum4, 'gdepw_ 0', gdepw_0)240 CALL iom_rstput( 0, 0, inum4, 'e3t_ 0' , e3t_0)241 CALL iom_rstput( 0, 0, inum4, 'e3w_ 0' , e3w_0)238 CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d ) ! ! reference z-coord. 239 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d ) 240 CALL iom_rstput( 0, 0, inum4, 'e3t_1d' , e3t_1d ) 241 CALL iom_rstput( 0, 0, inum4, 'e3w_1d' , e3w_1d ) 242 242 ENDIF 243 243 244 244 IF( ln_zco ) THEN 245 245 ! ! z-coordinate - full steps 246 CALL iom_rstput( 0, 0, inum4, 'gdept_ 0', gdept_0 )! ! depth247 CALL iom_rstput( 0, 0, inum4, 'gdepw_ 0', gdepw_0)248 CALL iom_rstput( 0, 0, inum4, 'e3t_ 0' , e3t_0 )! ! scale factors249 CALL iom_rstput( 0, 0, inum4, 'e3w_ 0' , e3w_0)246 CALL iom_rstput( 0, 0, inum4, 'gdept_1d', gdept_1d ) ! ! depth 247 CALL iom_rstput( 0, 0, inum4, 'gdepw_1d', gdepw_1d ) 248 CALL iom_rstput( 0, 0, inum4, 'e3t_1d' , e3t_1d ) ! ! scale factors 249 CALL iom_rstput( 0, 0, inum4, 'e3w_1d' , e3w_1d ) 250 250 ENDIF 251 251 ! ! ============================ -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r4245 r4292 88 88 !! vertical scale factors. 89 89 !! 90 !! ** Method : - reference 1D vertical coordinate (gdep._ 0, e3._0)90 !! ** Method : - reference 1D vertical coordinate (gdep._1d, e3._1d) 91 91 !! - read/set ocean depth and ocean levels (bathy, mbathy) 92 92 !! - vertical coordinate (gdep., e3.) depending on the … … 153 153 IF( nprint == 1 .AND. lwp ) THEN 154 154 WRITE(numout,*) ' MIN val mbathy ', MINVAL( mbathy(:,:) ), ' MAX ', MAXVAL( mbathy(:,:) ) 155 WRITE(numout,*) ' MIN val depth t ', MINVAL( fsdept(:,:,:) ), &156 & ' w ', MINVAL( fsdepw(:,:,:) ), '3w ', MINVAL( fsde3w(:,:,:) )157 WRITE(numout,*) ' MIN val e3 t ', MINVAL( fse3t(:,:,:) ), ' f ', MINVAL( fse3f(:,:,:) ), &158 & ' u ', MINVAL( fse3u(:,:,:) ), ' u ', MINVAL( fse3v(:,:,:) ), &159 & ' uw', MINVAL( fse3uw(:,:,:)), ' vw', MINVAL( fse3vw(:,:,:)), &160 & ' w ', MINVAL( fse3w(:,:,:) )161 162 WRITE(numout,*) ' MAX val depth t ', MAXVAL( fsdept(:,:,:) ), &163 & ' w ', MAXVAL( fsdepw(:,:,:) ), '3w ', MAXVAL( fsde3w(:,:,:) )164 WRITE(numout,*) ' MAX val e3 t ', MAXVAL( fse3t(:,:,:) ), ' f ', MAXVAL( fse3f(:,:,:) ), &165 & ' u ', MAXVAL( fse3u(:,:,:) ), ' u ', MAXVAL( fse3v(:,:,:) ), &166 & ' uw', MAXVAL( fse3uw(:,:,:)), ' vw', MAXVAL( fse3vw(:,:,:)), &167 & ' w ', MAXVAL( fse3w(:,:,:) )155 WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & 156 & ' w ', MINVAL( gdepw_0(:,:,:) ), '3w ', MINVAL( gdep3w_0(:,:,:) ) 157 WRITE(numout,*) ' MIN val e3 t ', MINVAL( e3t_0(:,:,:) ), ' f ', MINVAL( e3f_0(:,:,:) ), & 158 & ' u ', MINVAL( e3u_0(:,:,:) ), ' u ', MINVAL( e3v_0(:,:,:) ), & 159 & ' uw', MINVAL( e3uw_0(:,:,:)), ' vw', MINVAL( e3vw_0(:,:,:)), & 160 & ' w ', MINVAL( e3w_0(:,:,:) ) 161 162 WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ), & 163 & ' w ', MAXVAL( gdepw_0(:,:,:) ), '3w ', MAXVAL( gdep3w_0(:,:,:) ) 164 WRITE(numout,*) ' MAX val e3 t ', MAXVAL( e3t_0(:,:,:) ), ' f ', MAXVAL( e3f_0(:,:,:) ), & 165 & ' u ', MAXVAL( e3u_0(:,:,:) ), ' u ', MAXVAL( e3v_0(:,:,:) ), & 166 & ' uw', MAXVAL( e3uw_0(:,:,:)), ' vw', MAXVAL( e3vw_0(:,:,:)), & 167 & ' w ', MAXVAL( e3w_0(:,:,:) ) 168 168 ENDIF 169 169 ! … … 176 176 !!---------------------------------------------------------------------- 177 177 !! *** ROUTINE zgr_z *** 178 !! 178 !! 179 179 !! ** Purpose : set the depth of model levels and the resulting 180 180 !! vertical scale factors. … … 184 184 !! function the derivative of which gives the scale factors. 185 185 !! both depth and scale factors only depend on k (1d arrays). 186 !! w-level: gdepw_ 0 = fsdep(k)187 !! e3w_ 0(k) = dk(fsdep)(k) = fse3(k)188 !! t-level: gdept_ 0 = fsdep(k+0.5)189 !! e3t_ 0(k) = dk(fsdep)(k+0.5) = fse3(k+0.5)190 !! 191 !! ** Action : - gdept_ 0, gdepw_0: depth of T- and W-point (m)192 !! - e3t_ 0 , e3w_0: scale factors at T- and W-levels (m)186 !! w-level: gdepw_1d = gdep(k) 187 !! e3w_1d(k) = dk(gdep)(k) = e3(k) 188 !! t-level: gdept_1d = gdep(k+0.5) 189 !! e3t_1d(k) = dk(gdep)(k+0.5) = e3(k+0.5) 190 !! 191 !! ** Action : - gdept_1d, gdepw_1d : depth of T- and W-point (m) 192 !! - e3t_1d , e3w_1d : scale factors at T- and W-levels (m) 193 193 !! 194 194 !! Reference : Marti, Madec & Delecluse, 1992, JGR, 97, No8, 12,763-12,766. … … 262 262 zw = FLOAT( jk ) 263 263 zt = FLOAT( jk ) + 0.5_wp 264 gdepw_ 0(jk) = ( zw - 1 ) * za1265 gdept_ 0(jk) = ( zt - 1 ) * za1266 e3w_ 0(jk) = za1267 e3t_ 0(jk) = za1264 gdepw_1d(jk) = ( zw - 1 ) * za1 265 gdept_1d(jk) = ( zt - 1 ) * za1 266 e3w_1d (jk) = za1 267 e3t_1d (jk) = za1 268 268 END DO 269 269 ELSE ! Madec & Imbard 1996 function … … 272 272 zw = REAL( jk , wp ) 273 273 zt = REAL( jk , wp ) + 0.5_wp 274 gdepw_ 0(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth) / zacr ) ) )275 gdept_ 0(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth) / zacr ) ) )276 e3w_ 0(jk) = za0 + za1 * TANH( (zw-zkth) / zacr )277 e3t_ 0(jk) = za0 + za1 * TANH( (zt-zkth) / zacr )274 gdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth) / zacr ) ) ) 275 gdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth) / zacr ) ) ) 276 e3w_1d (jk) = za0 + za1 * TANH( (zw-zkth) / zacr ) 277 e3t_1d (jk) = za0 + za1 * TANH( (zt-zkth) / zacr ) 278 278 END DO 279 279 ELSE … … 282 282 zt = FLOAT( jk ) + 0.5_wp 283 283 ! Double tanh function 284 gdepw_ 0(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth ) / zacr ) ) &285 & + za2 * zacr2* LOG ( COSH( (zw-zkth2) / zacr2 ) ) )286 gdept_ 0(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth ) / zacr ) ) &287 & + za2 * zacr2* LOG ( COSH( (zt-zkth2) / zacr2 ) ) )288 e3w_ 0 (jk) = za0 + za1 * TANH( (zw-zkth ) / zacr )&289 & + za2 * TANH( (zw-zkth2) / zacr2 )290 e3t_ 0 (jk) = za0 + za1 * TANH( (zt-zkth ) / zacr )&291 & + za2 * TANH( (zt-zkth2) / zacr2 )284 gdepw_1d(jk) = ( zsur + za0 * zw + za1 * zacr * LOG ( COSH( (zw-zkth ) / zacr ) ) & 285 & + za2 * zacr2* LOG ( COSH( (zw-zkth2) / zacr2 ) ) ) 286 gdept_1d(jk) = ( zsur + za0 * zt + za1 * zacr * LOG ( COSH( (zt-zkth ) / zacr ) ) & 287 & + za2 * zacr2* LOG ( COSH( (zt-zkth2) / zacr2 ) ) ) 288 e3w_1d (jk) = za0 + za1 * TANH( (zw-zkth ) / zacr ) & 289 & + za2 * TANH( (zw-zkth2) / zacr2 ) 290 e3t_1d (jk) = za0 + za1 * TANH( (zt-zkth ) / zacr ) & 291 & + za2 * TANH( (zt-zkth2) / zacr2 ) 292 292 END DO 293 293 ENDIF 294 gdepw_ 0(1) = 0._wp ! force first w-level to be exactly at zero294 gdepw_1d(1) = 0._wp ! force first w-level to be exactly at zero 295 295 ENDIF 296 296 297 297 !!gm BUG in s-coordinate this does not work! 298 298 ! deepest/shallowest W level Above/Below ~10m 299 zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_ 0 )! ref. depth with tolerance (10% of minimum layer thickness)300 nlb10 = MINLOC( gdepw_ 0, mask = gdepw_0 > zrefdep, dim = 1 )! shallowest W level Below ~10m299 zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d ) ! ref. depth with tolerance (10% of minimum layer thickness) 300 nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m 301 301 nla10 = nlb10 - 1 ! deepest W level Above ~10m 302 302 !!gm end bug … … 305 305 WRITE(numout,*) 306 306 WRITE(numout,*) ' Reference z-coordinate depth and scale factors:' 307 WRITE(numout, "(9x,' level gdept gdepw e3t e3w')" )308 WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_ 0(jk), gdepw_0(jk), e3t_0(jk), e3w_0(jk), jk = 1, jpk )307 WRITE(numout, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" ) 308 WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, gdept_1d(jk), gdepw_1d(jk), e3t_1d(jk), e3w_1d(jk), jk = 1, jpk ) 309 309 ENDIF 310 310 DO jk = 1, jpk ! control positivity 311 IF( e3w_ 0 (jk) <= 0._wp .OR. e3t_0 (jk) <= 0._wp ) CALL ctl_stop( 'dom:zgr_z: e3w or e3t=< 0 ' )312 IF( gdepw_ 0(jk) < 0._wp .OR. gdept_0(jk) < 0._wp ) CALL ctl_stop( 'dom:zgr_z: gdepw or gdept< 0 ' )311 IF( e3w_1d (jk) <= 0._wp .OR. e3t_1d (jk) <= 0._wp ) CALL ctl_stop( 'dom:zgr_z: e3w_1d or e3t_1d =< 0 ' ) 312 IF( gdepw_1d(jk) < 0._wp .OR. gdept_1d(jk) < 0._wp ) CALL ctl_stop( 'dom:zgr_z: gdepw_1d or gdept_1d < 0 ' ) 313 313 END DO 314 314 ! … … 382 382 idta(:,:) = jpkm1 383 383 DO jk = 1, jpkm1 384 WHERE( gdept_ 0(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_0(jk+1) ) idta(:,:) = jk384 WHERE( gdept_1d(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_1d(jk+1) ) idta(:,:) = jk 385 385 END DO 386 386 ENDIF … … 388 388 IF(lwp) WRITE(numout,*) ' Depth = depthw(jpkm1)' 389 389 idta(:,:) = jpkm1 ! before last level 390 zdta(:,:) = gdepw_ 0(jpk) ! last w-point depth391 h_oce = gdepw_ 0(jpk)390 zdta(:,:) = gdepw_1d(jpk) ! last w-point depth 391 h_oce = gdepw_1d(jpk) 392 392 ENDIF 393 393 ELSE ! bump centered in the basin … … 398 398 r_bump = 50000._wp ! bump radius (meters) 399 399 h_bump = 2700._wp ! bump height (meters) 400 h_oce = gdepw_ 0(jpk)! background ocean depth (meters)400 h_oce = gdepw_1d(jpk) ! background ocean depth (meters) 401 401 IF(lwp) WRITE(numout,*) ' bump characteristics: ' 402 402 IF(lwp) WRITE(numout,*) ' bump center (i,j) = ', ii_bump, ii_bump … … 418 418 idta(:,:) = jpkm1 419 419 DO jk = 1, jpkm1 420 WHERE( gdept_ 0(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_0(jk+1) ) idta(:,:) = jk420 WHERE( gdept_1d(jk) < zdta(:,:) .AND. zdta(:,:) <= gdept_1d(jk+1) ) idta(:,:) = jk 421 421 END DO 422 422 ENDIF … … 460 460 CALL iom_close( inum ) 461 461 mbathy(:,:) = INT( bathy(:,:) ) 462 ! 462 ! ! ===================== 463 463 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN ! ORCA R2 configuration 464 ! 464 ! ! ===================== 465 465 IF( nn_cla == 0 ) THEN 466 466 ii0 = 140 ; ii1 = 140 ! Gibraltar Strait open … … 531 531 IF ( .not. ln_sco ) THEN !== set a minimum depth ==! 532 532 IF( rn_hmin < 0._wp ) THEN ; ik = - INT( rn_hmin ) ! from a nb of level 533 ELSE ; ik = MINLOC( gdepw_ 0, mask = gdepw_0> rn_hmin, dim = 1 ) ! from a depth533 ELSE ; ik = MINLOC( gdepw_1d, mask = gdepw_1d > rn_hmin, dim = 1 ) ! from a depth 534 534 ENDIF 535 zhmin = gdepw_ 0(ik+1) ! minimum depth = ik+1 w-levels535 zhmin = gdepw_1d(ik+1) ! minimum depth = ik+1 w-levels 536 536 WHERE( bathy(:,:) <= 0._wp ) ; bathy(:,:) = 0._wp ! min=0 over the lands 537 537 ELSE WHERE ; bathy(:,:) = MAX( zhmin , bathy(:,:) ) ! min=zhmin over the oceans … … 798 798 ! 799 799 DO jk = 1, jpk 800 gdept(:,:,jk) = gdept_0(jk)801 gdepw(:,:,jk) = gdepw_0(jk)802 gdep3w(:,:,jk) = gdepw_0(jk)803 e3t (:,:,jk) = e3t_0(jk)804 e3u (:,:,jk) = e3t_0(jk)805 e3v (:,:,jk) = e3t_0(jk)806 e3f (:,:,jk) = e3t_0(jk)807 e3w (:,:,jk) = e3w_0(jk)808 e3uw(:,:,jk) = e3w_0(jk)809 e3vw(:,:,jk) = e3w_0(jk)800 gdept_0 (:,:,jk) = gdept_1d(jk) 801 gdepw_0 (:,:,jk) = gdepw_1d(jk) 802 gdep3w_0(:,:,jk) = gdepw_1d(jk) 803 e3t_0 (:,:,jk) = e3t_1d (jk) 804 e3u_0 (:,:,jk) = e3t_1d (jk) 805 e3v_0 (:,:,jk) = e3t_1d (jk) 806 e3f_0 (:,:,jk) = e3t_1d (jk) 807 e3w_0 (:,:,jk) = e3w_1d (jk) 808 e3uw_0 (:,:,jk) = e3w_1d (jk) 809 e3vw_0 (:,:,jk) = e3w_1d (jk) 810 810 END DO 811 811 ! … … 832 832 !! with partial steps on 3d arrays ( i, j, k ). 833 833 !! 834 !! w-level: gdepw (i,j,k) = fsdep(k)835 !! e3w (i,j,k) = dk(fsdep)(k) = fse3(i,j,k)836 !! t-level: gdept (i,j,k) = fsdep(k+0.5)837 !! e3t (i,j,k) = dk(fsdep)(k+0.5) = fse3(i,j,k+0.5)834 !! w-level: gdepw_0(i,j,k) = gdep(k) 835 !! e3w_0(i,j,k) = dk(gdep)(k) = e3(i,j,k) 836 !! t-level: gdept_0(i,j,k) = gdep(k+0.5) 837 !! e3t_0(i,j,k) = dk(gdep)(k+0.5) = e3(i,j,k+0.5) 838 838 !! 839 839 !! With the help of the bathymetric file ( bathymetry_depth_ORCA_R2.nc), … … 843 843 !! - bathy = 0 => mbathy = 0 844 844 !! - 1 < mbathy < jpkm1 845 !! - bathy > gdepw (jpk) => mbathy = jpkm1845 !! - bathy > gdepw_0(jpk) => mbathy = jpkm1 846 846 !! 847 847 !! Then, for each case, we find the new depth at t- and w- levels … … 855 855 !! schemes. 856 856 !! 857 !! c a u t i o n : gdept_ 0, gdepw_0 and e3._0are positives858 !! - - - - - - - gdept , gdepwand e3. are positives857 !! c a u t i o n : gdept_1d, gdepw_1d and e3._1d are positives 858 !! - - - - - - - gdept_0, gdepw_0 and e3. are positives 859 859 !! 860 860 !! Reference : Pacanowsky & Gnanadesikan 1997, Mon. Wea. Rev., 126, 3248-3270. … … 892 892 ! bathymetry in level (from bathy_meter) 893 893 ! =================== 894 zmax = gdepw_ 0(jpk) + e3t_0(jpk) ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_0(jpkm1) )894 zmax = gdepw_1d(jpk) + e3t_1d(jpk) ! maximum depth (i.e. the last ocean level thickness <= 2*e3t_1d(jpkm1) ) 895 895 bathy(:,:) = MIN( zmax , bathy(:,:) ) ! bounded value of bathy (min already set at the end of zgr_bat) 896 896 WHERE( bathy(:,:) == 0._wp ) ; mbathy(:,:) = 0 ! land : set mbathy to 0 … … 900 900 ! Compute mbathy for ocean points (i.e. the number of ocean levels) 901 901 ! find the number of ocean levels such that the last level thickness 902 ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_ 0(where903 ! e3t_ 0is the reference level thickness902 ! is larger than the minimum of e3zps_min and e3zps_rat * e3t_1d (where 903 ! e3t_1d is the reference level thickness 904 904 DO jk = jpkm1, 1, -1 905 zdepth = gdepw_ 0(jk) + MIN( e3zps_min, e3t_0(jk)*e3zps_rat )905 zdepth = gdepw_1d(jk) + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat ) 906 906 WHERE( 0._wp < bathy(:,:) .AND. bathy(:,:) <= zdepth ) mbathy(:,:) = jk-1 907 907 END DO … … 909 909 ! Scale factors and depth at T- and W-points 910 910 DO jk = 1, jpk ! intitialization to the reference z-coordinate 911 gdept (:,:,jk) = gdept_0(jk)912 gdepw (:,:,jk) = gdepw_0(jk)913 e3t (:,:,jk) = e3t_0(jk)914 e3w (:,:,jk) = e3w_0(jk)911 gdept_0(:,:,jk) = gdept_1d(jk) 912 gdepw_0(:,:,jk) = gdepw_1d(jk) 913 e3t_0 (:,:,jk) = e3t_1d (jk) 914 e3w_0 (:,:,jk) = e3w_1d (jk) 915 915 END DO 916 916 ! … … 922 922 IF( ik == jpkm1 ) THEN 923 923 zdepwp = bathy(ji,jj) 924 ze3tp = bathy(ji,jj) - gdepw_ 0(ik)925 ze3wp = 0.5_wp * e3w_ 0(ik) * ( 1._wp + ( ze3tp/e3t_0(ik) ) )926 e3t (ji,jj,ik ) = ze3tp927 e3t (ji,jj,ik+1) = ze3tp928 e3w (ji,jj,ik ) = ze3wp929 e3w (ji,jj,ik+1) = ze3tp930 gdepw (ji,jj,ik+1) = zdepwp931 gdept (ji,jj,ik ) = gdept_0(ik-1) + ze3wp932 gdept (ji,jj,ik+1) = gdept(ji,jj,ik) + ze3tp924 ze3tp = bathy(ji,jj) - gdepw_1d(ik) 925 ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) ) 926 e3t_0(ji,jj,ik ) = ze3tp 927 e3t_0(ji,jj,ik+1) = ze3tp 928 e3w_0(ji,jj,ik ) = ze3wp 929 e3w_0(ji,jj,ik+1) = ze3tp 930 gdepw_0(ji,jj,ik+1) = zdepwp 931 gdept_0(ji,jj,ik ) = gdept_1d(ik-1) + ze3wp 932 gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp 933 933 ! 934 934 ELSE ! standard case 935 IF( bathy(ji,jj) <= gdepw_ 0(ik+1) ) THEN ; gdepw(ji,jj,ik+1) = bathy(ji,jj)936 ELSE ; gdepw (ji,jj,ik+1) = gdepw_0(ik+1)935 IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN ; gdepw_0(ji,jj,ik+1) = bathy(ji,jj) 936 ELSE ; gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1) 937 937 ENDIF 938 !gm Bug? check the gdepw_ 0938 !gm Bug? check the gdepw_1d 939 939 ! ... on ik 940 gdept (ji,jj,ik) = gdepw_0(ik) + ( gdepw (ji,jj,ik+1) - gdepw_0(ik) ) &941 & * ((gdept_0( ik ) - gdepw_0(ik) ) &942 & / ( gdepw_0( ik+1) - gdepw_0(ik) ))943 e3t (ji,jj,ik) = e3t_0 (ik) * ( gdepw (ji,jj,ik+1) - gdepw_0(ik) ) &944 & / ( gdepw_ 0( ik+1) - gdepw_0(ik) )945 e3w (ji,jj,ik) = 0.5_wp * ( gdepw(ji,jj,ik+1) + gdepw_0(ik+1) - 2._wp * gdepw_0(ik) ) &946 & * ( e3w_ 0(ik) / ( gdepw_0(ik+1) - gdepw_0(ik) ) )940 gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) ) & 941 & * ((gdept_1d( ik ) - gdepw_1d(ik) ) & 942 & / ( gdepw_1d( ik+1) - gdepw_1d(ik) )) 943 e3t_0(ji,jj,ik) = e3t_1d (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik) ) & 944 & / ( gdepw_1d( ik+1) - gdepw_1d(ik) ) 945 e3w_0(ji,jj,ik) = 0.5_wp * ( gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) ) & 946 & * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) ) 947 947 ! ... on ik+1 948 e3w (ji,jj,ik+1) = e3t(ji,jj,ik)949 e3t (ji,jj,ik+1) = e3t(ji,jj,ik)950 gdept (ji,jj,ik+1) = gdept(ji,jj,ik) + e3t(ji,jj,ik)948 e3w_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) 949 e3t_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik) 950 gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik) 951 951 ENDIF 952 952 ENDIF … … 959 959 ik = mbathy(ji,jj) 960 960 IF( ik > 0 ) THEN ! ocean point only 961 e3tp (ji,jj) = e3t (ji,jj,ik)962 e3wp (ji,jj) = e3w (ji,jj,ik)961 e3tp (ji,jj) = e3t_0(ji,jj,ik) 962 e3wp (ji,jj) = e3w_0(ji,jj,ik) 963 963 ! test 964 zdiff= gdepw (ji,jj,ik+1) - gdept(ji,jj,ik )964 zdiff= gdepw_0(ji,jj,ik+1) - gdept_0(ji,jj,ik ) 965 965 IF( zdiff <= 0._wp .AND. lwp ) THEN 966 966 it = it + 1 967 967 WRITE(numout,*) ' it = ', it, ' ik = ', ik, ' (i,j) = ', ji, jj 968 968 WRITE(numout,*) ' bathy = ', bathy(ji,jj) 969 WRITE(numout,*) ' gdept = ', gdept(ji,jj,ik), ' gdepw = ', gdepw(ji,jj,ik+1), ' zdiff = ', zdiff970 WRITE(numout,*) ' e3tp = ', e3t (ji,jj,ik), ' e3wp = ', e3w(ji,jj,ik )969 WRITE(numout,*) ' gdept_0 = ', gdept_0(ji,jj,ik), ' gdepw_0 = ', gdepw_0(ji,jj,ik+1), ' zdiff = ', zdiff 970 WRITE(numout,*) ' e3tp = ', e3t_0 (ji,jj,ik), ' e3wp = ', e3w_0 (ji,jj,ik ) 971 971 ENDIF 972 972 ENDIF … … 976 976 ! Scale factors and depth at U-, V-, UW and VW-points 977 977 DO jk = 1, jpk ! initialisation to z-scale factors 978 e3u (:,:,jk) = e3t_0(jk)979 e3v (:,:,jk) = e3t_0(jk)980 e3uw (:,:,jk) = e3w_0(jk)981 e3vw (:,:,jk) = e3w_0(jk)978 e3u_0 (:,:,jk) = e3t_1d(jk) 979 e3v_0 (:,:,jk) = e3t_1d(jk) 980 e3uw_0(:,:,jk) = e3w_1d(jk) 981 e3vw_0(:,:,jk) = e3w_1d(jk) 982 982 END DO 983 983 DO jk = 1,jpk ! Computed as the minimum of neighbooring scale factors 984 984 DO jj = 1, jpjm1 985 985 DO ji = 1, fs_jpim1 ! vector opt. 986 e3u (ji,jj,jk) = MIN( e3t(ji,jj,jk), e3t(ji+1,jj,jk) )987 e3v (ji,jj,jk) = MIN( e3t(ji,jj,jk), e3t(ji,jj+1,jk) )988 e3uw (ji,jj,jk) = MIN( e3w(ji,jj,jk), e3w(ji+1,jj,jk) )989 e3vw (ji,jj,jk) = MIN( e3w(ji,jj,jk), e3w(ji,jj+1,jk) )990 END DO 991 END DO 992 END DO 993 CALL lbc_lnk( e3u , 'U', 1._wp ) ; CALL lbc_lnk( e3uw, 'U', 1._wp ) ! lateral boundary conditions994 CALL lbc_lnk( e3v , 'V', 1._wp ) ; CALL lbc_lnk( e3vw, 'V', 1._wp )986 e3u_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji+1,jj,jk) ) 987 e3v_0 (ji,jj,jk) = MIN( e3t_0(ji,jj,jk), e3t_0(ji,jj+1,jk) ) 988 e3uw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji+1,jj,jk) ) 989 e3vw_0(ji,jj,jk) = MIN( e3w_0(ji,jj,jk), e3w_0(ji,jj+1,jk) ) 990 END DO 991 END DO 992 END DO 993 CALL lbc_lnk( e3u_0 , 'U', 1._wp ) ; CALL lbc_lnk( e3uw_0, 'U', 1._wp ) ! lateral boundary conditions 994 CALL lbc_lnk( e3v_0 , 'V', 1._wp ) ; CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 995 995 ! 996 996 DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries) 997 WHERE( e3u (:,:,jk) == 0._wp ) e3u (:,:,jk) = e3t_0(jk)998 WHERE( e3v (:,:,jk) == 0._wp ) e3v (:,:,jk) = e3t_0(jk)999 WHERE( e3uw (:,:,jk) == 0._wp ) e3uw(:,:,jk) = e3w_0(jk)1000 WHERE( e3vw (:,:,jk) == 0._wp ) e3vw(:,:,jk) = e3w_0(jk)997 WHERE( e3u_0 (:,:,jk) == 0._wp ) e3u_0 (:,:,jk) = e3t_1d(jk) 998 WHERE( e3v_0 (:,:,jk) == 0._wp ) e3v_0 (:,:,jk) = e3t_1d(jk) 999 WHERE( e3uw_0(:,:,jk) == 0._wp ) e3uw_0(:,:,jk) = e3w_1d(jk) 1000 WHERE( e3vw_0(:,:,jk) == 0._wp ) e3vw_0(:,:,jk) = e3w_1d(jk) 1001 1001 END DO 1002 1002 1003 1003 ! Scale factor at F-point 1004 1004 DO jk = 1, jpk ! initialisation to z-scale factors 1005 e3f (:,:,jk) = e3t_0(jk)1005 e3f_0(:,:,jk) = e3t_1d(jk) 1006 1006 END DO 1007 1007 DO jk = 1, jpk ! Computed as the minimum of neighbooring V-scale factors 1008 1008 DO jj = 1, jpjm1 1009 1009 DO ji = 1, fs_jpim1 ! vector opt. 1010 e3f (ji,jj,jk) = MIN( e3v(ji,jj,jk), e3v(ji+1,jj,jk) )1011 END DO 1012 END DO 1013 END DO 1014 CALL lbc_lnk( e3f , 'F', 1._wp ) ! Lateral boundary conditions1010 e3f_0(ji,jj,jk) = MIN( e3v_0(ji,jj,jk), e3v_0(ji+1,jj,jk) ) 1011 END DO 1012 END DO 1013 END DO 1014 CALL lbc_lnk( e3f_0, 'F', 1._wp ) ! Lateral boundary conditions 1015 1015 ! 1016 1016 DO jk = 1, jpk ! set to z-scale factor if zero (i.e. along closed boundaries) 1017 WHERE( e3f (:,:,jk) == 0._wp ) e3f(:,:,jk) = e3t_0(jk)1017 WHERE( e3f_0(:,:,jk) == 0._wp ) e3f_0(:,:,jk) = e3t_1d(jk) 1018 1018 END DO 1019 1019 !!gm bug ? : must be a do loop with mj0,mj1 1020 1020 ! 1021 e3t (:,mj0(1),:) = e3t(:,mj0(2),:) ! we duplicate factor scales for jj = 1 and jj = 21022 e3w (:,mj0(1),:) = e3w(:,mj0(2),:)1023 e3u (:,mj0(1),:) = e3u(:,mj0(2),:)1024 e3v (:,mj0(1),:) = e3v(:,mj0(2),:)1025 e3f (:,mj0(1),:) = e3f(:,mj0(2),:)1021 e3t_0(:,mj0(1),:) = e3t_0(:,mj0(2),:) ! we duplicate factor scales for jj = 1 and jj = 2 1022 e3w_0(:,mj0(1),:) = e3w_0(:,mj0(2),:) 1023 e3u_0(:,mj0(1),:) = e3u_0(:,mj0(2),:) 1024 e3v_0(:,mj0(1),:) = e3v_0(:,mj0(2),:) 1025 e3f_0(:,mj0(1),:) = e3f_0(:,mj0(2),:) 1026 1026 1027 1027 ! Control of the sign 1028 IF( MINVAL( e3t (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3t<= 0' )1029 IF( MINVAL( e3w (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3w<= 0' )1030 IF( MINVAL( gdept (:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdepw< 0' )1031 IF( MINVAL( gdepw (:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdepw< 0' )1028 IF( MINVAL( e3t_0 (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3t_0 <= 0' ) 1029 IF( MINVAL( e3w_0 (:,:,:) ) <= 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r e3w_0 <= 0' ) 1030 IF( MINVAL( gdept_0(:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdept_0 < 0' ) 1031 IF( MINVAL( gdepw_0(:,:,:) ) < 0._wp ) CALL ctl_stop( ' zgr_zps : e r r o r gdepw_0 < 0' ) 1032 1032 1033 ! Compute gdep3w (vertical sum of e3w)1034 gdep3w (:,:,1) = 0.5_wp * e3w(:,:,1)1033 ! Compute gdep3w_0 (vertical sum of e3w) 1034 gdep3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) 1035 1035 DO jk = 2, jpk 1036 gdep3w (:,:,jk) = gdep3w(:,:,jk-1) + e3w(:,:,jk)1036 gdep3w_0(:,:,jk) = gdep3w_0(:,:,jk-1) + e3w_0(:,:,jk) 1037 1037 END DO 1038 1038 … … 1043 1043 DO ji = 1, jpi 1044 1044 ik = MAX( mbathy(ji,jj), 1 ) 1045 zprt(ji,jj,1) = e3t (ji,jj,ik)1046 zprt(ji,jj,2) = e3w (ji,jj,ik)1047 zprt(ji,jj,3) = e3u (ji,jj,ik)1048 zprt(ji,jj,4) = e3v (ji,jj,ik)1049 zprt(ji,jj,5) = e3f (ji,jj,ik)1050 zprt(ji,jj,6) = gdep3w (ji,jj,ik)1045 zprt(ji,jj,1) = e3t_0 (ji,jj,ik) 1046 zprt(ji,jj,2) = e3w_0 (ji,jj,ik) 1047 zprt(ji,jj,3) = e3u_0 (ji,jj,ik) 1048 zprt(ji,jj,4) = e3v_0 (ji,jj,ik) 1049 zprt(ji,jj,5) = e3f_0 (ji,jj,ik) 1050 zprt(ji,jj,6) = gdep3w_0(ji,jj,ik) 1051 1051 END DO 1052 1052 END DO … … 1387 1387 ENDIF 1388 1388 1389 CALL lbc_lnk( e3t , 'T', 1._wp )1390 CALL lbc_lnk( e3u , 'U', 1._wp )1391 CALL lbc_lnk( e3v , 'V', 1._wp )1392 CALL lbc_lnk( e3f , 'F', 1._wp )1393 CALL lbc_lnk( e3w , 'W', 1._wp )1394 CALL lbc_lnk( e3uw , 'U', 1._wp )1395 CALL lbc_lnk( e3vw , 'V', 1._wp )1396 1397 fsdepw(:,:,:) = gdepw (:,:,:)1398 fsde3w(:,:,:) = gdep3w (:,:,:)1399 ! 1400 where (e3t (:,:,:).eq.0.0) e3t(:,:,:) = 1._wp1401 where (e3u (:,:,:).eq.0.0) e3u(:,:,:) = 1._wp1402 where (e3v (:,:,:).eq.0.0) e3v(:,:,:) = 1._wp1403 where (e3f (:,:,:).eq.0.0) e3f(:,:,:) = 1._wp1404 where (e3w (:,:,:).eq.0.0) e3w(:,:,:) = 1._wp1405 where (e3uw (:,:,:).eq.0.0) e3uw(:,:,:) = 1._wp1406 where (e3vw (:,:,:).eq.0.0) e3vw(:,:,:) = 1._wp1389 CALL lbc_lnk( e3t_0 , 'T', 1._wp ) 1390 CALL lbc_lnk( e3u_0 , 'U', 1._wp ) 1391 CALL lbc_lnk( e3v_0 , 'V', 1._wp ) 1392 CALL lbc_lnk( e3f_0 , 'F', 1._wp ) 1393 CALL lbc_lnk( e3w_0 , 'W', 1._wp ) 1394 CALL lbc_lnk( e3uw_0, 'U', 1._wp ) 1395 CALL lbc_lnk( e3vw_0, 'V', 1._wp ) 1396 1397 fsdepw(:,:,:) = gdepw_0 (:,:,:) 1398 fsde3w(:,:,:) = gdep3w_0(:,:,:) 1399 ! 1400 where (e3t_0 (:,:,:).eq.0.0) e3t_0(:,:,:) = 1.0 1401 where (e3u_0 (:,:,:).eq.0.0) e3u_0(:,:,:) = 1.0 1402 where (e3v_0 (:,:,:).eq.0.0) e3v_0(:,:,:) = 1.0 1403 where (e3f_0 (:,:,:).eq.0.0) e3f_0(:,:,:) = 1.0 1404 where (e3w_0 (:,:,:).eq.0.0) e3w_0(:,:,:) = 1.0 1405 where (e3uw_0 (:,:,:).eq.0.0) e3uw_0(:,:,:) = 1.0 1406 where (e3vw_0 (:,:,:).eq.0.0) e3vw_0(:,:,:) = 1.0 1407 1407 1408 1408 #if defined key_agrif … … 1411 1411 ! 1412 1412 IF((nbondi == -1).OR.(nbondi == 2)) THEN 1413 e3u (1,:,:) = e3u(2,:,:)1413 e3u_0(1,:,:) = e3u_0(2,:,:) 1414 1414 ENDIF 1415 1415 ! 1416 1416 IF((nbondi == 1).OR.(nbondi == 2)) THEN 1417 e3u (nlci-1,:,:) = e3u(nlci-2,:,:)1417 e3u_0(nlci-1,:,:) = e3u_0(nlci-2,:,:) 1418 1418 ENDIF 1419 1419 ! 1420 1420 IF((nbondj == -1).OR.(nbondj == 2)) THEN 1421 e3v (:,1,:) = e3v(:,2,:)1421 e3v_0(:,1,:) = e3v_0(:,2,:) 1422 1422 ENDIF 1423 1423 ! 1424 1424 IF((nbondj == 1).OR.(nbondj == 2)) THEN 1425 e3v (:,nlcj-1,:) = e3v(:,nlcj-2,:)1425 e3v_0(:,nlcj-1,:) = e3v_0(:,nlcj-2,:) 1426 1426 ENDIF 1427 1427 ! … … 1429 1429 #endif 1430 1430 1431 fsdept(:,:,:) = gdept (:,:,:)1432 fsdepw(:,:,:) = gdepw (:,:,:)1433 fsde3w(:,:,:) = gdep3w (:,:,:)1434 fse3t (:,:,:) = e3t (:,:,:)1435 fse3u (:,:,:) = e3u (:,:,:)1436 fse3v (:,:,:) = e3v (:,:,:)1437 fse3f (:,:,:) = e3f (:,:,:)1438 fse3w (:,:,:) = e3w (:,:,:)1439 fse3uw(:,:,:) = e3uw (:,:,:)1440 fse3vw(:,:,:) = e3vw (:,:,:)1431 fsdept(:,:,:) = gdept_0 (:,:,:) 1432 fsdepw(:,:,:) = gdepw_0 (:,:,:) 1433 fsde3w(:,:,:) = gdep3w_0(:,:,:) 1434 fse3t (:,:,:) = e3t_0 (:,:,:) 1435 fse3u (:,:,:) = e3u_0 (:,:,:) 1436 fse3v (:,:,:) = e3v_0 (:,:,:) 1437 fse3f (:,:,:) = e3f_0 (:,:,:) 1438 fse3w (:,:,:) = e3w_0 (:,:,:) 1439 fse3uw(:,:,:) = e3uw_0 (:,:,:) 1440 fse3vw(:,:,:) = e3vw_0 (:,:,:) 1441 1441 !! 1442 1442 ! HYBRID : … … 1453 1453 1454 1454 IF( nprint == 1 .AND. lwp ) THEN ! min max values over the local domain 1455 WRITE(numout,*) ' MIN val mbathy ', MINVAL( mbathy(:,:) ), ' MAX ', MAXVAL( mbathy(:,:) )1456 WRITE(numout,*) ' MIN val depth t ', MINVAL( fsdept(:,:,:) ), &1457 & ' w ', MINVAL( fsdepw(:,:,:) ), '3w ' , MINVAL( fsde3w(:,:,:) )1458 WRITE(numout,*) ' MIN val e3 t ', MINVAL( fse3t (:,:,:) ), ' f ' , MINVAL( fse3f(:,:,:) ), &1459 & ' u ', MINVAL( fse3u (:,:,:) ), ' u ' , MINVAL( fse3v(:,:,:) ), &1460 & ' uw', MINVAL( fse3uw(:,:,:) ), ' vw' , MINVAL( fse3vw(:,:,:) ), &1461 & ' w ', MINVAL( fse3w(:,:,:) )1462 1463 WRITE(numout,*) ' MAX val depth t ', MAXVAL( fsdept(:,:,:) ), &1464 & ' w ', MAXVAL( fsdepw(:,:,:) ), '3w ' , MAXVAL( fsde3w(:,:,:) )1465 WRITE(numout,*) ' MAX val e3 t ', MAXVAL( fse3t (:,:,:) ), ' f ' , MAXVAL( fse3f(:,:,:) ), &1466 & ' u ', MAXVAL( fse3u (:,:,:) ), ' u ' , MAXVAL( fse3v(:,:,:) ), &1467 & ' uw', MAXVAL( fse3uw(:,:,:) ), ' vw' , MAXVAL( fse3vw(:,:,:) ), &1468 & ' w ', MAXVAL( fse3w(:,:,:) )1455 WRITE(numout,*) ' MIN val mbathy ', MINVAL( mbathy(:,:) ), ' MAX ', MAXVAL( mbathy(:,:) ) 1456 WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & 1457 & ' w ', MINVAL( gdepw_0(:,:,:) ), '3w ' , MINVAL( gdep3w_0(:,:,:) ) 1458 WRITE(numout,*) ' MIN val e3 t ', MINVAL( e3t_0 (:,:,:) ), ' f ' , MINVAL( e3f_0 (:,:,:) ), & 1459 & ' u ', MINVAL( e3u_0 (:,:,:) ), ' u ' , MINVAL( e3v_0 (:,:,:) ), & 1460 & ' uw', MINVAL( e3uw_0 (:,:,:) ), ' vw' , MINVAL( e3vw_0 (:,:,:) ), & 1461 & ' w ', MINVAL( e3w_0 (:,:,:) ) 1462 1463 WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ), & 1464 & ' w ', MAXVAL( gdepw_0(:,:,:) ), '3w ' , MAXVAL( gdep3w_0(:,:,:) ) 1465 WRITE(numout,*) ' MAX val e3 t ', MAXVAL( e3t_0 (:,:,:) ), ' f ' , MAXVAL( e3f_0 (:,:,:) ), & 1466 & ' u ', MAXVAL( e3u_0 (:,:,:) ), ' u ' , MAXVAL( e3v_0 (:,:,:) ), & 1467 & ' uw', MAXVAL( e3uw_0 (:,:,:) ), ' vw' , MAXVAL( e3vw_0 (:,:,:) ), & 1468 & ' w ', MAXVAL( e3w_0 (:,:,:) ) 1469 1469 ENDIF 1470 1470 ! END DO … … 1473 1473 WRITE(numout,*) ' domzgr: vertical coordinates : point (1,1,k) bathy = ', bathy(1,1), hbatt(1,1) 1474 1474 WRITE(numout,*) ' ~~~~~~ --------------------' 1475 WRITE(numout,"(9x,' level gdept gdepw gde3w e3t e3w ')") 1476 WRITE(numout,"(10x,i4,4f9.2)") ( jk, fsdept(1,1,jk), fsdepw(1,1,jk), & 1477 & fse3t (1,1,jk), fse3w (1,1,jk), jk=1,jpk ) 1478 iip1 = MIN(20, jpiglo-1) ! for config with i smaller than 20 points 1479 ijp1 = MIN(20, jpjglo-1) ! for config with j smaller than 20 points 1480 DO jj = mj0(ijp1), mj1(ijp1) 1481 DO ji = mi0(iip1), mi1(iip1) 1475 WRITE(numout,"(9x,' level gdept_0 gdepw_0 e3t_0 e3w_0')") 1476 WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(1,1,jk), gdepw_0(1,1,jk), & 1477 & e3t_0 (1,1,jk) , e3w_0 (1,1,jk) , jk=1,jpk ) 1478 DO jj = mj0(20), mj1(20) 1479 DO ji = mi0(20), mi1(20) 1482 1480 WRITE(numout,*) 1483 WRITE(numout,*) ' domzgr: vertical coordinates : point (',iip1,',',ijp1,',k) bathy = ', & 1484 & bathy(ji,jj), hbatt(ji,jj) 1481 WRITE(numout,*) ' domzgr: vertical coordinates : point (20,20,k) bathy = ', bathy(ji,jj), hbatt(ji,jj) 1485 1482 WRITE(numout,*) ' ~~~~~~ --------------------' 1486 WRITE(numout,"(9x,' level gdept gdepw gde3w e3t e3w ')") 1487 WRITE(numout,"(10x,i4,4f9.2)") ( jk, fsdept(ji,jj,jk), fsdepw(ji,jj,jk), & 1488 & fse3t (ji,jj,jk), fse3w (ji,jj,jk), jk=1,jpk ) 1489 END DO 1490 END DO 1491 iip1 = MIN( 74, jpiglo-1) 1492 ijp1 = MIN( 100, jpjglo-1) 1493 DO jj = mj0(ijp1), mj1(ijp1) 1494 DO ji = mi0(iip1), mi1(iip1) 1483 WRITE(numout,"(9x,' level gdept_0 gdepw_0 e3t_0 e3w_0')") 1484 WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(ji,jj,jk), gdepw_0(ji,jj,jk), & 1485 & e3t_0 (ji,jj,jk) , e3w_0 (ji,jj,jk) , jk=1,jpk ) 1486 END DO 1487 END DO 1488 DO jj = mj0(74), mj1(74) 1489 DO ji = mi0(100), mi1(100) 1495 1490 WRITE(numout,*) 1496 WRITE(numout,*) ' domzgr: vertical coordinates : point (',iip1,',',ijp1,',k) bathy = ', & 1497 & bathy(ji,jj), hbatt(ji,jj) 1491 WRITE(numout,*) ' domzgr: vertical coordinates : point (100,74,k) bathy = ', bathy(ji,jj), hbatt(ji,jj) 1498 1492 WRITE(numout,*) ' ~~~~~~ --------------------' 1499 WRITE(numout,"(9x,' level gdept gdepw gde3w e3t e3w')")1500 WRITE(numout,"(10x,i4,4f9.2)") ( jk, fsdept(ji,jj,jk), fsdepw(ji,jj,jk), &1501 & fse3t (ji,jj,jk), fse3w (ji,jj,jk), jk=1,jpk )1493 WRITE(numout,"(9x,' level gdept_0 gdepw_0 e3t_0 e3w_0')") 1494 WRITE(numout,"(10x,i4,4f9.2)") ( jk, gdept_0(ji,jj,jk), gdepw_0(ji,jj,jk), & 1495 & e3t_0 (ji,jj,jk) , e3w_0 (ji,jj,jk) , jk=1,jpk ) 1502 1496 END DO 1503 1497 END DO … … 1617 1611 zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 1618 1612 zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 1619 gdept (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigt3(ji,jj,jk)+rn_hc*zcoeft )1620 gdepw (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigw3(ji,jj,jk)+rn_hc*zcoefw )1621 gdep3w (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsi3w3(ji,jj,jk)+rn_hc*zcoeft )1613 gdept_0 (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigt3(ji,jj,jk)+rn_hc*zcoeft ) 1614 gdepw_0 (ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsigw3(ji,jj,jk)+rn_hc*zcoefw ) 1615 gdep3w_0(ji,jj,jk) = ( scosrf(ji,jj) + (hbatt(ji,jj)-rn_hc)*z_gsi3w3(ji,jj,jk)+rn_hc*zcoeft ) 1622 1616 END DO 1623 1617 ! … … 1640 1634 & / ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 1641 1635 ! 1642 e3t (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigt3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) )1643 e3u (ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigtu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) )1644 e3v (ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigtv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) )1645 e3f (ji,jj,jk) = ( (hbatf(ji,jj)-rn_hc)*z_esigtf3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) )1636 e3t_0(ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigt3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 1637 e3u_0(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigtu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 1638 e3v_0(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigtv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 1639 e3f_0(ji,jj,jk) = ( (hbatf(ji,jj)-rn_hc)*z_esigtf3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 1646 1640 ! 1647 e3w (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigw3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) )1648 e3uw (ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigwu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) )1649 e3vw (ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigwv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) )1641 e3w_0 (ji,jj,jk) = ( (hbatt(ji,jj)-rn_hc)*z_esigw3 (ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 1642 e3uw_0(ji,jj,jk) = ( (hbatu(ji,jj)-rn_hc)*z_esigwu3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 1643 e3vw_0(ji,jj,jk) = ( (hbatv(ji,jj)-rn_hc)*z_esigwv3(ji,jj,jk) + rn_hc/REAL(jpkm1,wp) ) 1650 1644 END DO 1651 1645 END DO … … 1745 1739 1746 1740 DO jk = 1, jpk 1747 gdept (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigt3(ji,jj,jk)1748 gdepw (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigw3(ji,jj,jk)1749 gdep3w (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsi3w3(ji,jj,jk)1741 gdept_0 (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigt3(ji,jj,jk) 1742 gdepw_0 (ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsigw3(ji,jj,jk) 1743 gdep3w_0(ji,jj,jk) = (scosrf(ji,jj)+hbatt(ji,jj))*z_gsi3w3(ji,jj,jk) 1750 1744 END DO 1751 1745 … … 1769 1763 ( hbatt(ji,jj)+hbatt(ji,jj+1) ) 1770 1764 1771 e3t (ji,jj,jk)=(scosrf(ji,jj)+hbatt(ji,jj))*z_esigt3(ji,jj,jk)1772 e3u (ji,jj,jk)=(scosrf(ji,jj)+hbatu(ji,jj))*z_esigtu3(ji,jj,jk)1773 e3v (ji,jj,jk)=(scosrf(ji,jj)+hbatv(ji,jj))*z_esigtv3(ji,jj,jk)1774 e3f (ji,jj,jk)=(scosrf(ji,jj)+hbatf(ji,jj))*z_esigtf3(ji,jj,jk)1765 e3t_0(ji,jj,jk)=(scosrf(ji,jj)+hbatt(ji,jj))*z_esigt3(ji,jj,jk) 1766 e3u_0(ji,jj,jk)=(scosrf(ji,jj)+hbatu(ji,jj))*z_esigtu3(ji,jj,jk) 1767 e3v_0(ji,jj,jk)=(scosrf(ji,jj)+hbatv(ji,jj))*z_esigtv3(ji,jj,jk) 1768 e3f_0(ji,jj,jk)=(scosrf(ji,jj)+hbatf(ji,jj))*z_esigtf3(ji,jj,jk) 1775 1769 ! 1776 e3w (ji,jj,jk)=hbatt(ji,jj)*z_esigw3(ji,jj,jk)1777 e3uw (ji,jj,jk)=hbatu(ji,jj)*z_esigwu3(ji,jj,jk)1778 e3vw (ji,jj,jk)=hbatv(ji,jj)*z_esigwv3(ji,jj,jk)1770 e3w_0(ji,jj,jk)=hbatt(ji,jj)*z_esigw3(ji,jj,jk) 1771 e3uw_0(ji,jj,jk)=hbatu(ji,jj)*z_esigwu3(ji,jj,jk) 1772 e3vw_0(ji,jj,jk)=hbatv(ji,jj)*z_esigwv3(ji,jj,jk) 1779 1773 END DO 1780 1774 1781 1775 ENDDO 1782 1776 ENDDO 1777 ! 1778 CALL lbc_lnk(e3t_0 ,'T',1.) ; CALL lbc_lnk(e3u_0 ,'T',1.) 1779 CALL lbc_lnk(e3v_0 ,'T',1.) ; CALL lbc_lnk(e3f_0 ,'T',1.) 1780 CALL lbc_lnk(e3w_0 ,'T',1.) 1781 CALL lbc_lnk(e3uw_0,'T',1.) ; CALL lbc_lnk(e3vw_0,'T',1.) 1783 1782 ! 1784 1783 ! ! ============= … … 1838 1837 zcoeft = ( REAL(jk,wp) - 0.5_wp ) / REAL(jpkm1,wp) 1839 1838 zcoefw = ( REAL(jk,wp) - 1.0_wp ) / REAL(jpkm1,wp) 1840 gdept (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigt(jk) + hift(:,:)*zcoeft )1841 gdepw (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigw(jk) + hift(:,:)*zcoefw )1842 gdep3w (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsi3w(jk) + hift(:,:)*zcoeft )1839 gdept_0 (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigt(jk) + hift(:,:)*zcoeft ) 1840 gdepw_0 (:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsigw(jk) + hift(:,:)*zcoefw ) 1841 gdep3w_0(:,:,jk) = ( scosrf(:,:) + (hbatt(:,:)-hift(:,:))*z_gsi3w(jk) + hift(:,:)*zcoeft ) 1843 1842 END DO 1844 1843 !!gm: e3uw, e3vw can be suppressed (modif in dynzdf, dynzdf_iso, zdfbfr) (save 2 3D arrays) … … 1846 1845 DO ji = 1, jpi 1847 1846 DO jk = 1, jpk 1848 e3t (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigt(jk) + hift(ji,jj)/REAL(jpkm1,wp) )1849 e3u (ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigt(jk) + hifu(ji,jj)/REAL(jpkm1,wp) )1850 e3v (ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigt(jk) + hifv(ji,jj)/REAL(jpkm1,wp) )1851 e3f (ji,jj,jk) = ( (hbatf(ji,jj)-hiff(ji,jj))*z_esigt(jk) + hiff(ji,jj)/REAL(jpkm1,wp) )1847 e3t_0(ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigt(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 1848 e3u_0(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigt(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 1849 e3v_0(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigt(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 1850 e3f_0(ji,jj,jk) = ( (hbatf(ji,jj)-hiff(ji,jj))*z_esigt(jk) + hiff(ji,jj)/REAL(jpkm1,wp) ) 1852 1851 ! 1853 e3w (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigw(jk) + hift(ji,jj)/REAL(jpkm1,wp) )1854 e3uw (ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigw(jk) + hifu(ji,jj)/REAL(jpkm1,wp) )1855 e3vw (ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigw(jk) + hifv(ji,jj)/REAL(jpkm1,wp) )1852 e3w_0 (ji,jj,jk) = ( (hbatt(ji,jj)-hift(ji,jj))*z_esigw(jk) + hift(ji,jj)/REAL(jpkm1,wp) ) 1853 e3uw_0(ji,jj,jk) = ( (hbatu(ji,jj)-hifu(ji,jj))*z_esigw(jk) + hifu(ji,jj)/REAL(jpkm1,wp) ) 1854 e3vw_0(ji,jj,jk) = ( (hbatv(ji,jj)-hifv(ji,jj))*z_esigw(jk) + hifv(ji,jj)/REAL(jpkm1,wp) ) 1856 1855 END DO 1857 1856 END DO … … 1878 1877 !!---------------------------------------------------------------------- 1879 1878 ! 1880 pf = ( TANH( rn_theta * ( -(pk-0.5_wp) / REAL(jpkm1 ,wp) + rn_thetb ) ) &1879 pf = ( TANH( rn_theta * ( -(pk-0.5_wp) / REAL(jpkm1) + rn_thetb ) ) & 1881 1880 & - TANH( rn_thetb * rn_theta ) ) & 1882 1881 & * ( COSH( rn_theta ) & … … 1904 1903 ! 1905 1904 IF ( rn_theta == 0 ) then ! uniform sigma 1906 pf1 = - ( pk1 - 0.5_wp ) / REAL( jpkm1 ,wp)1905 pf1 = - ( pk1 - 0.5_wp ) / REAL( jpkm1 ) 1907 1906 ELSE ! stretched sigma 1908 pf1 = ( 1._wp - pbb ) * ( SINH( rn_theta*(-(pk1-0.5_wp)/REAL(jpkm1 ,wp)) ) ) / SINH( rn_theta ) &1909 & + pbb * ( (TANH( rn_theta*( (-(pk1-0.5_wp)/REAL(jpkm1 ,wp)) + 0.5_wp) ) - TANH( 0.5_wp * rn_theta ) ) &1907 pf1 = ( 1._wp - pbb ) * ( SINH( rn_theta*(-(pk1-0.5_wp)/REAL(jpkm1)) ) ) / SINH( rn_theta ) & 1908 & + pbb * ( (TANH( rn_theta*( (-(pk1-0.5_wp)/REAL(jpkm1)) + 0.5_wp) ) - TANH( 0.5_wp * rn_theta ) ) & 1910 1909 & / ( 2._wp * TANH( 0.5_wp * rn_theta ) ) ) 1911 1910 ENDIF -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr_substitute.h90
r2528 r4292 8 8 !! 3.1 ! 2009-02 (G. Madec, M. Leclair) pure z* coordinate 9 9 !!---------------------------------------------------------------------- 10 ! reference for s- or zps-coordinate (3D no time dependency) 11 # define fsdept_0(i,j,k) gdept(i,j,k) 12 # define fsdepw_0(i,j,k) gdepw(i,j,k) 13 # define fsde3w_0(i,j,k) gdep3w(i,j,k) 14 # define fse3t_0(i,j,k) e3t(i,j,k) 15 # define fse3u_0(i,j,k) e3u(i,j,k) 16 # define fse3v_0(i,j,k) e3v(i,j,k) 17 # define fse3f_0(i,j,k) e3f(i,j,k) 18 # define fse3w_0(i,j,k) e3w(i,j,k) 19 # define fse3uw_0(i,j,k) e3uw(i,j,k) 20 # define fse3vw_0(i,j,k) e3vw(i,j,k) 10 21 11 #if defined key_vvl 22 ! s* or z*-coordinate (3D + time dependency) + use of additional now arrays (..._1) 23 # define fsdept(i,j,k) gdept_1(i,j,k) 24 # define fsdepw(i,j,k) gdepw_1(i,j,k) 25 # define fsde3w(i,j,k) gdep3w_1(i,j,k) 26 # define fse3t(i,j,k) e3t_1(i,j,k) 27 # define fse3u(i,j,k) e3u_1(i,j,k) 28 # define fse3v(i,j,k) e3v_1(i,j,k) 29 # define fse3f(i,j,k) e3f_1(i,j,k) 30 # define fse3w(i,j,k) e3w_1(i,j,k) 31 # define fse3uw(i,j,k) e3uw_1(i,j,k) 32 # define fse3vw(i,j,k) e3vw_1(i,j,k) 12 ! s* or z*-coordinate (3D + time dependency) + use of additional now arrays (..._n) 33 13 34 14 # define fse3t_b(i,j,k) e3t_b(i,j,k) 35 15 # define fse3u_b(i,j,k) e3u_b(i,j,k) 36 16 # define fse3v_b(i,j,k) e3v_b(i,j,k) 37 # define fse3uw_b(i,j,k) (fse3uw_0(i,j,k)*(1.+sshu_b(i,j)*muu(i,j,k)))38 # define fse3vw_b(i,j,k) (fse3vw_0(i,j,k)*(1.+sshv_b(i,j)*muv(i,j,k)))17 # define fse3uw_b(i,j,k) e3uw_b(i,j,k) 18 # define fse3vw_b(i,j,k) e3vw_b(i,j,k) 39 19 40 # define fsdept_n(i,j,k) (fsdept_0(i,j,k)*(1.+sshn(i,j)*mut(i,j,k)))41 # define fsdepw_n(i,j,k) (fsdepw_0(i,j,k)*(1.+sshn(i,j)*mut(i,j,k)))42 # define fsde3w_n(i,j,k) (fsde3w_0(i,j,k)*(1.+sshn(i,j)*mut(i,j,k))-sshn(i,j))43 # define fse3t_n(i,j,k) (fse3t_0(i,j,k)*(1.+sshn(i,j)*mut(i,j,k)))44 # define fse3u_n(i,j,k) (fse3u_0(i,j,k)*(1.+sshu_n(i,j)*muu(i,j,k)))45 # define fse3v_n(i,j,k) (fse3v_0(i,j,k)*(1.+sshv_n(i,j)*muv(i,j,k)))46 # define fse3f_n(i,j,k) (fse3f_0(i,j,k)*(1.+sshf_n(i,j)*muf(i,j,k)))47 # define fse3w_n(i,j,k) (fse3w_0(i,j,k)*(1.+sshn(i,j)*mut(i,j,k)))48 # define fse3uw_n(i,j,k) (fse3uw_0(i,j,k)*(1.+sshu_n(i,j)*muu(i,j,k)))49 # define fse3vw_n(i,j,k) (fse3vw_0(i,j,k)*(1.+sshv_n(i,j)*muv(i,j,k)))20 # define fsdept_n(i,j,k) gdept_n(i,j,k) 21 # define fsdepw_n(i,j,k) gdepw_n(i,j,k) 22 # define fsde3w_n(i,j,k) gdep3w_n(i,j,k) 23 # define fse3t_n(i,j,k) e3t_n(i,j,k) 24 # define fse3u_n(i,j,k) e3u_n(i,j,k) 25 # define fse3v_n(i,j,k) e3v_n(i,j,k) 26 # define fse3f_n(i,j,k) e3f_n(i,j,k) 27 # define fse3w_n(i,j,k) e3w_n(i,j,k) 28 # define fse3uw_n(i,j,k) e3uw_n(i,j,k) 29 # define fse3vw_n(i,j,k) e3vw_n(i,j,k) 50 30 51 # define fse3t_m(i,j,k) (fse3t_0(i,j,k)*(1.+ssh_m(i,j)*mut(i,j,k))) 31 # define fse3t_a(i,j,k) e3t_a(i,j,k) 32 # define fse3u_a(i,j,k) e3u_a(i,j,k) 33 # define fse3v_a(i,j,k) e3v_a(i,j,k) 52 34 53 # define fse3t_a(i,j,k) (fse3t_0(i,j,k)*(1.+ssha(i,j)*mut(i,j,k))) 54 # define fse3u_a(i,j,k) (fse3u_0(i,j,k)*(1.+sshu_a(i,j)*muu(i,j,k))) 55 # define fse3v_a(i,j,k) (fse3v_0(i,j,k)*(1.+sshv_a(i,j)*muv(i,j,k))) 35 # define fse3t_m(i,j) e3t_m(i,j) 36 37 ! This part should be removed one day ... 38 ! ... In that case all occurence of the above statement functions 39 ! have to be replaced in the code by xxx_n 40 # define fsdept(i,j,k) gdept_n(i,j,k) 41 # define fsdepw(i,j,k) gdepw_n(i,j,k) 42 # define fsde3w(i,j,k) gdep3w_n(i,j,k) 43 # define fse3t(i,j,k) e3t_n(i,j,k) 44 # define fse3u(i,j,k) e3u_n(i,j,k) 45 # define fse3v(i,j,k) e3v_n(i,j,k) 46 # define fse3f(i,j,k) e3f_n(i,j,k) 47 # define fse3w(i,j,k) e3w_n(i,j,k) 48 # define fse3uw(i,j,k) e3uw_n(i,j,k) 49 # define fse3vw(i,j,k) e3vw_n(i,j,k) 56 50 57 51 #else 58 52 ! z- or s-coordinate (1D or 3D + no time dependency) use reference in all cases 59 # define fsdept(i,j,k) fsdept_0(i,j,k)60 # define fsdepw(i,j,k) fsdepw_0(i,j,k)61 # define fsde3w(i,j,k) fsde3w_0(i,j,k)62 # define fse3t(i,j,k) fse3t_0(i,j,k)63 # define fse3u(i,j,k) fse3u_0(i,j,k)64 # define fse3v(i,j,k) fse3v_0(i,j,k)65 # define fse3f(i,j,k) fse3f_0(i,j,k)66 # define fse3w(i,j,k) fse3w_0(i,j,k)67 # define fse3uw(i,j,k) fse3uw_0(i,j,k)68 # define fse3vw(i,j,k) fse3vw_0(i,j,k)69 53 70 # define fse3t_b(i,j,k) fse3t_0(i,j,k)71 # define fse3u_b(i,j,k) fse3u_0(i,j,k)72 # define fse3v_b(i,j,k) fse3v_0(i,j,k)73 # define fse3uw_b(i,j,k) fse3uw_0(i,j,k)74 # define fse3vw_b(i,j,k) fse3vw_0(i,j,k)54 # define fse3t_b(i,j,k) e3t_0(i,j,k) 55 # define fse3u_b(i,j,k) e3u_0(i,j,k) 56 # define fse3v_b(i,j,k) e3v_0(i,j,k) 57 # define fse3uw_b(i,j,k) e3uw_0(i,j,k) 58 # define fse3vw_b(i,j,k) e3vw_0(i,j,k) 75 59 76 # define fsdept_n(i,j,k) fsdept_0(i,j,k)77 # define fsdepw_n(i,j,k) fsdepw_0(i,j,k)78 # define fsde3w_n(i,j,k) fsde3w_0(i,j,k)79 # define fse3t_n(i,j,k) fse3t_0(i,j,k)80 # define fse3u_n(i,j,k) fse3u_0(i,j,k)81 # define fse3v_n(i,j,k) fse3v_0(i,j,k)82 # define fse3f_n(i,j,k) fse3f_0(i,j,k)83 # define fse3w_n(i,j,k) fse3w_0(i,j,k)84 # define fse3uw_n(i,j,k) fse3uw_0(i,j,k)85 # define fse3vw_n(i,j,k) fse3vw_0(i,j,k)60 # define fsdept_n(i,j,k) gdept_0(i,j,k) 61 # define fsdepw_n(i,j,k) gdepw_0(i,j,k) 62 # define fsde3w_n(i,j,k) gdep3w_0(i,j,k) 63 # define fse3t_n(i,j,k) e3t_0(i,j,k) 64 # define fse3u_n(i,j,k) e3u_0(i,j,k) 65 # define fse3v_n(i,j,k) e3v_0(i,j,k) 66 # define fse3f_n(i,j,k) e3f_0(i,j,k) 67 # define fse3w_n(i,j,k) e3w_0(i,j,k) 68 # define fse3uw_n(i,j,k) e3uw_0(i,j,k) 69 # define fse3vw_n(i,j,k) e3vw_0(i,j,k) 86 70 87 # define fse3t_m(i,j,k) fse3t_0(i,j,k) 71 # define fse3t_a(i,j,k) e3t_0(i,j,k) 72 # define fse3u_a(i,j,k) e3u_0(i,j,k) 73 # define fse3v_a(i,j,k) e3v_0(i,j,k) 88 74 89 # define fse3t_a(i,j,k) fse3t_0(i,j,k) 90 # define fse3u_a(i,j,k) fse3u_0(i,j,k) 91 # define fse3v_a(i,j,k) fse3v_0(i,j,k) 75 # define fse3t_m(i,j) e3t_0(i,j,1) 76 77 ! This part should be removed one day ... 78 ! ... In that case all occurence of the above statement functions 79 ! have to be replaced in the code by xxx_n 80 # define fsdept(i,j,k) gdept_0(i,j,k) 81 # define fsdepw(i,j,k) gdepw_0(i,j,k) 82 # define fsde3w(i,j,k) gdep3w_0(i,j,k) 83 # define fse3t(i,j,k) e3t_0(i,j,k) 84 # define fse3u(i,j,k) e3u_0(i,j,k) 85 # define fse3v(i,j,k) e3v_0(i,j,k) 86 # define fse3f(i,j,k) e3f_0(i,j,k) 87 # define fse3w(i,j,k) e3w_0(i,j,k) 88 # define fse3uw(i,j,k) e3uw_0(i,j,k) 89 # define fse3vw(i,j,k) e3vw_0(i,j,k) 90 92 91 #endif 93 92 !!---------------------------------------------------------------------- -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/dtatsd.F90
r4245 r4292 221 221 DO ji = 1, jpi 222 222 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 223 zl = fsdept_0(ji,jj,jk)224 IF( zl < gdept_ 0(1 ) ) THEN ! above the first level of data223 zl = gdept_0(ji,jj,jk) 224 IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data 225 225 ztp(jk) = ptsd(ji,jj,1 ,jp_tem) 226 226 zsp(jk) = ptsd(ji,jj,1 ,jp_sal) 227 ELSEIF( zl > gdept_ 0(jpk) ) THEN ! below the last level of data227 ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data 228 228 ztp(jk) = ptsd(ji,jj,jpkm1,jp_tem) 229 229 zsp(jk) = ptsd(ji,jj,jpkm1,jp_sal) 230 230 ELSE ! inbetween : vertical interpolation between jkk & jkk+1 231 231 DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1) 232 IF( (zl-gdept_ 0(jkk)) * (zl-gdept_0(jkk+1)) <= 0._wp ) THEN233 zi = ( zl - gdept_ 0(jkk) ) / (gdept_0(jkk+1)-gdept_0(jkk))232 IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 233 zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 234 234 ztp(jk) = ptsd(ji,jj,jkk,jp_tem) + ( ptsd(ji,jj,jkk+1,jp_tem) - ptsd(ji,jj,jkk,jp_tem) ) * zi 235 235 zsp(jk) = ptsd(ji,jj,jkk,jp_sal) + ( ptsd(ji,jj,jkk+1,jp_sal) - ptsd(ji,jj,jkk,jp_sal) ) * zi … … 259 259 ik = mbkt(ji,jj) 260 260 IF( ik > 1 ) THEN 261 zl = ( gdept_ 0(ik) - fsdept_0(ji,jj,ik) ) / ( gdept_0(ik) - gdept_0(ik-1) )261 zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 262 262 ptsd(ji,jj,ik,jp_tem) = (1.-zl) * ptsd(ji,jj,ik,jp_tem) + zl * ptsd(ji,jj,ik-1,jp_tem) 263 263 ptsd(ji,jj,ik,jp_sal) = (1.-zl) * ptsd(ji,jj,ik,jp_sal) + zl * ptsd(ji,jj,ik-1,jp_sal) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90
r4245 r4292 94 94 neuler = 1 ! Set time-step indicator at nit000 (leap-frog) 95 95 CALL rst_read ! Read the restart file 96 ! ! define e3u_b, e3v_b from e3t_b read in restart file97 CALL dom_vvl_2( nit000, fse3u_b(:,:,:), fse3v_b(:,:,:) )98 96 CALL day_init ! model calendar (using both namelist and restart infos) 99 97 ELSE … … 144 142 ENDDO 145 143 ENDIF 146 ! ! define e3u_b, e3v_b from e3t_b initialized in domzgr147 CALL dom_vvl_2( nit000, fse3u_b(:,:,:), fse3v_b(:,:,:) )148 144 ! 149 145 ENDIF … … 230 226 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 231 227 ! 232 zh1 = gdept_ 0( 1 )233 zh2 = gdept_ 0(jpkm1)228 zh1 = gdept_1d( 1 ) 229 zh2 = gdept_1d(jpkm1) 234 230 ! 235 231 zslope = ( zt1 - zt2 ) / ( zh1 - zh2 ) … … 411 407 WRITE(numout,*) 412 408 WRITE(numout,*) ' Initial temperature and salinity profiles:' 413 WRITE(numout, "(9x,' level gdept_ 0temperature salinity ')" )414 WRITE(numout, "(10x, i4, 3f10.2)" ) ( jk, gdept_ 0(jk), tsn(2,2,jk,jp_tem), tsn(2,2,jk,jp_sal), jk = 1, jpk )409 WRITE(numout, "(9x,' level gdept_1d temperature salinity ')" ) 410 WRITE(numout, "(10x, i4, 3f10.2)" ) ( jk, gdept_1d(jk), tsn(2,2,jk,jp_tem), tsn(2,2,jk,jp_sal), jk = 1, jpk ) 415 411 ENDIF 416 412 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90
r4147 r4292 767 767 DO jj = 2, jpjm1 768 768 DO ji = 2, jpim1 769 zu(ji,jj,1) = - ( fse3u(ji,jj,1) - ssh u_n(ji,jj) * znad)770 zv(ji,jj,1) = - ( fse3v(ji,jj,1) - ssh v_n(ji,jj) * znad)769 zu(ji,jj,1) = - ( fse3u(ji,jj,1) - sshn(ji,jj) * znad) ! probable bug: changed from sshu_n for ztilde compilation 770 zv(ji,jj,1) = - ( fse3v(ji,jj,1) - sshn(ji,jj) * znad) ! probable bug: changed from sshv_n for ztilde compilation 771 771 END DO 772 772 END DO -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90
r3764 r4292 17 17 !! 3.3 ! 2010-09 (D. Storkey, E.O'Dea) Bug fix for BDY module 18 18 !! 3.3 ! 2011-03 (P. Oddo) Bug fix for time-splitting+(BDY-OBC) and not VVL 19 !! 3.5 ! 2013-07 (J. Chanut) Compliant with time splitting changes 19 20 !!------------------------------------------------------------------------- 20 21 … … 42 43 USE wrk_nemo ! Memory Allocation 43 44 USE prtctl ! Print control 45 USE dynspg_ts ! Barotropic velocities 46 44 47 #if defined key_agrif 45 48 USE agrif_opa_interp … … 103 106 REAL(wp) :: zue3a, zue3n, zue3b, zuf, zec ! local scalars 104 107 REAL(wp) :: zve3a, zve3n, zve3b, zvf ! - - 108 REAL(wp), POINTER, DIMENSION(:,:) :: zua, zva 105 109 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3u_f, ze3v_f 106 110 !!---------------------------------------------------------------------- … … 109 113 ! 110 114 CALL wrk_alloc( jpi,jpj,jpk, ze3u_f, ze3v_f ) 115 IF ( lk_dynspg_ts ) CALL wrk_alloc( jpi,jpj, zua, zva ) 111 116 ! 112 117 IF( kt == nit000 ) THEN … … 127 132 ! 128 133 #else 134 135 # if defined key_dynspg_exp 129 136 ! Next velocity : Leap-frog time stepping 130 137 ! ------------- … … 147 154 END DO 148 155 ENDIF 149 156 # endif 157 158 # if defined key_dynspg_ts 159 ! Ensure below that barotropic velocities match time splitting estimate 160 ! Compute actual transport and replace it with ts estimate at "after" time step 161 zua(:,:) = 0._wp 162 zva(:,:) = 0._wp 163 IF (lk_vvl) THEN 164 DO jk = 1, jpkm1 165 zua(:,:) = zua(:,:) + fse3u_a(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) 166 zva(:,:) = zva(:,:) + fse3v_a(:,:,jk) * va(:,:,jk) * vmask(:,:,jk) 167 END DO 168 DO jk = 1, jpkm1 169 ua(:,:,jk) = ( ua(:,:,jk) - zua(:,:) * hur_e(:,:) + ua_b(:,:) ) * umask(:,:,jk) 170 va(:,:,jk) = ( va(:,:,jk) - zva(:,:) * hvr_e(:,:) + va_b(:,:) ) * vmask(:,:,jk) 171 END DO 172 ELSE 173 DO jk = 1, jpkm1 174 zua(:,:) = zua(:,:) + fse3u(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) 175 zva(:,:) = zva(:,:) + fse3v(:,:,jk) * va(:,:,jk) * vmask(:,:,jk) 176 END DO 177 DO jk = 1, jpkm1 178 ua(:,:,jk) = ( ua(:,:,jk) - zua(:,:) * hur(:,:) + ua_b(:,:) ) *umask(:,:,jk) 179 va(:,:,jk) = ( va(:,:,jk) - zva(:,:) * hvr(:,:) + va_b(:,:) ) *vmask(:,:,jk) 180 END DO 181 ENDIF 182 183 IF (lk_dynspg_ts.AND.(.NOT.ln_bt_fw)) THEN 184 ! Remove advective velocity from "now velocities" 185 ! prior to asselin filtering 186 ! In the forward case, this is done below after asselin filtering 187 DO jk = 1, jpkm1 188 un(:,:,jk) = ( un(:,:,jk) - un_adv(:,:) + un_b(:,:) )*umask(:,:,jk) 189 vn(:,:,jk) = ( vn(:,:,jk) - vn_adv(:,:) + vn_b(:,:) )*vmask(:,:,jk) 190 END DO 191 ENDIF 192 # endif 150 193 151 194 ! Update after velocity on domain lateral boundaries … … 194 237 vn(:,:,jk) = va(:,:,jk) 195 238 END DO 239 IF (lk_vvl) THEN 240 DO jk = 1, jpkm1 241 fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 242 fse3u_b(:,:,jk) = fse3u_n(:,:,jk) 243 fse3v_b(:,:,jk) = fse3v_n(:,:,jk) 244 ENDDO 245 ENDIF 196 246 ELSE !* Leap-Frog : Asselin filter and swap 197 247 ! ! =============! … … 201 251 DO jj = 1, jpj 202 252 DO ji = 1, jpi 203 zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2.e0 * un(ji,jj,jk) + ua(ji,jj,jk) )204 zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2.e0 * vn(ji,jj,jk) + va(ji,jj,jk) )253 zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2.e0_wp * un(ji,jj,jk) + ua(ji,jj,jk) ) 254 zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2.e0_wp * vn(ji,jj,jk) + va(ji,jj,jk) ) 205 255 ! 206 256 ub(ji,jj,jk) = zuf ! ub <-- filtered velocity … … 214 264 ELSE ! Variable volume ! 215 265 ! ! ================! 266 ! Before scale factor at t-points 267 ! (used as a now filtered scale factor until the swap) 268 ! ---------------------------------------------------- 269 IF (lk_dynspg_ts.AND.ln_bt_fw) THEN 270 ! Remove asselin filtering on thicknesses if forward time splitting 271 fse3t_b(:,:,:) = fse3t_n(:,:,:) 272 ELSE 273 fse3t_b(:,:,:) = fse3t_n(:,:,:) + atfp * ( fse3t_b(:,:,:) - 2._wp * fse3t_n(:,:,:) + fse3t_a(:,:,:) ) 274 ! Add volume filter correction: compatibility with tracer advection scheme 275 ! => time filter + conservation correction (only at the first level) 276 fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 216 277 ! 217 DO jk = 1, jpkm1 ! Before scale factor at t-points 218 fse3t_b(:,:,jk) = fse3t_n(:,:,jk) & 219 & + atfp * ( fse3t_b(:,:,jk) + fse3t_a(:,:,jk) & 220 & - 2._wp * fse3t_n(:,:,jk) ) 221 END DO 222 zec = atfp * rdt / rau0 ! Add filter correction only at the 1st level of t-point scale factors 223 fse3t_b(:,:,1) = fse3t_b(:,:,1) - zec * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 278 ENDIF 224 279 ! 225 IF( ln_dynadv_vec ) THEN ! vector invariant form (no thickness weighted calulation) 226 ! 227 ! ! before scale factors at u- & v-pts (computed from fse3t_b) 228 CALL dom_vvl_2( kt, fse3u_b(:,:,:), fse3v_b(:,:,:) ) 229 ! 230 DO jk = 1, jpkm1 ! Leap-Frog - Asselin filter and swap: applied on velocity 231 DO jj = 1, jpj ! -------- 280 IF( ln_dynadv_vec ) THEN 281 ! Before scale factor at (u/v)-points 282 ! ----------------------------------- 283 CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3u_b(:,:,:), 'U' ) 284 CALL dom_vvl_interpol( fse3t_b(:,:,:), fse3v_b(:,:,:), 'V' ) 285 ! Leap-Frog - Asselin filter and swap: applied on velocity 286 ! ----------------------------------- 287 DO jk = 1, jpkm1 288 DO jj = 1, jpj 232 289 DO ji = 1, jpi 233 zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2. e0* un(ji,jj,jk) + ua(ji,jj,jk) )234 zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2. e0* vn(ji,jj,jk) + va(ji,jj,jk) )290 zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2._wp * un(ji,jj,jk) + ua(ji,jj,jk) ) 291 zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2._wp * vn(ji,jj,jk) + va(ji,jj,jk) ) 235 292 ! 236 293 ub(ji,jj,jk) = zuf ! ub <-- filtered velocity … … 242 299 END DO 243 300 ! 244 ELSE ! flux form (thickness weighted calulation) 245 ! 246 CALL dom_vvl_2( kt, ze3u_f, ze3v_f ) ! before scale factors at u- & v-pts (computed from fse3t_b) 247 ! 248 DO jk = 1, jpkm1 ! Leap-Frog - Asselin filter and swap: 249 DO jj = 1, jpj ! applied on thickness weighted velocity 301 ELSE 302 ! Temporary filtered scale factor at (u/v)-points (will become before scale factor) 303 !------------------------------------------------ 304 CALL dom_vvl_interpol( fse3t_b(:,:,:), ze3u_f, 'U' ) 305 CALL dom_vvl_interpol( fse3t_b(:,:,:), ze3v_f, 'V' ) 306 ! Leap-Frog - Asselin filter and swap: applied on thickness weighted velocity 307 ! ----------------------------------- =========================== 308 DO jk = 1, jpkm1 309 DO jj = 1, jpj 250 310 DO ji = 1, jpi ! --------------------------- 251 311 zue3a = ua(ji,jj,jk) * fse3u_a(ji,jj,jk) … … 272 332 ENDIF 273 333 ! 274 ENDIF 334 IF (lk_dynspg_ts.AND.ln_bt_fw) THEN 335 ! Remove asselin filtering of barotropic velocities if forward time splitting 336 ! note that we replace barotropic velocities by advective velocities 337 zua(:,:) = 0._wp 338 zva(:,:) = 0._wp 339 IF (lk_vvl) THEN 340 DO jk = 1, jpkm1 341 zua(:,:) = zua(:,:) + fse3u_b(:,:,jk) * ub(:,:,jk) * umask(:,:,jk) 342 zva(:,:) = zva(:,:) + fse3v_b(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk) 343 END DO 344 ELSE 345 DO jk = 1, jpkm1 346 zua(:,:) = zua(:,:) + fse3u(:,:,jk) * ub(:,:,jk) * umask(:,:,jk) 347 zva(:,:) = zva(:,:) + fse3v(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk) 348 END DO 349 ENDIF 350 DO jk = 1, jpkm1 351 ub(:,:,jk) = ub(:,:,jk) - (zua(:,:) * hur(:,:) - un_b(:,:)) * umask(:,:,jk) 352 vb(:,:,jk) = vb(:,:,jk) - (zva(:,:) * hvr(:,:) - vn_b(:,:)) * vmask(:,:,jk) 353 END DO 354 ENDIF 355 ! 356 ENDIF ! neuler =/0 275 357 276 358 IF(ln_ctl) CALL prt_ctl( tab3d_1=un, clinfo1=' nxt - Un: ', mask1=umask, & … … 278 360 ! 279 361 CALL wrk_dealloc( jpi,jpj,jpk, ze3u_f, ze3v_f ) 362 IF ( lk_dynspg_ts ) CALL wrk_dealloc( jpi,jpj, zua, zva ) 280 363 ! 281 364 IF( nn_timing == 1 ) CALL timing_stop('dyn_nxt') -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90
r4245 r4292 23 23 USE dynspg_flt ! surface pressure gradient (dyn_spg_flt routine) 24 24 USE dynadv ! dynamics: vector invariant versus flux form 25 USE dynhpg, ONLY: ln_dynhpg_imp 26 USE sbctide 27 USE updtide 25 28 USE trdmod ! ocean dynamics trends 26 29 USE trdmod_oce ! ocean variables trends … … 101 104 ENDIF 102 105 103 IF( ln_apr_dyn ) THEN !== Atmospheric pressure gradient ==! 104 zg_2 = grav * 0.5 105 DO jj = 2, jpjm1 ! gradient of Patm using inverse barometer ssh 106 IF( ln_apr_dyn & ! atmos. pressure 107 .OR. ( .NOT.lk_dynspg_ts .AND. (ln_tide_pot .AND. lk_tide) ) & ! tide potential (no time slitting) 108 .OR. nn_ice_embd == 2 ) THEN ! embedded sea-ice 109 ! 110 DO jj = 2, jpjm1 106 111 DO ji = fs_2, fs_jpim1 ! vector opt. 107 spgu(ji,jj) = zg_2 * ( ssh_ib (ji+1,jj) - ssh_ib (ji,jj) & 108 & + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj) ) /e1u(ji,jj) 109 spgv(ji,jj) = zg_2 * ( ssh_ib (ji,jj+1) - ssh_ib (ji,jj) & 110 & + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj) ) /e2v(ji,jj) 111 END DO 112 END DO 113 DO jk = 1, jpkm1 ! Add the apg to the general trend 112 spgu(ji,jj) = 0._wp 113 spgv(ji,jj) = 0._wp 114 END DO 115 END DO 116 ! 117 IF( ln_apr_dyn .AND. (.NOT. lk_dynspg_ts) ) THEN !== Atmospheric pressure gradient (added later in time-split case) ==! 118 zg_2 = grav * 0.5 119 DO jj = 2, jpjm1 ! gradient of Patm using inverse barometer ssh 120 DO ji = fs_2, fs_jpim1 ! vector opt. 121 spgu(ji,jj) = spgu(ji,jj) + zg_2 * ( ssh_ib (ji+1,jj) - ssh_ib (ji,jj) & 122 & + ssh_ibb(ji+1,jj) - ssh_ibb(ji,jj) ) /e1u(ji,jj) 123 spgv(ji,jj) = spgv(ji,jj) + zg_2 * ( ssh_ib (ji,jj+1) - ssh_ib (ji,jj) & 124 & + ssh_ibb(ji,jj+1) - ssh_ibb(ji,jj) ) /e2v(ji,jj) 125 END DO 126 END DO 127 ENDIF 128 ! 129 ! !== tide potential forcing term ==! 130 IF( .NOT.lk_dynspg_ts .AND. ( ln_tide_pot .AND. lk_tide ) ) THEN ! N.B. added directly at sub-time-step in ts-case 131 ! 132 CALL upd_tide( kt ) ! update tide potential 133 ! 134 DO jj = 2, jpjm1 ! add tide potential forcing 135 DO ji = fs_2, fs_jpim1 ! vector opt. 136 spgv(ji,jj) = spgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) / e1u(ji,jj) 137 spgv(ji,jj) = spgv(ji,jj) + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) / e2v(ji,jj) 138 END DO 139 END DO 140 ENDIF 141 ! 142 IF( nn_ice_embd == 2 ) THEN !== embedded sea ice: Pressure gradient due to snow-ice mass ==! 143 CALL wrk_alloc( jpi, jpj, zpice ) 144 ! 145 zintp = REAL( MOD( kt-1, nn_fsbc ) ) / REAL( nn_fsbc ) 146 zgrau0r = - grav * r1_rau0 147 zpice(:,:) = ( zintp * snwice_mass(:,:) + ( 1.- zintp ) * snwice_mass_b(:,:) ) * zgrau0r 148 DO jj = 2, jpjm1 149 DO ji = fs_2, fs_jpim1 ! vector opt. 150 spgu(ji,jj) = spgu(ji,jj) + ( zpice(ji+1,jj) - zpice(ji,jj) ) / e1u(ji,jj) 151 spgv(ji,jj) = spgv(ji,jj) + ( zpice(ji,jj+1) - zpice(ji,jj) ) / e2v(ji,jj) 152 END DO 153 END DO 154 ! 155 CALL wrk_dealloc( jpi, jpj, zpice ) 156 ENDIF 157 ! 158 DO jk = 1, jpkm1 !== Add all terms to the general trend 114 159 DO jj = 2, jpjm1 115 160 DO ji = fs_2, fs_jpim1 ! vector opt. … … 118 163 END DO 119 164 END DO 120 END DO 121 ENDIF 122 123 IF( nn_ice_embd == 2 ) THEN !== embedded sea ice: Pressure gradient due to snow-ice mass ==! 124 CALL wrk_alloc( jpi, jpj, zpice ) 125 ! 126 zintp = REAL( MOD( kt-1, nn_fsbc ) ) / REAL( nn_fsbc ) 127 zgrau0r = - grav * r1_rau0 128 zpice(:,:) = ( zintp * snwice_mass(:,:) + ( 1.- zintp ) * snwice_mass_b(:,:) ) * zgrau0r 129 DO jj = 2, jpjm1 130 DO ji = fs_2, fs_jpim1 ! vector opt. 131 spgu(ji,jj) = ( zpice(ji+1,jj) - zpice(ji,jj) ) / e1u(ji,jj) 132 spgv(ji,jj) = ( zpice(ji,jj+1) - zpice(ji,jj) ) / e2v(ji,jj) 133 END DO 134 END DO 135 DO jk = 1, jpkm1 ! Add the surface pressure trend to the general trend 136 DO jj = 2, jpjm1 137 DO ji = fs_2, fs_jpim1 ! vector opt. 138 ua(ji,jj,jk) = ua(ji,jj,jk) + spgu(ji,jj) 139 va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj) 140 END DO 141 END DO 142 END DO 143 ! 144 CALL wrk_dealloc( jpi, jpj, zpice ) 145 ENDIF 146 165 END DO 166 ENDIF 147 167 148 168 SELECT CASE ( nspg ) ! compute surf. pressure gradient trend and add it to the general trend … … 209 229 ENDIF 210 230 231 IF( lk_dynspg_ts ) CALL dyn_spg_ts_init( nit000 ) 232 ! (do it now, to set nn_baro, used to allocate some arrays later on) 211 233 ! ! allocate dyn_spg arrays 212 234 IF( lk_dynspg_ts ) THEN … … 248 270 ENDIF 249 271 250 ! ! Control of momentum formulation251 IF( lk_dynspg_ts .AND. l k_vvl) THEN252 IF( .NOT.ln_dynadv_vec ) CALL ctl_stop( 'Flux form not implemented for this free surface formulation' )272 ! ! Control of hydrostatic pressure choice 273 IF( lk_dynspg_ts .AND. ln_dynhpg_imp ) THEN 274 CALL ctl_stop( 'Semi-implicit hpg not compatible with time splitting' ) 253 275 ENDIF 254 276 ! -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90
r3680 r4292 91 91 spgv(ji,jj) = - grav * ( sshn(ji,jj+1) - sshn(ji,jj) ) / e2v(ji,jj) 92 92 END DO 93 END DO 93 END DO 94 ! 94 95 DO jk = 1, jpkm1 ! Add it to the general trend 95 96 DO jj = 2, jpjm1 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_oce.F90
r3294 r4292 39 39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: hur_e , hvr_e ! inverse of hu_e and hv_e 40 40 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: sshn_b ! before field without time-filter 41 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ua_b, va_b ! after averaged velocities 42 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_b, vn_b ! now averaged velocities 43 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub_b, vb_b ! before averaged velocities 44 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_adv, vn_adv ! Advection vel. at "now" barocl. step 45 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub2_b, vb2_b ! Advection vel. at "now-0.5" barocl. step 41 46 42 47 !!---------------------------------------------------------------------- … … 53 58 ALLOCATE( sshn_e(jpi,jpj) , ua_e(jpi,jpj) , hu_e(jpi,jpj) , hur_e(jpi,jpj) , & 54 59 & ssha_e(jpi,jpj) , va_e(jpi,jpj) , hv_e(jpi,jpj) , hvr_e(jpi,jpj) , & 60 & ub_b(jpi,jpj) , vb_b(jpi,jpj) , un_b(jpi,jpj) , vn_b(jpi,jpj) , & 61 & ua_b(jpi,jpj) , va_b(jpi,jpj) , & 62 & ub2_b(jpi,jpj) , vb2_b(jpi,jpj) , & 63 & un_adv(jpi,jpj) , vn_adv(jpi,jpj) , & 55 64 & sshn_b(jpi,jpj) , STAT = dynspg_oce_alloc ) 56 65 ! -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90
r3680 r4292 9 9 !! 3.3 ! 2010-09 (D. Storkey, E. O'Dea) update for BDY for Shelf configurations 10 10 !! 3.3 ! 2011-03 (R. Benshila, R. Hordoir, P. Oddo) update calculation of ub_b 11 !! 3.5 ! 2013-07 (J. Chanut) Switch to Forward-backward time stepping 12 !! 3.6 ! 2013-11 (A. Coward) Update for z-tilde compatibility 11 13 !!--------------------------------------------------------------------- 12 14 #if defined key_dynspg_ts || defined key_esopa … … 16 18 !! dyn_spg_ts : compute surface pressure gradient trend using a time- 17 19 !! splitting scheme and add to the general trend 18 !! ts_rst : read/write the time-splitting restart fields in the ocean restart file19 20 !!---------------------------------------------------------------------- 20 21 USE oce ! ocean dynamics and tracers … … 24 25 USE phycst ! physical constants 25 26 USE domvvl ! variable volume 26 USE zdfbfr ! bottom friction27 27 USE dynvor ! vorticity term 28 USE obc_oce ! Lateral open boundary condition29 USE obc_par ! open boundary condition parameters30 USE obcdta ! open boundary condition data31 USE obcfla ! Flather open boundary condition32 28 USE bdy_par ! for lk_bdy 33 29 USE bdy_oce ! Lateral open boundary condition 34 USE bdy dta! open boundary condition data30 USE bdytides ! open boundary condition data 35 31 USE bdydyn2d ! open boundary conditions on barotropic variables 36 USE sbctide 37 USE updtide 32 USE sbctide ! tides 33 USE updtide ! tide potential 38 34 USE lib_mpp ! distributed memory computing library 39 35 USE lbclnk ! ocean lateral boundary conditions (or mpp link) … … 41 37 USE in_out_manager ! I/O manager 42 38 USE iom ! IOM library 39 USE restart ! only for lrst_oce 43 40 USE zdf_oce ! Vertical diffusion 44 41 USE wrk_nemo ! Memory Allocation 45 USE timing ! Timing 42 USE timing ! Timing 43 USE sbcapr ! surface boundary condition: atmospheric pressure 44 USE dynadv, ONLY: ln_dynadv_vec 45 #if defined key_agrif 46 USE agrif_opa_interp ! agrif 47 #endif 46 48 47 49 … … 49 51 PRIVATE 50 52 51 PUBLIC dyn_spg_ts ! routine called by step.F90 52 PUBLIC ts_rst ! routine called by istate.F90 53 PUBLIC dyn_spg_ts_alloc ! routine called by dynspg.F90 54 55 53 PUBLIC dyn_spg_ts ! routine called in dynspg.F90 54 PUBLIC dyn_spg_ts_alloc ! " " " " 55 PUBLIC dyn_spg_ts_init ! " " " " 56 57 ! Potential namelist parameters below to be read in dyn_spg_ts_init 58 LOGICAL, PUBLIC, PARAMETER :: ln_bt_fw=.TRUE. !: Forward integration of barotropic sub-stepping 59 LOGICAL, PRIVATE, PARAMETER :: ln_bt_av=.TRUE. !: Time averaging of barotropic variables 60 LOGICAL, PRIVATE, PARAMETER :: ln_bt_nn_auto=.FALSE. !: Set number of iterations automatically 61 INTEGER, PRIVATE, PARAMETER :: nn_bt_flt=1 !: Filter choice 62 REAL(wp), PRIVATE, PARAMETER :: rn_bt_cmax=0.8_wp !: Max. courant number (used if ln_bt_nn_auto=T) 63 ! End namelist parameters 64 65 INTEGER, SAVE :: icycle ! Number of barotropic sub-steps for each internal step nn_baro <= 2.5 nn_baro 66 REAL(wp),SAVE :: rdtbt ! Barotropic time step 67 68 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: & 69 wgtbtp1, & ! Primary weights used for time filtering of barotropic variables 70 wgtbtp2 ! Secondary weights used for time filtering of barotropic variables 71 72 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zwz ! ff/h at F points 56 73 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftnw, ftne ! triad of coriolis parameter 57 74 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ftsw, ftse ! (only used with een vorticity scheme) 58 75 59 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: un_b, vn_b ! now averaged velocity 60 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub_b, vb_b ! before averaged velocity 76 ! Arrays below are saved to allow testing of the "no time averaging" option 77 ! If this option is not retained, these could be replaced by temporary arrays 78 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshbb_e, sshb_e, & ! Instantaneous barotropic arrays 79 ubb_e, ub_e, & 80 vbb_e, vb_e 61 81 62 82 !! * Substitutions … … 64 84 # include "vectopt_loop_substitute.h90" 65 85 !!---------------------------------------------------------------------- 66 !! NEMO/OPA 4.0 , NEMO Consortium (2011)67 !! $Id $86 !! NEMO/OPA 3.5 , NEMO Consortium (2013) 87 !! $Id: dynspg_ts.F90 68 88 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 69 89 !!---------------------------------------------------------------------- … … 74 94 !! *** routine dyn_spg_ts_alloc *** 75 95 !!---------------------------------------------------------------------- 76 ALLOCATE( ftnw (jpi,jpj) , ftne(jpi,jpj) , un_b(jpi,jpj) , vn_b(jpi,jpj) , & 77 & ftsw (jpi,jpj) , ftse(jpi,jpj) , ub_b(jpi,jpj) , vb_b(jpi,jpj) , STAT= dyn_spg_ts_alloc ) 78 ! 96 INTEGER :: ierr(3) 97 !!---------------------------------------------------------------------- 98 ierr(:) = 0 99 100 ALLOCATE( sshb_e(jpi,jpj), sshbb_e(jpi,jpj), & 101 & ub_e(jpi,jpj) , vb_e(jpi,jpj) , & 102 & ubb_e(jpi,jpj) , vbb_e(jpi,jpj) , STAT= ierr(1) ) 103 104 ALLOCATE( wgtbtp1(3*nn_baro), wgtbtp2(3*nn_baro), zwz(jpi,jpj), STAT= ierr(2) ) 105 106 IF( ln_dynvor_een ) ALLOCATE( ftnw(jpi,jpj) , ftne(jpi,jpj) , & 107 & ftsw(jpi,jpj) , ftse(jpi,jpj) , STAT=ierr(3) ) 108 109 dyn_spg_ts_alloc = MAXVAL(ierr(:)) 110 79 111 IF( lk_mpp ) CALL mpp_sum( dyn_spg_ts_alloc ) 80 112 IF( dyn_spg_ts_alloc /= 0 ) CALL ctl_warn('dynspg_oce_alloc: failed to allocate arrays') … … 82 114 END FUNCTION dyn_spg_ts_alloc 83 115 84 85 116 SUBROUTINE dyn_spg_ts( kt ) 86 117 !!---------------------------------------------------------------------- 87 !! *** routine dyn_spg_ts ***88 118 !! 89 !! ** Purpose : Compute the now trend due to the surface pressure 90 !! gradient in case of free surface formulation with time-splitting. 91 !! Add it to the general trend of momentum equation. 119 !! ** Purpose : 120 !! -Compute the now trend due to the explicit time stepping 121 !! of the quasi-linear barotropic system. Barotropic variables are 122 !! advanced from internal time steps "n" to "n+1" (if ln_bt_cen=F) 123 !! or from "n-1" to "n+1" time steps (if ln_bt_cen=T) with a 124 !! generalized forward-backward (see ref. below) time stepping. 125 !! -Update the free surface at step "n+1" (ssha, zsshu_a, zsshv_a). 126 !! -Compute barotropic advective velocities at step "n" to be used 127 !! to advect tracers latter on. These are compliant with discrete 128 !! continuity equation taken at the baroclinic time steps, thus 129 !! ensuring tracers conservation. 92 130 !! 93 !! ** Method : Free surface formulation with time-splitting 94 !! -1- Save the vertically integrated trend. This general trend is 95 !! held constant over the barotropic integration. 96 !! The Coriolis force is removed from the general trend as the 97 !! surface gradient and the Coriolis force are updated within 98 !! the barotropic integration. 99 !! -2- Barotropic loop : updates of sea surface height (ssha_e) and 100 !! barotropic velocity (ua_e and va_e) through barotropic 101 !! momentum and continuity integration. Barotropic former 102 !! variables are time averaging over the full barotropic cycle 103 !! (= 2 * baroclinic time step) and saved in uX_b 104 !! and vX_b (X specifying after, now or before). 105 !! -3- The new general trend becomes : 106 !! ua = ua - sum_k(ua)/H + ( un_b - ub_b ) 131 !! ** Method : 107 132 !! 108 !! ** Action : - Update (ua,va) with the surf. pressure gradient trend 133 !! ** Action : - Update barotropic velocities: ua_b, va_b 134 !! - Update trend (ua,va) with barotropic component 135 !! - Update ssha, zsshu_a, zsshv_a 136 !! - Update barotropic advective velocity at kt=now 109 137 !! 110 !! References : Griffies et al., (2003): A technical guide to MOM4. NOAA/GFDL 138 !! References : Shchepetkin, A.F. and J.C. McWilliams, 2005: 139 !! The regional oceanic modeling system (ROMS): 140 !! a split-explicit, free-surface, 141 !! topography-following-coordinate oceanic model. 142 !! Ocean Modelling, 9, 347-404. 111 143 !!--------------------------------------------------------------------- 112 144 ! 113 145 INTEGER, INTENT(in) :: kt ! ocean time-step index 114 146 ! 115 INTEGER :: ji, jj, jk, jn ! dummy loop indices 116 INTEGER :: icycle ! local scalar 117 INTEGER :: ikbu, ikbv ! local scalar 118 REAL(wp) :: zraur, zcoef, z2dt_e, z1_2dt_b, z2dt_bf ! local scalars 119 REAL(wp) :: z1_8, zx1, zy1 ! - - 120 REAL(wp) :: z1_4, zx2, zy2 ! - - 121 REAL(wp) :: zu_spg, zu_cor, zu_sld, zu_asp ! - - 122 REAL(wp) :: zv_spg, zv_cor, zv_sld, zv_asp ! - - 123 REAL(wp) :: ua_btm, va_btm ! - - 124 ! 125 REAL(wp), POINTER, DIMENSION(:,:) :: zsshun_e, zsshvn_e, zsshb_e, zssh_sum, zhdiv 126 REAL(wp), POINTER, DIMENSION(:,:) :: zua, zva, zun, zvn, zun_e, zvn_e, zub_e, zvb_e 127 REAL(wp), POINTER, DIMENSION(:,:) :: zcu, zcv, zwx, zwy, zbfru, zbfrv, zu_sum, zv_sum 147 LOGICAL :: ll_fw_start ! if true, forward integration 148 LOGICAL :: ll_init ! if true, special startup of 2d equations 149 INTEGER :: ji, jj, jk, jn ! dummy loop indices 150 INTEGER :: ikbu, ikbv, noffset ! local integers 151 REAL(wp) :: zraur, z1_2dt_b, z2dt_bf ! local scalars 152 REAL(wp) :: zx1, zy1, zx2, zy2 ! - - 153 REAL(wp) :: z1_12, z1_8, z1_4, z1_2 ! - - 154 REAL(wp) :: zu_spg, zv_spg ! - - 155 REAL(wp) :: zhura, zhvra ! - - 156 REAL(wp) :: za0, za1, za2, za3 ! - - 157 ! 158 REAL(wp), POINTER, DIMENSION(:,:) :: zun_e, zvn_e, zsshp2_e 159 REAL(wp), POINTER, DIMENSION(:,:) :: zu_trd, zv_trd, zu_frc, zv_frc, zssh_frc 160 REAL(wp), POINTER, DIMENSION(:,:) :: zu_sum, zv_sum, zwx, zwy, zhdiv 161 REAL(wp), POINTER, DIMENSION(:,:) :: zhup2_e, zhvp2_e, zhust_e, zhvst_e 162 REAL(wp), POINTER, DIMENSION(:,:) :: zhur_b, zhvr_b 163 REAL(wp), POINTER, DIMENSION(:,:) :: zsshu_a, zsshv_a 164 REAL(wp), POINTER, DIMENSION(:,:) :: zht, zhf 128 165 !!---------------------------------------------------------------------- 129 166 ! 130 167 IF( nn_timing == 1 ) CALL timing_start('dyn_spg_ts') 131 168 ! 132 CALL wrk_alloc( jpi, jpj, zsshun_e, zsshvn_e, zsshb_e, zssh_sum, zhdiv ) 133 CALL wrk_alloc( jpi, jpj, zua, zva, zun, zvn, zun_e, zvn_e, zub_e, zvb_e ) 134 CALL wrk_alloc( jpi, jpj, zcu, zcv, zwx, zwy, zbfru, zbfrv, zu_sum, zv_sum ) 135 ! 136 IF( kt == nit000 ) THEN !* initialisation 169 ! !* Allocate temporay arrays 170 CALL wrk_alloc( jpi, jpj, zsshp2_e, zhdiv ) 171 CALL wrk_alloc( jpi, jpj, zu_trd, zv_trd, zun_e, zvn_e ) 172 CALL wrk_alloc( jpi, jpj, zwx, zwy, zu_sum, zv_sum, zssh_frc, zu_frc, zv_frc) 173 CALL wrk_alloc( jpi, jpj, zhup2_e, zhvp2_e, zhust_e, zhvst_e) 174 CALL wrk_alloc( jpi, jpj, zhur_b, zhvr_b ) 175 CALL wrk_alloc( jpi, jpj, zsshu_a, zsshv_a ) 176 CALL wrk_alloc( jpi, jpj, zht, zhf ) 177 ! 178 ! !* Local constant initialization 179 z1_12 = 1._wp / 12._wp 180 z1_8 = 0.125_wp 181 z1_4 = 0.25_wp 182 z1_2 = 0.5_wp 183 zraur = 1._wp / rau0 184 ! 185 IF( kt == nit000 .AND. neuler == 0 ) THEN ! reciprocal of baroclinic time step 186 z2dt_bf = rdt 187 ELSE 188 z2dt_bf = 2.0_wp * rdt 189 ENDIF 190 z1_2dt_b = 1.0_wp / z2dt_bf 191 ! 192 ll_init = ln_bt_av ! if no time averaging, then no specific restart 193 ll_fw_start = .FALSE. 194 ! 195 ! time offset in steps for bdy data update 196 IF (.NOT.ln_bt_fw) THEN ; noffset=-2*nn_baro ; ELSE ; noffset = 0 ; ENDIF 197 ! 198 IF( kt == nit000 ) THEN !* initialisation 137 199 ! 138 200 IF(lwp) WRITE(numout,*) … … 141 203 IF(lwp) WRITE(numout,*) ' Number of sub cycle in 1 time-step (2 rdt) : icycle = ', 2*nn_baro 142 204 ! 143 CALL ts_rst( nit000, 'READ' ) ! read or initialize the following fields: un_b, vn_b 144 ! 145 ua_e (:,:) = un_b (:,:) 146 va_e (:,:) = vn_b (:,:) 147 hu_e (:,:) = hu (:,:) 148 hv_e (:,:) = hv (:,:) 149 hur_e (:,:) = hur (:,:) 150 hvr_e (:,:) = hvr (:,:) 151 IF( ln_dynvor_een ) THEN 152 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 205 IF (neuler==0) ll_init=.TRUE. 206 ! 207 IF (ln_bt_fw.OR.(neuler==0)) THEN 208 ll_fw_start=.TRUE. 209 noffset = 0 210 ELSE 211 ll_fw_start=.FALSE. 212 ENDIF 213 ! 214 ! Set averaging weights and cycle length: 215 CALL ts_wgt(ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2) 216 ! 217 IF ((neuler/=0).AND.(ln_bt_fw)) CALL ts_rst( nit000, 'READ' ) 218 ! 219 ENDIF 220 ! 221 ! Set arrays to remove/compute coriolis trend. 222 ! Do it once at kt=nit000 if volume is fixed, else at each long time step. 223 ! Note that these arrays are also used during barotropic loop. These are however frozen 224 ! although they should be updated in variable volume case. Not a big approximation. 225 ! To remove this approximation, copy lines below inside barotropic loop 226 ! and update depths at T-F points (ht and hf resp.) at each barotropic time step 227 ! 228 IF ( kt == nit000 .OR. lk_vvl ) THEN 229 IF ( ln_dynvor_een ) THEN 230 ! JC: Simplification needed below: define ht_0 even when volume is fixed 231 IF (lk_vvl) THEN 232 zht(:,:) = (ht_0(:,:) + sshn(:,:)) * tmask(:,:,1) 233 ELSE 234 zht(:,:) = 0. 235 DO jk = 1, jpkm1 236 zht(:,:) = zht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 237 END DO 238 ENDIF 239 240 DO jj = 1, jpjm1 241 DO ji = 1, jpim1 242 zwz(ji,jj) = ( zht(ji ,jj+1) + zht(ji+1,jj+1) + & 243 & zht(ji ,jj ) + zht(ji+1,jj ) ) & 244 & / ( MAX( 1.0_wp, tmask(ji ,jj+1, 1) + tmask(ji+1,jj+1, 1) + & 245 & tmask(ji ,jj , 1) + tmask(ji+1,jj , 1) ) ) 246 IF( zwz(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zwz(ji,jj) 247 END DO 248 END DO 249 CALL lbc_lnk( zwz, 'F', 1._wp ) 250 zwz(:,:) = ff(:,:) * zwz(:,:) 251 252 ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp 153 253 DO jj = 2, jpj 154 254 DO ji = fs_2, jpi ! vector opt. 155 ftne(ji,jj) = ( ff(ji-1,jj ) + ff(ji ,jj ) + ff(ji ,jj-1) ) / 3._wp 156 ftnw(ji,jj) = ( ff(ji-1,jj-1) + ff(ji-1,jj ) + ff(ji ,jj ) ) / 3._wp 157 ftse(ji,jj) = ( ff(ji ,jj ) + ff(ji ,jj-1) + ff(ji-1,jj-1) ) / 3._wp 158 ftsw(ji,jj) = ( ff(ji ,jj-1) + ff(ji-1,jj-1) + ff(ji-1,jj ) ) / 3._wp 159 END DO 160 END DO 161 ENDIF 162 ! 163 ENDIF 164 165 ! !* Local constant initialization 166 z1_2dt_b = 1._wp / ( 2.0_wp * rdt ) ! reciprocal of baroclinic time step 167 IF( neuler == 0 .AND. kt == nit000 ) z1_2dt_b = 1.0_wp / rdt ! reciprocal of baroclinic 168 ! time step (euler timestep) 169 z1_8 = 0.125_wp ! coefficient for vorticity estimates 170 z1_4 = 0.25_wp 171 zraur = 1._wp / rau0 ! 1 / volumic mass 172 ! 173 zhdiv(:,:) = 0._wp ! barotropic divergence 174 zu_sld = 0._wp ; zu_asp = 0._wp ! tides trends (lk_tide=F) 175 zv_sld = 0._wp ; zv_asp = 0._wp 176 177 IF( kt == nit000 .AND. neuler == 0) THEN ! for implicit bottom friction 178 z2dt_bf = rdt 179 ELSE 180 z2dt_bf = 2.0_wp * rdt 181 ENDIF 182 255 ftne(ji,jj) = zwz(ji-1,jj ) + zwz(ji ,jj ) + zwz(ji ,jj-1) 256 ftnw(ji,jj) = zwz(ji-1,jj-1) + zwz(ji-1,jj ) + zwz(ji ,jj ) 257 ftse(ji,jj) = zwz(ji ,jj ) + zwz(ji ,jj-1) + zwz(ji-1,jj-1) 258 ftsw(ji,jj) = zwz(ji ,jj-1) + zwz(ji-1,jj-1) + zwz(ji-1,jj ) 259 END DO 260 END DO 261 ELSE 262 zwz(:,:) = 0._wp 263 zht(:,:) = 0. 264 IF ( .not. ln_sco ) THEN 265 ! IF( rn_hmin < 0._wp ) THEN ; jk = - INT( rn_hmin ) ! from a nb of level 266 ! ELSE ; jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 ) ! from a depth 267 ! ENDIF 268 ! zht(:,:) = gdepw_0(:,:,jk+1) 269 ELSE 270 zht(:,:) = hbatf(:,:) 271 END IF 272 273 DO jj = 1, jpjm1 274 zht(:,jj) = zht(:,jj)*(1._wp- umask(:,jj,1) * umask(:,jj+1,1)) 275 END DO 276 277 DO jk = 1, jpkm1 278 DO jj = 1, jpjm1 279 zht(:,jj) = zht(:,jj) + fse3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) 280 END DO 281 END DO 282 CALL lbc_lnk( zht, 'F', 1._wp ) 283 ! JC: TBC. hf should be greater than 0 284 DO jj = 1, jpj 285 DO ji = 1, jpi 286 IF( zht(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zht(ji,jj) ! zht is actually hf here but it saves an array 287 END DO 288 END DO 289 zwz(:,:) = ff(:,:) * zwz(:,:) 290 ENDIF 291 ENDIF 292 ! 293 ! If forward start at previous time step, and centered integration, 294 ! then update averaging weights: 295 IF ((.NOT.ln_bt_fw).AND.((neuler==0).AND.(kt==nit000+1))) THEN 296 ll_fw_start=.FALSE. 297 CALL ts_wgt(ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2) 298 ENDIF 299 300 ! before inverse water column height at u- and v- points 301 IF( lk_vvl ) THEN 302 zhur_b(:,:) = 0. 303 zhvr_b(:,:) = 0. 304 DO jk = 1, jpk 305 zhur_b(:,:) = zhur_b(:,:) + fse3u_b(:,:,jk) * umask(:,:,jk) 306 zhvr_b(:,:) = zhvr_b(:,:) + fse3v_b(:,:,jk) * vmask(:,:,jk) 307 END DO 308 zhur_b(:,:) = umask(:,:,1) / ( zhur_b(:,:) + 1. - umask(:,:,1) ) 309 zhvr_b(:,:) = vmask(:,:,1) / ( zhvr_b(:,:) + 1. - vmask(:,:,1) ) 310 ELSE 311 zhur_b(:,:) = hur(:,:) 312 zhvr_b(:,:) = hvr(:,:) 313 ENDIF 314 183 315 ! ----------------------------------------------------------------------------- 184 316 ! Phase 1 : Coupling between general trend and barotropic estimates (1st step) 185 317 ! ----------------------------------------------------------------------------- 186 318 ! 319 ! Some vertical sums (at now and before time steps) below could be suppressed 320 ! if one swap barotropic arrays somewhere 321 ! 187 322 ! !* e3*d/dt(Ua), e3*Ub, e3*Vn (Vertically integrated) 188 ! ! -------------------------- 189 zu a(:,:) = 0._wp ; zun(:,:) = 0._wp ; ub_b(:,:) = 0._wp190 zv a(:,:) = 0._wp ; zvn(:,:) = 0._wp ; vb_b(:,:) = 0._wp323 ! ! -------------------------------------------------- 324 zu_frc(:,:) = 0._wp ; ub_b(:,:) = 0._wp ; un_b(:,:) = 0._wp 325 zv_frc(:,:) = 0._wp ; vb_b(:,:) = 0._wp ; vn_b(:,:) = 0._wp 191 326 ! 192 327 DO jk = 1, jpkm1 … … 198 333 DO ji = 1, jpi 199 334 #endif 200 ! ! now trend 201 zua(ji,jj) = zua(ji,jj) + fse3u (ji,jj,jk) * ua(ji,jj,jk) * umask(ji,jj,jk) 202 zva(ji,jj) = zva(ji,jj) + fse3v (ji,jj,jk) * va(ji,jj,jk) * vmask(ji,jj,jk) 203 ! ! now velocity 204 zun(ji,jj) = zun(ji,jj) + fse3u (ji,jj,jk) * un(ji,jj,jk) 205 zvn(ji,jj) = zvn(ji,jj) + fse3v (ji,jj,jk) * vn(ji,jj,jk) 206 ! 207 #if defined key_vvl 208 ub_b(ji,jj) = ub_b(ji,jj) + fse3u_b(ji,jj,jk)* ub(ji,jj,jk) *umask(ji,jj,jk) 209 vb_b(ji,jj) = vb_b(ji,jj) + fse3v_b(ji,jj,jk)* vb(ji,jj,jk) *vmask(ji,jj,jk) 210 #else 211 ub_b(ji,jj) = ub_b(ji,jj) + fse3u_0(ji,jj,jk) * ub(ji,jj,jk) * umask(ji,jj,jk) 212 vb_b(ji,jj) = vb_b(ji,jj) + fse3v_0(ji,jj,jk) * vb(ji,jj,jk) * vmask(ji,jj,jk) 213 #endif 335 ! ! now trend: 336 zu_frc(ji,jj) = zu_frc(ji,jj) + fse3u(ji,jj,jk) * ua(ji,jj,jk) * umask(ji,jj,jk) 337 zv_frc(ji,jj) = zv_frc(ji,jj) + fse3v(ji,jj,jk) * va(ji,jj,jk) * vmask(ji,jj,jk) 338 ! ! now bt transp: 339 un_b(ji,jj) = un_b(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk) 340 vn_b(ji,jj) = vn_b(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) 341 ! ! before bt transp: 342 ub_b(ji,jj) = ub_b(ji,jj) + fse3u_b(ji,jj,jk) * ub(ji,jj,jk) * umask(ji,jj,jk) 343 vb_b(ji,jj) = vb_b(ji,jj) + fse3v_b(ji,jj,jk) * vb(ji,jj,jk) * vmask(ji,jj,jk) 214 344 END DO 215 345 END DO 216 346 END DO 217 347 ! 348 zu_frc(:,:) = zu_frc(:,:) * hur(:,:) 349 zv_frc(:,:) = zv_frc(:,:) * hvr(:,:) 350 ! 351 IF( lk_vvl ) THEN 352 ub_b(:,:) = ub_b(:,:) * zhur_b(:,:) 353 vb_b(:,:) = vb_b(:,:) * zhvr_b(:,:) 354 ELSE 355 ub_b(:,:) = ub_b(:,:) * hur(:,:) 356 vb_b(:,:) = vb_b(:,:) * hvr(:,:) 357 ENDIF 358 ! 218 359 ! !* baroclinic momentum trend (remove the vertical mean trend) 219 DO jk = 1, jpkm1 ! -------------------------- 360 DO jk = 1, jpkm1 ! ----------------------------------------------------------- 220 361 DO jj = 2, jpjm1 221 362 DO ji = fs_2, fs_jpim1 ! vector opt. 222 ua(ji,jj,jk) = ua(ji,jj,jk) - zu a(ji,jj) * hur(ji,jj)223 va(ji,jj,jk) = va(ji,jj,jk) - zv a(ji,jj) * hvr(ji,jj)363 ua(ji,jj,jk) = ua(ji,jj,jk) - zu_frc(ji,jj) * umask(ji,jj,jk) 364 va(ji,jj,jk) = va(ji,jj,jk) - zv_frc(ji,jj) * vmask(ji,jj,jk) 224 365 END DO 225 366 END DO 226 367 END DO 227 228 ! !* barotropic Coriolis trends * H (vorticity scheme dependent) 229 ! ! ---------------------------==== 230 zwx(:,:) = zun(:,:) * e2u(:,:) ! now transport 231 zwy(:,:) = zvn(:,:) * e1v(:,:) 368 ! !* barotropic Coriolis trends (vorticity scheme dependent) 369 ! ! -------------------------------------------------------- 370 zwx(:,:) = un_b(:,:) * e2u(:,:) ! now transport 371 zwy(:,:) = vn_b(:,:) * e1v(:,:) 232 372 ! 233 373 IF( ln_dynvor_ene .OR. ln_dynvor_mix ) THEN ! energy conserving or mixed scheme … … 239 379 zx2 = ( zwx(ji ,jj) + zwx(ji ,jj+1) ) / e2v(ji,jj) 240 380 ! energy conserving formulation for planetary vorticity term 241 z cu(ji,jj) = z1_4 * ( ff(ji ,jj-1) * zy1 + ff(ji,jj) * zy2 )242 z cv(ji,jj) =-z1_4 * ( ff(ji-1,jj ) * zx1 + ff(ji,jj) * zx2 )243 END DO 244 END DO 245 ! 246 ELSEIF ( ln_dynvor_ens ) THEN 381 zu_trd(ji,jj) = z1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 382 zv_trd(ji,jj) =-z1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 383 END DO 384 END DO 385 ! 386 ELSEIF ( ln_dynvor_ens ) THEN ! enstrophy conserving scheme 247 387 DO jj = 2, jpjm1 248 388 DO ji = fs_2, fs_jpim1 ! vector opt. 249 zy1 = z1_8 * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) + zwy(ji,jj) + zwy(ji+1,jj ) ) / e1u(ji,jj) 250 zx1 = - z1_8 * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) + zwx(ji,jj) + zwx(ji ,jj+1) ) / e2v(ji,jj) 251 zcu(ji,jj) = zy1 * ( ff(ji ,jj-1) + ff(ji,jj) ) 252 zcv(ji,jj) = zx1 * ( ff(ji-1,jj ) + ff(ji,jj) ) 253 END DO 254 END DO 255 ! 256 ELSEIF ( ln_dynvor_een ) THEN ! enstrophy and energy conserving scheme 389 zy1 = z1_8 * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & 390 & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) / e1u(ji,jj) 391 zx1 = - z1_8 * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & 392 & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) / e2v(ji,jj) 393 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 394 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 395 END DO 396 END DO 397 ! 398 ELSEIF ( ln_dynvor_een ) THEN ! enstrophy and energy conserving scheme 257 399 DO jj = 2, jpjm1 258 400 DO ji = fs_2, fs_jpim1 ! vector opt. 259 zcu(ji,jj) = + z1_4 / e1u(ji,jj) * ( ftne(ji,jj ) * zwy(ji ,jj ) + ftnw(ji+1,jj) * zwy(ji+1,jj ) & 260 & + ftse(ji,jj ) * zwy(ji ,jj-1) + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 261 zcv(ji,jj) = - z1_4 / e2v(ji,jj) * ( ftsw(ji,jj+1) * zwx(ji-1,jj+1) + ftse(ji,jj+1) * zwx(ji ,jj+1) & 262 & + ftnw(ji,jj ) * zwx(ji-1,jj ) + ftne(ji,jj ) * zwx(ji ,jj ) ) 263 END DO 264 END DO 265 ! 266 ENDIF 267 401 zu_trd(ji,jj) = + z1_12 / e1u(ji,jj) * ( ftne(ji,jj ) * zwy(ji ,jj ) & 402 & + ftnw(ji+1,jj) * zwy(ji+1,jj ) & 403 & + ftse(ji,jj ) * zwy(ji ,jj-1) & 404 & + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 405 zv_trd(ji,jj) = - z1_12 / e2v(ji,jj) * ( ftsw(ji,jj+1) * zwx(ji-1,jj+1) & 406 & + ftse(ji,jj+1) * zwx(ji ,jj+1) & 407 & + ftnw(ji,jj ) * zwx(ji-1,jj ) & 408 & + ftne(ji,jj ) * zwx(ji ,jj ) ) 409 END DO 410 END DO 411 ! 412 ENDIF 413 ! 414 un_b (:,:) = un_b(:,:) * hur(:,:) ! Revert now transport to barotropic velocities 415 vn_b (:,:) = vn_b(:,:) * hvr(:,:) 268 416 ! !* Right-Hand-Side of the barotropic momentum equation 269 417 ! ! ---------------------------------------------------- 270 IF( lk_vvl ) THEN ! Variable volume : remove both Coriolis and Surface pressure gradient418 IF( lk_vvl ) THEN ! Variable volume : remove surface pressure gradient 271 419 DO jj = 2, jpjm1 272 420 DO ji = fs_2, fs_jpim1 ! vector opt. 273 zcu(ji,jj) = zcu(ji,jj) - grav * ( ( rhd(ji+1,jj ,1) + 1 ) * sshn(ji+1,jj ) & 274 & - ( rhd(ji ,jj ,1) + 1 ) * sshn(ji ,jj ) ) * hu(ji,jj) / e1u(ji,jj) 275 zcv(ji,jj) = zcv(ji,jj) - grav * ( ( rhd(ji ,jj+1,1) + 1 ) * sshn(ji ,jj+1) & 276 & - ( rhd(ji ,jj ,1) + 1 ) * sshn(ji ,jj ) ) * hv(ji,jj) / e2v(ji,jj) 277 END DO 278 END DO 279 ENDIF 280 281 DO jj = 2, jpjm1 ! Remove coriolis term (and possibly spg) from barotropic trend 421 zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) / e1u(ji,jj) 422 zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji ,jj+1) - sshn(ji ,jj ) ) / e2v(ji,jj) 423 END DO 424 END DO 425 ENDIF 426 427 DO jj = 2, jpjm1 ! Remove coriolis term (and possibly spg) from barotropic trend 282 428 DO ji = fs_2, fs_jpim1 283 zu a(ji,jj) = zua(ji,jj) - zcu(ji,jj)284 zv a(ji,jj) = zva(ji,jj) - zcv(ji,jj)429 zu_frc(ji,jj) = zu_frc(ji,jj) - zu_trd(ji,jj) * umask(ji,jj,1) 430 zv_frc(ji,jj) = zv_frc(ji,jj) - zv_trd(ji,jj) * vmask(ji,jj,1) 285 431 END DO 286 END DO 287 288 289 ! ! Remove barotropic contribution of bottom friction 290 ! ! from the barotropic transport trend 291 zcoef = -1._wp * z1_2dt_b 292 293 IF(ln_bfrimp) THEN 294 ! ! Remove the bottom stress trend from 3-D sea surface level gradient 295 ! ! and Coriolis forcing in case of 3D semi-implicit bottom friction 296 DO jj = 2, jpjm1 297 DO ji = fs_2, fs_jpim1 298 ikbu = mbku(ji,jj) 299 ikbv = mbkv(ji,jj) 300 ua_btm = zcu(ji,jj) * z2dt_bf * hur(ji,jj) * umask (ji,jj,ikbu) 301 va_btm = zcv(ji,jj) * z2dt_bf * hvr(ji,jj) * vmask (ji,jj,ikbv) 302 303 zua(ji,jj) = zua(ji,jj) - bfrua(ji,jj) * ua_btm 304 zva(ji,jj) = zva(ji,jj) - bfrva(ji,jj) * va_btm 305 END DO 306 END DO 307 308 ELSE 309 310 # if defined key_vectopt_loop 311 DO jj = 1, 1 312 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling) 313 # else 314 DO jj = 2, jpjm1 315 DO ji = 2, jpim1 316 # endif 317 ! Apply stability criteria for bottom friction 318 !RBbug for vvl and external mode we may need to use varying fse3 319 !!gm Rq: the bottom e3 present the smallest variation, the use of e3u_0 is not a big approx. 320 zbfru(ji,jj) = MAX( bfrua(ji,jj) , fse3u(ji,jj,mbku(ji,jj)) * zcoef ) 321 zbfrv(ji,jj) = MAX( bfrva(ji,jj) , fse3v(ji,jj,mbkv(ji,jj)) * zcoef ) 322 END DO 323 END DO 324 325 IF( lk_vvl ) THEN 326 DO jj = 2, jpjm1 327 DO ji = fs_2, fs_jpim1 ! vector opt. 328 zua(ji,jj) = zua(ji,jj) - zbfru(ji,jj) * ub_b(ji,jj) & 329 & / ( hu_0(ji,jj) + sshu_b(ji,jj) + 1._wp - umask(ji,jj,1) ) 330 zva(ji,jj) = zva(ji,jj) - zbfrv(ji,jj) * vb_b(ji,jj) & 331 & / ( hv_0(ji,jj) + sshv_b(ji,jj) + 1._wp - vmask(ji,jj,1) ) 332 END DO 333 END DO 334 ELSE 335 DO jj = 2, jpjm1 336 DO ji = fs_2, fs_jpim1 ! vector opt. 337 zua(ji,jj) = zua(ji,jj) - zbfru(ji,jj) * ub_b(ji,jj) * hur(ji,jj) 338 zva(ji,jj) = zva(ji,jj) - zbfrv(ji,jj) * vb_b(ji,jj) * hvr(ji,jj) 339 END DO 340 END DO 341 ENDIF 342 END IF ! end (ln_bfrimp) 343 344 345 ! !* d/dt(Ua), Ub, Vn (Vertical mean velocity) 346 ! ! -------------------------- 347 zua(:,:) = zua(:,:) * hur(:,:) 348 zva(:,:) = zva(:,:) * hvr(:,:) 349 ! 350 IF( lk_vvl ) THEN 351 ub_b(:,:) = ub_b(:,:) * umask(:,:,1) / ( hu_0(:,:) + sshu_b(:,:) + 1._wp - umask(:,:,1) ) 352 vb_b(:,:) = vb_b(:,:) * vmask(:,:,1) / ( hv_0(:,:) + sshv_b(:,:) + 1._wp - vmask(:,:,1) ) 353 ELSE 354 ub_b(:,:) = ub_b(:,:) * hur(:,:) 355 vb_b(:,:) = vb_b(:,:) * hvr(:,:) 356 ENDIF 357 432 END DO 433 ! 434 ! ! Add bottom stress contribution from baroclinic velocities: 435 IF (ln_bt_fw) THEN 436 DO jj = 2, jpjm1 437 DO ji = fs_2, fs_jpim1 ! vector opt. 438 ikbu = mbku(ji,jj) 439 ikbv = mbkv(ji,jj) 440 zwx(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) ! NOW bottom baroclinic velocities 441 zwy(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) 442 END DO 443 END DO 444 ELSE 445 DO jj = 2, jpjm1 446 DO ji = fs_2, fs_jpim1 ! vector opt. 447 ikbu = mbku(ji,jj) 448 ikbv = mbkv(ji,jj) 449 zwx(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) ! BEFORE bottom baroclinic velocities 450 zwy(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) 451 END DO 452 END DO 453 ENDIF 454 ! 455 ! Note that the "unclipped" bottom friction parameter is used even with explicit drag 456 zu_frc(:,:) = zu_frc(:,:) + hur(:,:) * bfrua(:,:) * zwx(:,:) 457 zv_frc(:,:) = zv_frc(:,:) + hvr(:,:) * bfrva(:,:) * zwy(:,:) 458 ! 459 IF (ln_bt_fw) THEN ! Add wind forcing 460 zu_frc(:,:) = zu_frc(:,:) + zraur * utau(:,:) * hur(:,:) 461 zv_frc(:,:) = zv_frc(:,:) + zraur * vtau(:,:) * hvr(:,:) 462 ELSE 463 zu_frc(:,:) = zu_frc(:,:) + zraur * z1_2 * ( utau_b(:,:) + utau(:,:) ) * hur(:,:) 464 zv_frc(:,:) = zv_frc(:,:) + zraur * z1_2 * ( vtau_b(:,:) + vtau(:,:) ) * hvr(:,:) 465 ENDIF 466 ! 467 IF ( ln_apr_dyn ) THEN ! Add atm pressure forcing 468 IF (ln_bt_fw) THEN 469 DO jj = 2, jpjm1 470 DO ji = fs_2, fs_jpim1 ! vector opt. 471 zu_spg = grav * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) ) /e1u(ji,jj) 472 zv_spg = grav * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) ) /e2v(ji,jj) 473 zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 474 zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 475 END DO 476 END DO 477 ELSE 478 DO jj = 2, jpjm1 479 DO ji = fs_2, fs_jpim1 ! vector opt. 480 zu_spg = grav * z1_2 * ( ssh_ib (ji+1,jj ) - ssh_ib (ji,jj) & 481 & + ssh_ibb(ji+1,jj ) - ssh_ibb(ji,jj) ) /e1u(ji,jj) 482 zv_spg = grav * z1_2 * ( ssh_ib (ji ,jj+1) - ssh_ib (ji,jj) & 483 & + ssh_ibb(ji ,jj+1) - ssh_ibb(ji,jj) ) /e2v(ji,jj) 484 zu_frc(ji,jj) = zu_frc(ji,jj) + zu_spg 485 zv_frc(ji,jj) = zv_frc(ji,jj) + zv_spg 486 END DO 487 END DO 488 ENDIF 489 ENDIF 490 ! !* Right-Hand-Side of the barotropic ssh equation 491 ! ! ----------------------------------------------- 492 ! ! Surface net water flux and rivers 493 IF (ln_bt_fw) THEN 494 zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) ) 495 ELSE 496 zssh_frc(:,:) = zraur * z1_2 * (emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)) 497 ENDIF 498 #if defined key_asminc 499 ! ! Include the IAU weighted SSH increment 500 IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN 501 zssh_frc(:,:) = zssh_frc(:,:) + ssh_iau(:,:) 502 ENDIF 503 #endif 504 ! 358 505 ! ----------------------------------------------------------------------- 359 ! Phase 2 : Integration of the barotropic equations with time splitting506 ! Phase 2 : Integration of the barotropic equations 360 507 ! ----------------------------------------------------------------------- 361 508 ! 362 509 ! ! ==================== ! 363 510 ! ! Initialisations ! 511 ! ! ==================== ! 512 ! Initialize barotropic variables: 513 IF (ln_bt_fw) THEN ! FORWARD integration: start from NOW fields 514 sshn_e (:,:) = sshn (:,:) 515 zun_e (:,:) = un_b (:,:) 516 zvn_e (:,:) = vn_b (:,:) 517 ELSE ! CENTERED integration: start from BEFORE fields 518 sshn_e (:,:) = sshb (:,:) 519 zun_e (:,:) = ub_b (:,:) 520 zvn_e (:,:) = vb_b (:,:) 521 ENDIF 522 ! 523 ! Initialize depths: 524 IF ( lk_vvl.AND.(.NOT.ln_bt_fw) ) THEN 525 hu_e (:,:) = umask(:,:,1) / ( zhur_b(:,:) + 1._wp - umask(:,:,1) ) 526 hv_e (:,:) = vmask(:,:,1) / ( zhvr_b(:,:) + 1._wp - vmask(:,:,1) ) 527 hur_e (:,:) = zhur_b(:,:) 528 hvr_e (:,:) = zhvr_b(:,:) 529 ELSE 530 hu_e (:,:) = hu (:,:) 531 hv_e (:,:) = hv (:,:) 532 hur_e (:,:) = hur (:,:) 533 hvr_e (:,:) = hvr (:,:) 534 ENDIF 535 ! 536 IF (.NOT.lk_vvl) THEN ! Depths at jn+0.5: 537 zhup2_e (:,:) = hu(:,:) 538 zhvp2_e (:,:) = hv(:,:) 539 ENDIF 540 ! 541 ! Initialize sums: 542 ua_b (:,:) = 0._wp ! After barotropic velocities (or transport if flux form) 543 va_b (:,:) = 0._wp 544 ssha (:,:) = 0._wp ! Sum for after averaged sea level 545 zu_sum(:,:) = 0._wp ! Sum for now transport issued from ts loop 546 zv_sum(:,:) = 0._wp 364 547 ! ! ==================== ! 365 icycle = 2 * nn_baro ! Number of barotropic sub time-step 366 367 ! ! Start from NOW field 368 hu_e (:,:) = hu (:,:) ! ocean depth at u- and v-points 369 hv_e (:,:) = hv (:,:) 370 hur_e (:,:) = hur (:,:) ! ocean depth inverted at u- and v-points 371 hvr_e (:,:) = hvr (:,:) 372 !RBbug zsshb_e(:,:) = sshn (:,:) 373 zsshb_e(:,:) = sshn_b(:,:) ! sea surface height (before and now) 374 sshn_e (:,:) = sshn (:,:) 375 376 zun_e (:,:) = un_b (:,:) ! barotropic velocity (external) 377 zvn_e (:,:) = vn_b (:,:) 378 zub_e (:,:) = un_b (:,:) 379 zvb_e (:,:) = vn_b (:,:) 380 381 zu_sum (:,:) = un_b (:,:) ! summation 382 zv_sum (:,:) = vn_b (:,:) 383 zssh_sum(:,:) = sshn (:,:) 384 385 #if defined key_obc 386 ! set ssh corrections to 0 387 ! ssh corrections are applied to normal velocities (Flather's algorithm) and averaged over the barotropic loop 388 IF( lp_obc_east ) sshfoe_b(:,:) = 0._wp 389 IF( lp_obc_west ) sshfow_b(:,:) = 0._wp 390 IF( lp_obc_south ) sshfos_b(:,:) = 0._wp 391 IF( lp_obc_north ) sshfon_b(:,:) = 0._wp 392 #endif 393 394 ! ! ==================== ! 395 DO jn = 1, icycle ! sub-time-step loop ! (from NOW to AFTER+1) 548 DO jn = 1, icycle ! sub-time-step loop ! 396 549 ! ! ==================== ! 397 z2dt_e = 2. * ( rdt / nn_baro )398 IF( jn == 1 ) z2dt_e = rdt / nn_baro399 400 550 ! !* Update the forcing (BDY and tides) 401 551 ! ! ------------------ 402 IF( lk_obc ) CALL obc_dta_bt ( kt, jn ) 403 IF( lk_bdy ) CALL bdy_dta ( kt, jit=jn, time_offset=+1 ) 404 IF ( ln_tide_pot .AND. lk_tide) CALL upd_tide( kt, jn ) 405 406 ! !* after ssh_e 552 ! Update only tidal forcing at open boundaries 553 #if defined key_tide 554 IF ( lk_bdy .AND. lk_tide ) CALL bdy_dta_tides( kt, kit=jn, time_offset=(noffset+1) ) 555 IF ( ln_tide_pot .AND. lk_tide ) CALL upd_tide( kt, kit=jn, koffset=noffset ) 556 #endif 557 ! 558 ! Set extrapolation coefficients for predictor step: 559 IF ((jn<3).AND.ll_init) THEN ! Forward 560 za1 = 1._wp 561 za2 = 0._wp 562 za3 = 0._wp 563 ELSE ! AB3-AM4 Coefficients: bet=0.281105 564 za1 = 1.781105_wp ! za1 = 3/2 + bet 565 za2 = -1.06221_wp ! za2 = -(1/2 + 2*bet) 566 za3 = 0.281105_wp ! za3 = bet 567 ENDIF 568 569 ! Extrapolate barotropic velocities at step jit+0.5: 570 ua_e(:,:) = za1 * zun_e(:,:) + za2 * ub_e(:,:) + za3 * ubb_e(:,:) 571 va_e(:,:) = za1 * zvn_e(:,:) + za2 * vb_e(:,:) + za3 * vbb_e(:,:) 572 573 IF( lk_vvl ) THEN !* Update ocean depth (variable volume case only) 574 ! ! ------------------ 575 ! Extrapolate Sea Level at step jit+0.5: 576 zsshp2_e(:,:) = za1 * sshn_e(:,:) + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 577 ! 578 DO jj = 2, jpjm1 ! Sea Surface Height at u- & v-points 579 DO ji = 2, fs_jpim1 ! Vector opt. 580 zwx(ji,jj) = z1_2 * umask(ji,jj,1) / ( e1u(ji,jj) * e2u(ji,jj) ) & 581 & * ( e1t(ji ,jj) * e2t(ji ,jj) * zsshp2_e(ji ,jj) & 582 & + e1t(ji+1,jj) * e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) 583 zwy(ji,jj) = z1_2 * vmask(ji,jj,1) / ( e1v(ji,jj) * e2v(ji,jj) ) & 584 & * ( e1t(ji,jj ) * e2t(ji,jj ) * zsshp2_e(ji,jj ) & 585 & + e1t(ji,jj+1) * e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) 586 END DO 587 END DO 588 CALL lbc_lnk( zwx, 'U', 1._wp ) ; CALL lbc_lnk( zwy, 'V', 1._wp ) 589 ! 590 zhup2_e (:,:) = hu_0(:,:) + zwx(:,:) ! Ocean depth at U- and V-points 591 zhvp2_e (:,:) = hv_0(:,:) + zwy(:,:) 592 ENDIF 593 ! !* after ssh 407 594 ! ! ----------- 408 DO jj = 2, jpjm1 ! Horizontal divergence of barotropic transports 595 ! One should enforce volume conservation at open boundaries here 596 ! considering fluxes below: 597 ! 598 zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:) ! fluxes at jn+0.5 599 zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 600 DO jj = 2, jpjm1 409 601 DO ji = fs_2, fs_jpim1 ! vector opt. 410 zhdiv(ji,jj) = ( e2u(ji ,jj) * zun_e(ji ,jj) * hu_e(ji ,jj) & 411 & - e2u(ji-1,jj) * zun_e(ji-1,jj) * hu_e(ji-1,jj) & 412 & + e1v(ji,jj ) * zvn_e(ji,jj ) * hv_e(ji,jj ) & 413 & - e1v(ji,jj-1) * zvn_e(ji,jj-1) * hv_e(ji,jj-1) ) / ( e1t(ji,jj) * e2t(ji,jj) ) 414 END DO 415 END DO 416 ! 417 #if defined key_obc 418 ! ! OBC : zhdiv must be zero behind the open boundary 419 !! mpp remark: The zeroing of hdiv can probably be extended to 1->jpi/jpj for the correct row/column 420 IF( lp_obc_east ) zhdiv(nie0p1:nie1p1,nje0 :nje1 ) = 0._wp ! east 421 IF( lp_obc_west ) zhdiv(niw0 :niw1 ,njw0 :njw1 ) = 0._wp ! west 422 IF( lp_obc_north ) zhdiv(nin0 :nin1 ,njn0p1:njn1p1) = 0._wp ! north 423 IF( lp_obc_south ) zhdiv(nis0 :nis1 ,njs0 :njs1 ) = 0._wp ! south 602 zhdiv(ji,jj) = ( zwx(ji,jj) - zwx(ji-1,jj) & 603 & + zwy(ji,jj) - zwy(ji,jj-1) & 604 & ) / ( e1t(ji,jj) * e2t(ji,jj) ) 605 END DO 606 END DO 607 ! 608 ! Sum over sub-time-steps to compute advective velocities 609 za2 = wgtbtp2(jn) 610 zu_sum (:,:) = zu_sum (:,:) + za2 * ua_e (:,:) * zhup2_e (:,:) 611 zv_sum (:,:) = zv_sum (:,:) + za2 * va_e (:,:) * zhvp2_e (:,:) 612 ! 613 ! Set next sea level: 614 ssha_e(:,:) = ( sshn_e(:,:) - rdtbt * ( zssh_frc(:,:) + zhdiv(:,:) ) ) * tmask(:,:,1) 615 CALL lbc_lnk( ssha_e, 'T', 1._wp ) 616 617 #if defined key_bdy 618 ! Duplicate sea level across open boundaries (this is only cosmetic if lk_vvl=.false.) 619 IF (lk_bdy) CALL bdy_ssh( ssha_e ) 424 620 #endif 425 #if defined key_ bdy426 zhdiv(:,:) = zhdiv(:,:) * bdytmask(:,:) ! BDY mask621 #if defined key_agrif 622 IF( .NOT.Agrif_Root() ) CALL agrif_ssh_ts( jn ) 427 623 #endif 428 ! 429 DO jj = 2, jpjm1 ! leap-frog on ssh_e 430 DO ji = fs_2, fs_jpim1 ! vector opt. 431 ssha_e(ji,jj) = ( zsshb_e(ji,jj) - z2dt_e * ( zraur * ( emp(ji,jj)-rnf(ji,jj) ) + zhdiv(ji,jj) ) ) * tmask(ji,jj,1) 432 END DO 433 END DO 434 435 ! !* after barotropic velocities (vorticity scheme dependent) 436 ! ! --------------------------- 437 zwx(:,:) = e2u(:,:) * zun_e(:,:) * hu_e(:,:) ! now_e transport 438 zwy(:,:) = e1v(:,:) * zvn_e(:,:) * hv_e(:,:) 624 ! 625 ! Sea Surface Height at u-,v-points (vvl case only) 626 IF ( lk_vvl ) THEN 627 DO jj = 2, jpjm1 628 DO ji = 2, jpim1 ! NO Vector Opt. 629 zsshu_a(ji,jj) = z1_2 * umask(ji,jj,1) / ( e1u(ji ,jj) * e2u(ji ,jj) ) & 630 & * ( e1t(ji ,jj) * e2t(ji ,jj) * ssha_e(ji ,jj) & 631 & + e1t(ji+1,jj) * e2t(ji+1,jj) * ssha_e(ji+1,jj) ) 632 zsshv_a(ji,jj) = z1_2 * vmask(ji,jj,1) / ( e1v(ji,jj ) * e2v(ji,jj ) ) & 633 & * ( e1t(ji,jj ) * e2t(ji,jj ) * ssha_e(ji,jj ) & 634 & + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha_e(ji,jj+1) ) 635 END DO 636 END DO 637 CALL lbc_lnk( zsshu_a, 'U', 1._wp ) ; CALL lbc_lnk( zsshv_a, 'V', 1._wp ) 638 ENDIF 639 ! 640 ! Half-step back interpolation of SSH for surface pressure computation: 641 !---------------------------------------------------------------------- 642 IF ((jn==1).AND.ll_init) THEN 643 za0=1._wp ! Forward-backward 644 za1=0._wp 645 za2=0._wp 646 za3=0._wp 647 ELSEIF ((jn==2).AND.ll_init) THEN ! AB2-AM3 Coefficients; bet=0 ; gam=-1/6 ; eps=1/12 648 za0= 1.0833333333333_wp ! za0 = 1-gam-eps 649 za1=-0.1666666666666_wp ! za1 = gam 650 za2= 0.0833333333333_wp ! za2 = eps 651 za3= 0._wp 652 ELSE ! AB3-AM4 Coefficients; bet=0.281105 ; eps=0.013 ; gam=0.0880 653 za0=0.614_wp ! za0 = 1/2 + gam + 2*eps 654 za1=0.285_wp ! za1 = 1/2 - 2*gam - 3*eps 655 za2=0.088_wp ! za2 = gam 656 za3=0.013_wp ! za3 = eps 657 ENDIF 658 659 zsshp2_e(:,:) = za0 * ssha_e(:,:) + za1 * sshn_e (:,:) & 660 & + za2 * sshb_e(:,:) + za3 * sshbb_e(:,:) 661 662 ! 663 ! Compute associated depths at U and V points: 664 IF ( lk_vvl.AND.(.NOT.ln_dynadv_vec) ) THEN 665 ! 666 DO jj = 2, jpjm1 667 DO ji = 2, jpim1 668 zx1 = z1_2 * umask(ji,jj,1) / ( e1u(ji,jj) * e2u(ji,jj) ) & 669 & * ( e1t(ji ,jj) * e2t(ji ,jj) * zsshp2_e(ji ,jj) & 670 & + e1t(ji+1,jj) * e2t(ji+1,jj) * zsshp2_e(ji+1,jj) ) 671 zy1 = z1_2 * vmask(ji,jj,1) / ( e1v(ji,jj) * e2v(ji,jj) ) & 672 & * ( e1t(ji,jj ) * e2t(ji,jj ) * zsshp2_e(ji,jj ) & 673 & + e1t(ji,jj+1) * e2t(ji,jj+1) * zsshp2_e(ji,jj+1) ) 674 zhust_e(ji,jj) = hu_0(ji,jj) + zx1 675 zhvst_e(ji,jj) = hv_0(ji,jj) + zy1 676 END DO 677 END DO 678 ENDIF 679 ! 680 ! Add Coriolis trend: 681 ! zwz array below or triads normally depend on sea level with key_vvl and should be updated 682 ! at each time step. We however keep them constant here for optimization. 683 ! Recall that zwx and zwy arrays hold fluxes at this stage: 684 ! zwx(:,:) = e2u(:,:) * ua_e(:,:) * zhup2_e(:,:) ! fluxes at jn+0.5 685 ! zwy(:,:) = e1v(:,:) * va_e(:,:) * zhvp2_e(:,:) 439 686 ! 440 687 IF( ln_dynvor_ene .OR. ln_dynvor_mix ) THEN !== energy conserving or mixed scheme ==! 441 688 DO jj = 2, jpjm1 442 689 DO ji = fs_2, fs_jpim1 ! vector opt. 443 ! surface pressure gradient444 IF( lk_vvl) THEN445 zu_spg = -grav * ( ( rhd(ji+1,jj ,1) + 1 ) * sshn_e(ji+1,jj ) &446 & - ( rhd(ji ,jj ,1) + 1 ) * sshn_e(ji ,jj ) ) / e1u(ji,jj)447 zv_spg = -grav * ( ( rhd(ji ,jj+1,1) + 1 ) * sshn_e(ji ,jj+1) &448 & - ( rhd(ji ,jj ,1) + 1 ) * sshn_e(ji ,jj ) ) / e2v(ji,jj)449 ELSE450 zu_spg = -grav * ( sshn_e(ji+1,jj) - sshn_e(ji,jj) ) / e1u(ji,jj)451 zv_spg = -grav * ( sshn_e(ji,jj+1) - sshn_e(ji,jj) ) / e2v(ji,jj)452 ENDIF453 ! add tidal astronomical forcing454 IF ( ln_tide_pot .AND. lk_tide ) THEN455 zu_spg = zu_spg + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) / e1u(ji,jj)456 zv_spg = zv_spg + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) / e2v(ji,jj)457 ENDIF458 ! energy conserving formulation for planetary vorticity term459 690 zy1 = ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) ) / e1u(ji,jj) 460 691 zy2 = ( zwy(ji ,jj ) + zwy(ji+1,jj ) ) / e1u(ji,jj) 461 692 zx1 = ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) ) / e2v(ji,jj) 462 693 zx2 = ( zwx(ji ,jj ) + zwx(ji ,jj+1) ) / e2v(ji,jj) 463 zu_cor = z1_4 * ( ff(ji ,jj-1) * zy1 + ff(ji,jj) * zy2 ) * hur_e(ji,jj) 464 zv_cor =-z1_4 * ( ff(ji-1,jj ) * zx1 + ff(ji,jj) * zx2 ) * hvr_e(ji,jj) 465 ! after velocities with implicit bottom friction 466 467 IF( ln_bfrimp ) THEN ! implicit bottom friction 468 ! A new method to implement the implicit bottom friction. 469 ! H. Liu 470 ! Sept 2011 471 ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) + & 472 & z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp ) & 473 & / ( 1._wp - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 474 ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e * zua(ji,jj) ) * umask(ji,jj,1) 475 ! 476 va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) + & 477 & z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp ) & 478 & / ( 1._wp - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 479 va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e * zva(ji,jj) ) * vmask(ji,jj,1) 480 ! 481 ELSE 482 ua_e(ji,jj) = ( zub_e(ji,jj) + z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp + zua(ji,jj))) * umask(ji,jj,1) & 483 & / ( 1._wp - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) 484 va_e(ji,jj) = ( zvb_e(ji,jj) + z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp + zva(ji,jj))) * vmask(ji,jj,1) & 485 & / ( 1._wp - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) 486 ENDIF 694 zu_trd(ji,jj) = z1_4 * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) 695 zv_trd(ji,jj) =-z1_4 * ( zwz(ji-1,jj ) * zx1 + zwz(ji,jj) * zx2 ) 487 696 END DO 488 697 END DO … … 491 700 DO jj = 2, jpjm1 492 701 DO ji = fs_2, fs_jpim1 ! vector opt. 493 ! surface pressure gradient 494 IF( lk_vvl) THEN 495 zu_spg = -grav * ( ( rhd(ji+1,jj ,1) + 1 ) * sshn_e(ji+1,jj ) & 496 & - ( rhd(ji ,jj ,1) + 1 ) * sshn_e(ji ,jj ) ) / e1u(ji,jj) 497 zv_spg = -grav * ( ( rhd(ji ,jj+1,1) + 1 ) * sshn_e(ji ,jj+1) & 498 & - ( rhd(ji ,jj ,1) + 1 ) * sshn_e(ji ,jj ) ) / e2v(ji,jj) 499 ELSE 500 zu_spg = -grav * ( sshn_e(ji+1,jj) - sshn_e(ji,jj) ) / e1u(ji,jj) 501 zv_spg = -grav * ( sshn_e(ji,jj+1) - sshn_e(ji,jj) ) / e2v(ji,jj) 502 ENDIF 503 ! add tidal astronomical forcing 504 IF ( ln_tide_pot .AND. lk_tide ) THEN 505 zu_spg = zu_spg + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) / e1u(ji,jj) 506 zv_spg = zv_spg + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) / e2v(ji,jj) 507 ENDIF 508 ! enstrophy conserving formulation for planetary vorticity term 509 zy1 = z1_8 * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) + zwy(ji,jj) + zwy(ji+1,jj ) ) / e1u(ji,jj) 510 zx1 = - z1_8 * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) + zwx(ji,jj) + zwx(ji ,jj+1) ) / e2v(ji,jj) 511 zu_cor = zy1 * ( ff(ji ,jj-1) + ff(ji,jj) ) * hur_e(ji,jj) 512 zv_cor = zx1 * ( ff(ji-1,jj ) + ff(ji,jj) ) * hvr_e(ji,jj) 513 ! after velocities with implicit bottom friction 514 IF( ln_bfrimp ) THEN 515 ! A new method to implement the implicit bottom friction. 516 ! H. Liu 517 ! Sept 2011 518 ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) + & 519 & z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp ) & 520 & / ( 1._wp - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 521 ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e * zua(ji,jj) ) * umask(ji,jj,1) 522 ! 523 va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) + & 524 & z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp ) & 525 & / ( 1._wp - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 526 va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e * zva(ji,jj) ) * vmask(ji,jj,1) 527 ! 528 ELSE 529 ua_e(ji,jj) = ( zub_e(ji,jj) + z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp + zua(ji,jj))) * umask(ji,jj,1) & 530 & / ( 1._wp - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) 531 va_e(ji,jj) = ( zvb_e(ji,jj) + z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp + zva(ji,jj))) * vmask(ji,jj,1) & 532 & / ( 1._wp - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) 533 ENDIF 702 zy1 = z1_8 * ( zwy(ji ,jj-1) + zwy(ji+1,jj-1) & 703 & + zwy(ji ,jj ) + zwy(ji+1,jj ) ) / e1u(ji,jj) 704 zx1 = - z1_8 * ( zwx(ji-1,jj ) + zwx(ji-1,jj+1) & 705 & + zwx(ji ,jj ) + zwx(ji ,jj+1) ) / e2v(ji,jj) 706 zu_trd(ji,jj) = zy1 * ( zwz(ji ,jj-1) + zwz(ji,jj) ) 707 zv_trd(ji,jj) = zx1 * ( zwz(ji-1,jj ) + zwz(ji,jj) ) 534 708 END DO 535 709 END DO … … 538 712 DO jj = 2, jpjm1 539 713 DO ji = fs_2, fs_jpim1 ! vector opt. 540 ! surface pressure gradient 541 IF( lk_vvl) THEN 542 zu_spg = -grav * ( ( rhd(ji+1,jj ,1) + 1 ) * sshn_e(ji+1,jj ) & 543 & - ( rhd(ji ,jj ,1) + 1 ) * sshn_e(ji ,jj ) ) / e1u(ji,jj) 544 zv_spg = -grav * ( ( rhd(ji ,jj+1,1) + 1 ) * sshn_e(ji ,jj+1) & 545 & - ( rhd(ji ,jj ,1) + 1 ) * sshn_e(ji ,jj ) ) / e2v(ji,jj) 546 ELSE 547 zu_spg = -grav * ( sshn_e(ji+1,jj) - sshn_e(ji,jj) ) / e1u(ji,jj) 548 zv_spg = -grav * ( sshn_e(ji,jj+1) - sshn_e(ji,jj) ) / e2v(ji,jj) 549 ENDIF 550 ! add tidal astronomical forcing 551 IF ( ln_tide_pot .AND. lk_tide ) THEN 552 zu_spg = zu_spg + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) / e1u(ji,jj) 553 zv_spg = zv_spg + grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) / e2v(ji,jj) 554 ENDIF 555 ! energy/enstrophy conserving formulation for planetary vorticity term 556 zu_cor = + z1_4 / e1u(ji,jj) * ( ftne(ji,jj ) * zwy(ji ,jj ) + ftnw(ji+1,jj) * zwy(ji+1,jj ) & 557 & + ftse(ji,jj ) * zwy(ji ,jj-1) + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) * hur_e(ji,jj) 558 zv_cor = - z1_4 / e2v(ji,jj) * ( ftsw(ji,jj+1) * zwx(ji-1,jj+1) + ftse(ji,jj+1) * zwx(ji ,jj+1) & 559 & + ftnw(ji,jj ) * zwx(ji-1,jj ) + ftne(ji,jj ) * zwx(ji ,jj ) ) * hvr_e(ji,jj) 560 ! after velocities with implicit bottom friction 561 IF( ln_bfrimp ) THEN 562 ! A new method to implement the implicit bottom friction. 563 ! H. Liu 564 ! Sept 2011 565 ua_e(ji,jj) = umask(ji,jj,1) * ( zub_e(ji,jj) + & 566 & z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp ) & 567 & / ( 1._wp - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) ) 568 ua_e(ji,jj) = ( ua_e(ji,jj) + z2dt_e * zua(ji,jj) ) * umask(ji,jj,1) 569 ! 570 va_e(ji,jj) = vmask(ji,jj,1) * ( zvb_e(ji,jj) + & 571 & z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp ) & 572 & / ( 1._wp - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) ) 573 va_e(ji,jj) = ( va_e(ji,jj) + z2dt_e * zva(ji,jj) ) * vmask(ji,jj,1) 574 ! 575 ELSE 576 ua_e(ji,jj) = ( zub_e(ji,jj) + z2dt_e * ( zu_cor + zu_spg + zu_sld + zu_asp + zua(ji,jj))) * umask(ji,jj,1) & 577 & / ( 1._wp - z2dt_e * bfrua(ji,jj) * hur_e(ji,jj) ) 578 va_e(ji,jj) = ( zvb_e(ji,jj) + z2dt_e * ( zv_cor + zv_spg + zv_sld + zv_asp + zva(ji,jj))) * vmask(ji,jj,1) & 579 & / ( 1._wp - z2dt_e * bfrva(ji,jj) * hvr_e(ji,jj) ) 580 ENDIF 714 zu_trd(ji,jj) = + z1_12 / e1u(ji,jj) * ( ftne(ji,jj ) * zwy(ji ,jj ) & 715 & + ftnw(ji+1,jj) * zwy(ji+1,jj ) & 716 & + ftse(ji,jj ) * zwy(ji ,jj-1) & 717 & + ftsw(ji+1,jj) * zwy(ji+1,jj-1) ) 718 zv_trd(ji,jj) = - z1_12 / e2v(ji,jj) * ( ftsw(ji,jj+1) * zwx(ji-1,jj+1) & 719 & + ftse(ji,jj+1) * zwx(ji ,jj+1) & 720 & + ftnw(ji,jj ) * zwx(ji-1,jj ) & 721 & + ftne(ji,jj ) * zwx(ji ,jj ) ) 581 722 END DO 582 723 END DO 583 724 ! 584 725 ENDIF 585 ! !* domain lateral boundary 586 ! ! ----------------------- 587 588 ! OBC open boundaries 589 IF( lk_obc ) CALL obc_fla_ts ( ua_e, va_e, sshn_e, ssha_e ) 590 591 ! BDY open boundaries 592 #if defined key_bdy 593 pssh => sshn_e 594 phur => hur_e 595 phvr => hvr_e 596 pu2d => ua_e 597 pv2d => va_e 598 599 IF( lk_bdy ) CALL bdy_dyn2d( kt ) 600 #endif 601 602 ! 603 CALL lbc_lnk( ua_e , 'U', -1. ) ! local domain boundaries 604 CALL lbc_lnk( va_e , 'V', -1. ) 605 CALL lbc_lnk( ssha_e, 'T', 1. ) 606 607 zu_sum (:,:) = zu_sum (:,:) + ua_e (:,:) ! Sum over sub-time-steps 608 zv_sum (:,:) = zv_sum (:,:) + va_e (:,:) 609 zssh_sum(:,:) = zssh_sum(:,:) + ssha_e(:,:) 610 611 ! !* Time filter and swap 612 ! ! -------------------- 613 IF( jn == 1 ) THEN ! Swap only (1st Euler time step) 614 zsshb_e(:,:) = sshn_e(:,:) 615 zub_e (:,:) = zun_e (:,:) 616 zvb_e (:,:) = zvn_e (:,:) 617 sshn_e (:,:) = ssha_e(:,:) 618 zun_e (:,:) = ua_e (:,:) 619 zvn_e (:,:) = va_e (:,:) 620 ELSE ! Swap + Filter 621 zsshb_e(:,:) = atfp * ( zsshb_e(:,:) + ssha_e(:,:) ) + atfp1 * sshn_e(:,:) 622 zub_e (:,:) = atfp * ( zub_e (:,:) + ua_e (:,:) ) + atfp1 * zun_e (:,:) 623 zvb_e (:,:) = atfp * ( zvb_e (:,:) + va_e (:,:) ) + atfp1 * zvn_e (:,:) 624 sshn_e (:,:) = ssha_e(:,:) 625 zun_e (:,:) = ua_e (:,:) 626 zvn_e (:,:) = va_e (:,:) 627 ENDIF 628 629 IF( lk_vvl ) THEN !* Update ocean depth (variable volume case only) 630 ! ! ------------------ 631 DO jj = 1, jpjm1 ! Sea Surface Height at u- & v-points 632 DO ji = 1, fs_jpim1 ! Vector opt. 633 zsshun_e(ji,jj) = 0.5_wp * umask(ji,jj,1) / ( e1u(ji,jj) * e2u(ji,jj) ) & 634 & * ( e1t(ji ,jj) * e2t(ji ,jj) * sshn_e(ji ,jj) & 635 & + e1t(ji+1,jj) * e2t(ji+1,jj) * sshn_e(ji+1,jj) ) 636 zsshvn_e(ji,jj) = 0.5_wp * vmask(ji,jj,1) / ( e1v(ji,jj) * e2v(ji,jj) ) & 637 & * ( e1t(ji,jj ) * e2t(ji,jj ) * sshn_e(ji,jj ) & 638 & + e1t(ji,jj+1) * e2t(ji,jj+1) * sshn_e(ji,jj+1) ) 639 END DO 640 END DO 641 CALL lbc_lnk( zsshun_e, 'U', 1. ) ! lateral boundaries conditions 642 CALL lbc_lnk( zsshvn_e, 'V', 1. ) 643 ! 644 hu_e (:,:) = hu_0(:,:) + zsshun_e(:,:) ! Ocean depth at U- and V-points 645 hv_e (:,:) = hv_0(:,:) + zsshvn_e(:,:) 726 ! 727 ! Add tidal astronomical forcing if defined 728 IF ( lk_tide.AND.ln_tide_pot ) THEN 729 DO jj = 2, jpjm1 730 DO ji = fs_2, fs_jpim1 ! vector opt. 731 zu_spg = grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) / e1u(ji,jj) 732 zv_spg = grav * ( pot_astro(ji,jj+1) - pot_astro(ji,jj) ) / e2v(ji,jj) 733 zu_trd(ji,jj) = zu_trd(ji,jj) + zu_spg 734 zv_trd(ji,jj) = zv_trd(ji,jj) + zv_spg 735 END DO 736 END DO 737 ENDIF 738 ! 739 ! Add bottom stresses: 740 zu_trd(:,:) = zu_trd(:,:) + bfrua(:,:) * zun_e(:,:) * hur_e(:,:) 741 zv_trd(:,:) = zv_trd(:,:) + bfrva(:,:) * zvn_e(:,:) * hvr_e(:,:) 742 ! 743 ! Surface pressure trend: 744 DO jj = 2, jpjm1 745 DO ji = fs_2, fs_jpim1 ! vector opt. 746 ! Add surface pressure gradient 747 zu_spg = - grav * ( zsshp2_e(ji+1,jj) - zsshp2_e(ji,jj) ) / e1u(ji,jj) 748 zv_spg = - grav * ( zsshp2_e(ji,jj+1) - zsshp2_e(ji,jj) ) / e2v(ji,jj) 749 zwx(ji,jj) = zu_spg 750 zwy(ji,jj) = zv_spg 751 END DO 752 END DO 753 ! 754 ! Set next velocities: 755 IF( ln_dynadv_vec .OR. (.NOT. lk_vvl) ) THEN ! Vector form 756 DO jj = 2, jpjm1 757 DO ji = fs_2, fs_jpim1 ! vector opt. 758 ua_e(ji,jj) = ( zun_e(ji,jj) & 759 & + rdtbt * ( zwx(ji,jj) & 760 & + zu_trd(ji,jj) & 761 & + zu_frc(ji,jj) ) & 762 & ) * umask(ji,jj,1) 763 764 va_e(ji,jj) = ( zvn_e(ji,jj) & 765 & + rdtbt * ( zwy(ji,jj) & 766 & + zv_trd(ji,jj) & 767 & + zv_frc(ji,jj) ) & 768 & ) * vmask(ji,jj,1) 769 END DO 770 END DO 771 772 ELSE ! Flux form 773 DO jj = 2, jpjm1 774 DO ji = fs_2, fs_jpim1 ! vector opt. 775 776 zhura = umask(ji,jj,1)/(hu_0(ji,jj) + zsshu_a(ji,jj) + 1._wp - umask(ji,jj,1)) 777 zhvra = vmask(ji,jj,1)/(hv_0(ji,jj) + zsshv_a(ji,jj) + 1._wp - vmask(ji,jj,1)) 778 779 ua_e(ji,jj) = ( hu_e(ji,jj) * zun_e(ji,jj) & 780 & + rdtbt * ( zhust_e(ji,jj) * zwx(ji,jj) & 781 & + zhup2_e(ji,jj) * zu_trd(ji,jj) & 782 & + hu(ji,jj) * zu_frc(ji,jj) ) & 783 & ) * zhura 784 785 va_e(ji,jj) = ( hv_e(ji,jj) * zvn_e(ji,jj) & 786 & + rdtbt * ( zhvst_e(ji,jj) * zwy(ji,jj) & 787 & + zhvp2_e(ji,jj) * zv_trd(ji,jj) & 788 & + hv(ji,jj) * zv_frc(ji,jj) ) & 789 & ) * zhvra 790 END DO 791 END DO 792 ENDIF 793 ! 794 IF( lk_vvl ) THEN !* Update ocean depth (variable volume case only) 795 ! ! ---------------------------------------------- 796 hu_e (:,:) = hu_0(:,:) + zsshu_a(:,:) 797 hv_e (:,:) = hv_0(:,:) + zsshv_a(:,:) 646 798 hur_e(:,:) = umask(:,:,1) / ( hu_e(:,:) + 1._wp - umask(:,:,1) ) 647 799 hvr_e(:,:) = vmask(:,:,1) / ( hv_e(:,:) + 1._wp - vmask(:,:,1) ) 648 800 ! 649 801 ENDIF 802 ! !* domain lateral boundary 803 ! ! ----------------------- 804 ! 805 CALL lbc_lnk( ua_e , 'U', -1._wp ) ! local domain boundaries 806 CALL lbc_lnk( va_e , 'V', -1._wp ) 807 808 #if defined key_bdy 809 810 pssh => ssha_e 811 phur => hur_e 812 phvr => hvr_e 813 pua2d => ua_e 814 pva2d => va_e 815 pub2d => zun_e 816 pvb2d => zvn_e 817 818 IF( lk_bdy ) CALL bdy_dyn2d( kt ) ! open boundaries 819 #endif 820 #if defined key_agrif 821 IF( .NOT.Agrif_Root() ) CALL agrif_dyn_ts( kt, jn ) ! Agrif 822 #endif 823 ! !* Swap 824 ! ! ---- 825 ubb_e (:,:) = ub_e (:,:) 826 ub_e (:,:) = zun_e (:,:) 827 zun_e (:,:) = ua_e (:,:) 828 ! 829 vbb_e (:,:) = vb_e (:,:) 830 vb_e (:,:) = zvn_e (:,:) 831 zvn_e (:,:) = va_e (:,:) 832 ! 833 sshbb_e(:,:) = sshb_e(:,:) 834 sshb_e (:,:) = sshn_e(:,:) 835 sshn_e (:,:) = ssha_e(:,:) 836 837 ! !* Sum over whole bt loop 838 ! ! ---------------------- 839 za1 = wgtbtp1(jn) 840 IF (( ln_dynadv_vec ).OR. (.NOT. lk_vvl)) THEN ! Sum velocities 841 ua_b (:,:) = ua_b (:,:) + za1 * ua_e (:,:) 842 va_b (:,:) = va_b (:,:) + za1 * va_e (:,:) 843 ELSE ! Sum transports 844 ua_b (:,:) = ua_b (:,:) + za1 * ua_e (:,:) * hu_e (:,:) 845 va_b (:,:) = va_b (:,:) + za1 * va_e (:,:) * hv_e (:,:) 846 ENDIF 847 ! ! Sum sea level 848 ssha(:,:) = ssha(:,:) + za1 * ssha_e(:,:) 650 849 ! ! ==================== ! 651 850 END DO ! end loop ! 652 851 ! ! ==================== ! 653 654 #if defined key_obc655 IF( lp_obc_east ) sshfoe_b(:,:) = zcoef * sshfoe_b(:,:) !!gm totally useless ?????656 IF( lp_obc_west ) sshfow_b(:,:) = zcoef * sshfow_b(:,:)657 IF( lp_obc_north ) sshfon_b(:,:) = zcoef * sshfon_b(:,:)658 IF( lp_obc_south ) sshfos_b(:,:) = zcoef * sshfos_b(:,:)659 #endif660 661 852 ! ----------------------------------------------------------------------------- 662 853 ! Phase 3. update the general trend with the barotropic trend 663 854 ! ----------------------------------------------------------------------------- 664 855 ! 665 ! !* Time average ==> after barotropic u, v, ssh 666 zcoef = 1._wp / ( 2 * nn_baro + 1 ) 667 zu_sum(:,:) = zcoef * zu_sum (:,:) 668 zv_sum(:,:) = zcoef * zv_sum (:,:) 669 ! 670 ! !* update the general momentum trend 671 DO jk=1,jpkm1 672 ua(:,:,jk) = ua(:,:,jk) + ( zu_sum(:,:) - ub_b(:,:) ) * z1_2dt_b 673 va(:,:,jk) = va(:,:,jk) + ( zv_sum(:,:) - vb_b(:,:) ) * z1_2dt_b 856 ! At this stage ssha holds a time averaged value 857 ! ! Sea Surface Height at u-,v- and f-points 858 IF( lk_vvl ) THEN ! (required only in key_vvl case) 859 DO jj = 1, jpjm1 860 DO ji = 1, jpim1 ! NO Vector Opt. 861 zsshu_a(ji,jj) = z1_2 * umask(ji,jj,1) / ( e1u(ji ,jj) * e2u(ji ,jj) ) & 862 & * ( e1t(ji ,jj) * e2t(ji ,jj) * ssha(ji ,jj) & 863 & + e1t(ji+1,jj) * e2t(ji+1,jj) * ssha(ji+1,jj) ) 864 zsshv_a(ji,jj) = z1_2 * vmask(ji,jj,1) / ( e1v(ji,jj ) * e2v(ji,jj ) ) & 865 & * ( e1t(ji,jj ) * e2t(ji,jj ) * ssha(ji,jj ) & 866 & + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha(ji,jj+1) ) 867 END DO 868 END DO 869 CALL lbc_lnk( zsshu_a, 'U', 1._wp ) ; CALL lbc_lnk( zsshv_a, 'V', 1._wp ) ! Boundary conditions 870 ENDIF 871 ! 872 ! Set advection velocity correction: 873 IF (((kt==nit000).AND.(neuler==0)).OR.(.NOT.ln_bt_fw)) THEN 874 un_adv(:,:) = zu_sum(:,:)*hur(:,:) 875 vn_adv(:,:) = zv_sum(:,:)*hvr(:,:) 876 ELSE 877 un_adv(:,:) = z1_2 * ( ub2_b(:,:) + zu_sum(:,:)) * hur(:,:) 878 vn_adv(:,:) = z1_2 * ( vb2_b(:,:) + zv_sum(:,:)) * hvr(:,:) 879 END IF 880 881 IF (ln_bt_fw) THEN ! Save integrated transport for next computation 882 ub2_b(:,:) = zu_sum(:,:) 883 vb2_b(:,:) = zv_sum(:,:) 884 ENDIF 885 ! 886 ! Update barotropic trend: 887 IF (( ln_dynadv_vec ).OR. (.NOT. lk_vvl)) THEN 888 DO jk=1,jpkm1 889 ua(:,:,jk) = ua(:,:,jk) + ( ua_b(:,:) - ub_b(:,:) ) * z1_2dt_b 890 va(:,:,jk) = va(:,:,jk) + ( va_b(:,:) - vb_b(:,:) ) * z1_2dt_b 891 END DO 892 ELSE 893 hu_e (:,:) = umask(:,:,1) / ( zhur_b(:,:) + 1._wp - umask(:,:,1) ) 894 hv_e (:,:) = vmask(:,:,1) / ( zhvr_b(:,:) + 1._wp - vmask(:,:,1) ) 895 DO jk=1,jpkm1 896 ua(:,:,jk) = ua(:,:,jk) + hur(:,:) * ( ua_b(:,:) - ub_b(:,:) * hu_e(:,:) ) * z1_2dt_b 897 va(:,:,jk) = va(:,:,jk) + hvr(:,:) * ( va_b(:,:) - vb_b(:,:) * hv_e(:,:) ) * z1_2dt_b 898 END DO 899 ! Save barotropic velocities not transport: 900 ua_b (:,:) = ua_b(:,:) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - umask(:,:,1) ) 901 va_b (:,:) = va_b(:,:) / ( hv_0(:,:) + zsshv_a(:,:) + 1._wp - vmask(:,:,1) ) 902 ENDIF 903 ! 904 DO jk = 1, jpkm1 905 ! Correct velocities: 906 un(:,:,jk) = ( un(:,:,jk) + un_adv(:,:) - un_b(:,:) )*umask(:,:,jk) 907 vn(:,:,jk) = ( vn(:,:,jk) + vn_adv(:,:) - vn_b(:,:) )*vmask(:,:,jk) 908 ! 674 909 END DO 675 un_b (:,:) = zu_sum(:,:)676 vn_b (:,:) = zv_sum(:,:)677 sshn_b(:,:) = zcoef * zssh_sum(:,:)678 910 ! 679 911 ! !* write time-spliting arrays in the restart 680 IF( lrst_oce ) CALL ts_rst( kt, 'WRITE' ) 681 ! 682 CALL wrk_dealloc( jpi, jpj, zsshun_e, zsshvn_e, zsshb_e, zssh_sum, zhdiv ) 683 CALL wrk_dealloc( jpi, jpj, zua, zva, zun, zvn, zun_e, zvn_e, zub_e, zvb_e ) 684 CALL wrk_dealloc( jpi, jpj, zcu, zcv, zwx, zwy, zbfru, zbfrv, zu_sum, zv_sum ) 912 IF(lrst_oce .AND.ln_bt_fw) CALL ts_rst( kt, 'WRITE' ) 913 ! 914 CALL wrk_dealloc( jpi, jpj, zsshp2_e, zhdiv ) 915 CALL wrk_dealloc( jpi, jpj, zu_trd, zv_trd, zun_e, zvn_e ) 916 CALL wrk_dealloc( jpi, jpj, zwx, zwy, zu_sum, zv_sum, zssh_frc, zu_frc, zv_frc ) 917 CALL wrk_dealloc( jpi, jpj, zhup2_e, zhvp2_e, zhust_e, zhvst_e ) 918 CALL wrk_dealloc( jpi, jpj, zhur_b, zhvr_b ) 919 CALL wrk_dealloc( jpi, jpj, zsshu_a, zsshv_a ) 920 CALL wrk_dealloc( jpi, jpj, zht, zhf ) 685 921 ! 686 922 IF( nn_timing == 1 ) CALL timing_stop('dyn_spg_ts') … … 688 924 END SUBROUTINE dyn_spg_ts 689 925 926 SUBROUTINE ts_wgt( ll_av, ll_fw, jpit, zwgt1, zwgt2) 927 !!--------------------------------------------------------------------- 928 !! *** ROUTINE ts_wgt *** 929 !! 930 !! ** Purpose : Set time-splitting weights for temporal averaging (or not) 931 !!---------------------------------------------------------------------- 932 LOGICAL, INTENT(in) :: ll_av ! temporal averaging=.true. 933 LOGICAL, INTENT(in) :: ll_fw ! forward time splitting =.true. 934 INTEGER, INTENT(inout) :: jpit ! cycle length 935 REAL(wp), DIMENSION(3*nn_baro), INTENT(inout) :: zwgt1, & ! Primary weights 936 zwgt2 ! Secondary weights 937 938 INTEGER :: jic, jn, ji ! temporary integers 939 REAL(wp) :: za1, za2 940 !!---------------------------------------------------------------------- 941 942 zwgt1(:) = 0._wp 943 zwgt2(:) = 0._wp 944 945 ! Set time index when averaged value is requested 946 IF (ll_fw) THEN 947 jic = nn_baro 948 ELSE 949 jic = 2 * nn_baro 950 ENDIF 951 952 ! Set primary weights: 953 IF (ll_av) THEN 954 ! Define simple boxcar window for primary weights 955 ! (width = nn_baro, centered around jic) 956 SELECT CASE ( nn_bt_flt ) 957 CASE( 0 ) ! No averaging 958 zwgt1(jic) = 1._wp 959 jpit = jic 960 961 CASE( 1 ) ! Boxcar, width = nn_baro 962 DO jn = 1, 3*nn_baro 963 za1 = ABS(float(jn-jic))/float(nn_baro) 964 IF (za1 < 0.5_wp) THEN 965 zwgt1(jn) = 1._wp 966 jpit = jn 967 ENDIF 968 ENDDO 969 970 CASE( 2 ) ! Boxcar, width = 2 * nn_baro 971 DO jn = 1, 3*nn_baro 972 za1 = ABS(float(jn-jic))/float(nn_baro) 973 IF (za1 < 1._wp) THEN 974 zwgt1(jn) = 1._wp 975 jpit = jn 976 ENDIF 977 ENDDO 978 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_bt_flt' ) 979 END SELECT 980 981 ELSE ! No time averaging 982 zwgt1(jic) = 1._wp 983 jpit = jic 984 ENDIF 985 986 ! Set secondary weights 987 DO jn = 1, jpit 988 DO ji = jn, jpit 989 zwgt2(jn) = zwgt2(jn) + zwgt1(ji) 990 END DO 991 END DO 992 993 ! Normalize weigths: 994 za1 = 1._wp / SUM(zwgt1(1:jpit)) 995 za2 = 1._wp / SUM(zwgt2(1:jpit)) 996 DO jn = 1, jpit 997 zwgt1(jn) = zwgt1(jn) * za1 998 zwgt2(jn) = zwgt2(jn) * za2 999 END DO 1000 ! 1001 END SUBROUTINE ts_wgt 690 1002 691 1003 SUBROUTINE ts_rst( kt, cdrw ) … … 698 1010 CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag 699 1011 ! 700 INTEGER :: ji, jk ! dummy loop indices701 1012 !!---------------------------------------------------------------------- 702 1013 ! 703 1014 IF( TRIM(cdrw) == 'READ' ) THEN 704 IF( iom_varid( numror, 'un_b', ldstop = .FALSE. ) > 0 ) THEN 705 CALL iom_get( numror, jpdom_autoglo, 'un_b' , un_b (:,:) ) ! external velocity issued 706 CALL iom_get( numror, jpdom_autoglo, 'vn_b' , vn_b (:,:) ) ! from barotropic loop 1015 CALL iom_get( numror, jpdom_autoglo, 'ub2_b' , ub2_b (:,:) ) 1016 CALL iom_get( numror, jpdom_autoglo, 'vb2_b' , vb2_b (:,:) ) 1017 IF( .NOT.ln_bt_av .AND. iom_varid( numror, 'sshbb_e', ldstop = .FALSE. ) > 0) THEN 1018 CALL iom_get( numror, jpdom_autoglo, 'sshbb_e' , sshbb_e(:,:) ) 1019 CALL iom_get( numror, jpdom_autoglo, 'ubb_e' , ubb_e(:,:) ) 1020 CALL iom_get( numror, jpdom_autoglo, 'vbb_e' , vbb_e(:,:) ) 1021 CALL iom_get( numror, jpdom_autoglo, 'sshb_e' , sshb_e(:,:) ) 1022 CALL iom_get( numror, jpdom_autoglo, 'ub_e' , ub_e(:,:) ) 1023 CALL iom_get( numror, jpdom_autoglo, 'vb_e' , vb_e(:,:) ) 707 1024 ELSE 708 un_b (:,:) = 0._wp 709 vn_b (:,:) = 0._wp 710 ! vertical sum 711 IF( lk_vopt_loop ) THEN ! vector opt., forced unroll 712 DO jk = 1, jpkm1 713 DO ji = 1, jpij 714 un_b(ji,1) = un_b(ji,1) + fse3u(ji,1,jk) * un(ji,1,jk) 715 vn_b(ji,1) = vn_b(ji,1) + fse3v(ji,1,jk) * vn(ji,1,jk) 716 END DO 717 END DO 718 ELSE ! No vector opt. 719 DO jk = 1, jpkm1 720 un_b(:,:) = un_b(:,:) + fse3u(:,:,jk) * un(:,:,jk) 721 vn_b(:,:) = vn_b(:,:) + fse3v(:,:,jk) * vn(:,:,jk) 722 END DO 723 ENDIF 724 un_b (:,:) = un_b(:,:) * hur(:,:) 725 vn_b (:,:) = vn_b(:,:) * hvr(:,:) 726 ENDIF 727 728 ! Vertically integrated velocity (before) 729 IF (neuler/=0) THEN 730 ub_b (:,:) = 0._wp 731 vb_b (:,:) = 0._wp 732 733 ! vertical sum 734 IF( lk_vopt_loop ) THEN ! vector opt., forced unroll 735 DO jk = 1, jpkm1 736 DO ji = 1, jpij 737 ub_b(ji,1) = ub_b(ji,1) + fse3u_b(ji,1,jk) * ub(ji,1,jk) 738 vb_b(ji,1) = vb_b(ji,1) + fse3v_b(ji,1,jk) * vb(ji,1,jk) 739 END DO 740 END DO 741 ELSE ! No vector opt. 742 DO jk = 1, jpkm1 743 ub_b(:,:) = ub_b(:,:) + fse3u_b(:,:,jk) * ub(:,:,jk) 744 vb_b(:,:) = vb_b(:,:) + fse3v_b(:,:,jk) * vb(:,:,jk) 745 END DO 746 ENDIF 747 748 IF( lk_vvl ) THEN 749 ub_b (:,:) = ub_b(:,:) * umask(:,:,1) / ( hu_0(:,:) + sshu_b(:,:) + 1._wp - umask(:,:,1) ) 750 vb_b (:,:) = vb_b(:,:) * vmask(:,:,1) / ( hv_0(:,:) + sshv_b(:,:) + 1._wp - vmask(:,:,1) ) 751 ELSE 752 ub_b(:,:) = ub_b(:,:) * hur(:,:) 753 vb_b(:,:) = vb_b(:,:) * hvr(:,:) 754 ENDIF 755 ELSE ! neuler==0 756 ub_b (:,:) = un_b (:,:) 757 vb_b (:,:) = vn_b (:,:) 758 ENDIF 759 760 IF( iom_varid( numror, 'sshn_b', ldstop = .FALSE. ) > 0 ) THEN 761 CALL iom_get( numror, jpdom_autoglo, 'sshn_b' , sshn_b (:,:) ) ! filtered ssh 762 ELSE 763 sshn_b(:,:) = sshb(:,:) ! if not in restart set previous time mean to current baroclinic before value 764 ENDIF 1025 sshbb_e = sshn_b ! ACC GUESS WORK 1026 ubb_e = ub_b 1027 vbb_e = vb_b 1028 sshb_e = sshn_b 1029 ub_e = ub_b 1030 vb_e = vb_b 1031 ENDIF 1032 ! 765 1033 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN 766 CALL iom_rstput( kt, nitrst, numrow, 'un_b' , un_b (:,:) ) ! external velocity and ssh 767 CALL iom_rstput( kt, nitrst, numrow, 'vn_b' , vn_b (:,:) ) ! issued from barotropic loop 768 CALL iom_rstput( kt, nitrst, numrow, 'sshn_b' , sshn_b(:,:) ) ! 1034 CALL iom_rstput( kt, nitrst, numrow, 'ub2_b' , ub2_b (:,:) ) 1035 CALL iom_rstput( kt, nitrst, numrow, 'vb2_b' , vb2_b (:,:) ) 1036 ! 1037 IF (.NOT.ln_bt_av) THEN 1038 CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e' , sshbb_e(:,:) ) 1039 CALL iom_rstput( kt, nitrst, numrow, 'ubb_e' , ubb_e(:,:) ) 1040 CALL iom_rstput( kt, nitrst, numrow, 'vbb_e' , vbb_e(:,:) ) 1041 CALL iom_rstput( kt, nitrst, numrow, 'sshb_e' , sshb_e(:,:) ) 1042 CALL iom_rstput( kt, nitrst, numrow, 'ub_e' , ub_e(:,:) ) 1043 CALL iom_rstput( kt, nitrst, numrow, 'vb_e' , vb_e(:,:) ) 1044 ENDIF 769 1045 ENDIF 770 1046 ! 771 1047 END SUBROUTINE ts_rst 772 1048 1049 SUBROUTINE dyn_spg_ts_init( kt ) 1050 !!--------------------------------------------------------------------- 1051 !! *** ROUTINE dyn_spg_ts_init *** 1052 !! 1053 !! ** Purpose : Set time splitting options 1054 !!---------------------------------------------------------------------- 1055 INTEGER , INTENT(in) :: kt ! ocean time-step 1056 ! 1057 INTEGER :: ji ,jj, jk 1058 REAL(wp) :: zxr2, zyr2, zcmax 1059 REAL(wp), POINTER, DIMENSION(:,:) :: zcu, zht 1060 !! 1061 ! NAMELIST/namsplit/ ln_bt_fw, ln_bt_av, ln_bt_nn_auto, & 1062 ! & nn_baro, rn_bt_cmax, nn_bt_flt 1063 !!---------------------------------------------------------------------- 1064 ! REWIND( numnam ) !* Namelist namsplit: split-explicit free surface 1065 ! READ ( numnam, namsplit ) 1066 ! ! Max courant number for ext. grav. waves 1067 ! 1068 CALL wrk_alloc( jpi, jpj, zcu, zht ) 1069 ! 1070 ! JC: Simplification needed below: define ht_0 even when volume is fixed 1071 IF (lk_vvl) THEN 1072 zht(:,:) = ht_0(:,:) * tmask(:,:,1) 1073 ELSE 1074 zht(:,:) = 0. 1075 DO jk = 1, jpkm1 1076 zht(:,:) = zht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 1077 END DO 1078 ENDIF 1079 1080 DO jj = 1, jpj 1081 DO ji =1, jpi 1082 zxr2 = 1./(e1t(ji,jj)*e1t(ji,jj)) 1083 zyr2 = 1./(e2t(ji,jj)*e2t(ji,jj)) 1084 zcu(ji,jj) = sqrt(grav*zht(ji,jj)*(zxr2 + zyr2) ) 1085 END DO 1086 END DO 1087 1088 zcmax = MAXVAL(zcu(:,:)) 1089 IF( lk_mpp ) CALL mpp_max( zcmax ) 1090 1091 ! Estimate number of iterations to satisfy a max courant number=0.8 1092 IF (ln_bt_nn_auto) nn_baro = CEILING( rdt / rn_bt_cmax * zcmax) 1093 1094 rdtbt = rdt / FLOAT(nn_baro) 1095 zcmax = zcmax * rdtbt 1096 ! Print results 1097 IF(lwp) WRITE(numout,*) 1098 IF(lwp) WRITE(numout,*) 'dyn_spg_ts : split-explicit free surface' 1099 IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 1100 IF( ln_bt_nn_auto ) THEN 1101 IF(lwp) WRITE(numout,*) ' ln_ts_nn_auto=.true. Automatically set nn_baro ' 1102 IF(lwp) WRITE(numout,*) ' Max. courant number allowed: ', rn_bt_cmax 1103 ELSE 1104 IF(lwp) WRITE(numout,*) ' ln_ts_nn_auto=.false.: Use nn_baro in namelist ' 1105 ENDIF 1106 IF(lwp) WRITE(numout,*) ' nn_baro = ', nn_baro 1107 IF(lwp) WRITE(numout,*) ' Barotropic time step [s] is :', rdtbt 1108 IF(lwp) WRITE(numout,*) ' Maximum Courant number is :', zcmax 1109 1110 IF(ln_bt_av) THEN 1111 IF(lwp) WRITE(numout,*) ' ln_bt_av=.true. => Time averaging over nn_baro time steps is on ' 1112 ELSE 1113 IF(lwp) WRITE(numout,*) ' ln_bt_av=.false. => No time averaging of barotropic variables ' 1114 ENDIF 1115 ! 1116 ! 1117 IF(ln_bt_fw) THEN 1118 IF(lwp) WRITE(numout,*) ' ln_bt_fw=.true. => Forward integration of barotropic variables ' 1119 ELSE 1120 IF(lwp) WRITE(numout,*) ' ln_bt_fw =.false.=> Centered integration of barotropic variables ' 1121 ENDIF 1122 ! 1123 IF(lwp) WRITE(numout,*) ' Time filter choice, nn_bt_flt: ', nn_bt_flt 1124 SELECT CASE ( nn_bt_flt ) 1125 CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' Dirac' 1126 CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' Boxcar: width = nn_baro' 1127 CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' Boxcar: width = 2*nn_baro' 1128 CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for nn_bt_flt: should 0,1,2' ) 1129 END SELECT 1130 ! 1131 IF ((.NOT.ln_bt_av).AND.(.NOT.ln_bt_fw)) THEN 1132 CALL ctl_stop( 'dynspg_ts ERROR: No time averaging => only forward integration is possible' ) 1133 ENDIF 1134 IF ( zcmax>0.9_wp ) THEN 1135 CALL ctl_stop( 'dynspg_ts ERROR: Maximum Courant number is greater than 0.9: Inc. nn_baro !' ) 1136 ENDIF 1137 ! 1138 CALL wrk_dealloc( jpi, jpj, zcu, zht ) 1139 ! 1140 END SUBROUTINE dyn_spg_ts_init 1141 773 1142 #else 774 !!---------------------------------------------------------------------- 775 !! Default case : Empty module No standart free surface cst volume 776 !!---------------------------------------------------------------------- 1143 !!--------------------------------------------------------------------------- 1144 !! Default case : Empty module No standard free surface constant volume 1145 !!--------------------------------------------------------------------------- 1146 1147 USE par_kind 1148 LOGICAL, PUBLIC, PARAMETER :: ln_bt_fw=.FALSE. ! Forward integration of barotropic sub-stepping 777 1149 CONTAINS 778 1150 INTEGER FUNCTION dyn_spg_ts_alloc() ! Dummy function … … 787 1159 CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag 788 1160 WRITE(*,*) 'ts_rst : You should not have seen this print! error?', kt, cdrw 789 END SUBROUTINE ts_rst 1161 END SUBROUTINE ts_rst 1162 SUBROUTINE dyn_spg_ts_init( kt ) ! Empty routine 1163 INTEGER , INTENT(in) :: kt ! ocean time-step 1164 WRITE(*,*) 'dyn_spg_ts_init : You should not have seen this print! error?', kt 1165 END SUBROUTINE dyn_spg_ts_init 790 1166 #endif 791 1167 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90
r4147 r4292 572 572 INTEGER :: ierr ! local integer 573 573 REAL(wp) :: zfac12, zua, zva ! local scalars 574 REAL(wp) :: zmsk, ze3 ! local scalars 574 575 ! ! 3D workspace 575 576 REAL(wp), POINTER , DIMENSION(:,: ) :: zwx, zwy, zwz … … 577 578 #if defined key_vvl 578 579 REAL(wp), POINTER , DIMENSION(:,:,:) :: ze3f ! 3D workspace (lk_vvl=T) 579 #endif 580 #if ! defined key_vvl 580 #else 581 581 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), SAVE :: ze3f ! lk_vvl=F, ze3f=1/e3f saved one for all 582 582 #endif … … 604 604 ENDIF 605 605 606 IF( kt == nit000 .OR. lk_vvl ) THEN ! reciprocal of e3 at F-point (masked averaging of e3t )606 IF( kt == nit000 .OR. lk_vvl ) THEN ! reciprocal of e3 at F-point (masked averaging of e3t over ocean points) 607 607 DO jk = 1, jpk 608 608 DO jj = 1, jpjm1 609 609 DO ji = 1, jpim1 610 ze3f(ji,jj,jk) = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & 611 & + fse3t(ji,jj ,jk)*tmask(ji,jj ,jk) + fse3t(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) * 0.25 612 IF( ze3f(ji,jj,jk) /= 0._wp ) ze3f(ji,jj,jk) = 1._wp / ze3f(ji,jj,jk) 610 ze3 = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & 611 & + fse3t(ji,jj ,jk)*tmask(ji,jj ,jk) + fse3t(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) 612 zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & 613 & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) 614 IF( ze3 /= 0._wp ) ze3f(ji,jj,jk) = zmsk / ze3 613 615 END DO 614 616 END DO -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90
r3625 r4292 16 16 USE oce ! ocean dynamics and tracers 17 17 USE dom_oce ! ocean space and time domain 18 USE domvvl ! variable volume 18 19 USE sbc_oce ! surface boundary condition: ocean 19 20 USE zdf_oce ! ocean vertical physics … … 24 25 USE wrk_nemo ! Memory Allocation 25 26 USE timing ! Timing 27 USE dynadv ! dynamics: vector invariant versus flux form 28 USE dynspg_oce, ONLY: lk_dynspg_ts, ua_b, va_b 29 USE dynspg_ts 26 30 27 31 IMPLICIT NONE … … 29 33 30 34 PUBLIC dyn_zdf_imp ! called by step.F90 35 36 REAL(wp) :: r_vvl ! variable volume indicator, =1 if lk_vvl=T, =0 otherwise 31 37 32 38 !! * Substitutions … … 64 70 INTEGER :: ikbu, ikbv ! local integers 65 71 REAL(wp) :: z1_p2dt, zcoef, zzwi, zzws, zrhs ! local scalars 72 REAL(wp) :: ze3ua, ze3va 66 73 !!---------------------------------------------------------------------- 67 74 68 75 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwd, zws 69 REAL(wp), POINTER, DIMENSION(:,:) :: zavmu, zavmv70 76 !!---------------------------------------------------------------------- 71 77 ! … … 73 79 ! 74 80 CALL wrk_alloc( jpi,jpj,jpk, zwi, zwd, zws ) 75 CALL wrk_alloc( jpi,jpj, zavmu, zavmv )76 81 ! 77 82 IF( kt == nit000 ) THEN … … 79 84 IF(lwp) WRITE(numout,*) 'dyn_zdf_imp : vertical momentum diffusion implicit operator' 80 85 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' 86 ! 87 IF( lk_vvl ) THEN ; r_vvl = 1._wp ! Variable volume indicator 88 ELSE ; r_vvl = 0._wp 89 ENDIF 81 90 ENDIF 82 91 … … 94 103 IF( ln_bfrimp ) THEN 95 104 # if defined key_vectopt_loop 96 DO jj = 1, 197 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling)105 DO jj = 1, 1 106 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling) 98 107 # else 99 DO jj = 2, jpjm1100 DO ji = 2, jpim1108 DO jj = 2, jpjm1 109 DO ji = 2, jpim1 101 110 # endif 102 ikbu = mbku(ji,jj) ! ocean bottom level at u- and v-points 103 ikbv = mbkv(ji,jj) ! (deepest ocean u- and v-points) 104 zavmu(ji,jj) = avmu(ji,jj,ikbu+1) 105 zavmv(ji,jj) = avmv(ji,jj,ikbv+1) 106 avmu(ji,jj,ikbu+1) = -bfrua(ji,jj) * fse3uw(ji,jj,ikbu+1) 107 avmv(ji,jj,ikbv+1) = -bfrva(ji,jj) * fse3vw(ji,jj,ikbv+1) 108 END DO 109 END DO 110 ENDIF 111 ikbu = mbku(ji,jj) ! ocean bottom level at u- and v-points 112 ikbv = mbkv(ji,jj) ! (deepest ocean u- and v-points) 113 avmu(ji,jj,ikbu+1) = -bfrua(ji,jj) * fse3uw(ji,jj,ikbu+1) 114 avmv(ji,jj,ikbv+1) = -bfrva(ji,jj) * fse3vw(ji,jj,ikbv+1) 115 END DO 116 END DO 117 ENDIF 118 119 #if defined key_dynspg_ts 120 IF( ln_dynadv_vec .OR. .NOT. lk_vvl ) THEN ! applied on velocity 121 DO jk = 1, jpkm1 122 ua(:,:,jk) = ( ub(:,:,jk) + p2dt * ua(:,:,jk) ) * umask(:,:,jk) 123 va(:,:,jk) = ( vb(:,:,jk) + p2dt * va(:,:,jk) ) * vmask(:,:,jk) 124 END DO 125 ELSE ! applied on thickness weighted velocity 126 DO jk = 1, jpkm1 127 ua(:,:,jk) = ( ub(:,:,jk) * fse3u_b(:,:,jk) & 128 & + p2dt * ua(:,:,jk) * fse3u_n(:,:,jk) ) & 129 & / fse3u_a(:,:,jk) * umask(:,:,jk) 130 va(:,:,jk) = ( vb(:,:,jk) * fse3v_b(:,:,jk) & 131 & + p2dt * va(:,:,jk) * fse3v_n(:,:,jk) ) & 132 & / fse3v_a(:,:,jk) * vmask(:,:,jk) 133 END DO 134 ENDIF 135 136 IF ( ln_bfrimp .AND.lk_dynspg_ts ) THEN 137 ! remove barotropic velocities: 138 DO jk = 1, jpkm1 139 ua(:,:,jk) = (ua(:,:,jk) - ua_b(:,:)) * umask(:,:,jk) 140 va(:,:,jk) = (va(:,:,jk) - va_b(:,:)) * vmask(:,:,jk) 141 ENDDO 142 ! Add bottom stress due to barotropic component only: 143 DO jj = 2, jpjm1 144 DO ji = fs_2, fs_jpim1 ! vector opt. 145 ikbu = mbku(ji,jj) ! ocean bottom level at u- and v-points 146 ikbv = mbkv(ji,jj) ! (deepest ocean u- and v-points) 147 ze3ua = ( 1._wp - r_vvl ) * fse3u_n(ji,jj,ikbu) + r_vvl * fse3u_a(ji,jj,ikbu) 148 ze3va = ( 1._wp - r_vvl ) * fse3v_n(ji,jj,ikbv) + r_vvl * fse3v_a(ji,jj,ikbv) 149 ua(ji,jj,ikbu) = ua(ji,jj,ikbu) + p2dt * bfrua(ji,jj) * ua_b(ji,jj) / ze3ua 150 va(ji,jj,ikbv) = va(ji,jj,ikbv) + p2dt * bfrva(ji,jj) * va_b(ji,jj) / ze3va 151 END DO 152 END DO 153 ENDIF 154 #endif 111 155 112 156 ! 2. Vertical diffusion on u … … 119 163 DO jj = 2, jpjm1 120 164 DO ji = fs_2, fs_jpim1 ! vector opt. 121 zcoef = - p2dt / fse3u(ji,jj,jk) 165 ze3ua = ( 1._wp - r_vvl ) * fse3u_n(ji,jj,jk) + r_vvl * fse3u_a(ji,jj,jk) ! after scale factor at T-point 166 zcoef = - p2dt / ze3ua 122 167 zzwi = zcoef * avmu (ji,jj,jk ) / fse3uw(ji,jj,jk ) 123 168 zwi(ji,jj,jk) = zzwi * umask(ji,jj,jk) … … 128 173 END DO 129 174 END DO 130 DO jj = 2, jpjm1 ! Surface bou dary conditions175 DO jj = 2, jpjm1 ! Surface boundary conditions 131 176 DO ji = fs_2, fs_jpim1 ! vector opt. 132 177 zwi(ji,jj,1) = 0._wp … … 160 205 DO jj = 2, jpjm1 !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 == 161 206 DO ji = fs_2, fs_jpim1 ! vector opt. 162 ua(ji,jj,1) = ub(ji,jj,1) + p2dt * ( ua(ji,jj,1) + 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 163 & * r1_rau0 / fse3u(ji,jj,1) ) 207 ze3ua = ( 1._wp - r_vvl ) * fse3u_n(ji,jj,1) + r_vvl * fse3u_a(ji,jj,1) 208 #if defined key_dynspg_ts 209 ua(ji,jj,1) = ua(ji,jj,1) + p2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 210 & / ( ze3ua * rau0 ) 211 #else 212 ua(ji,jj,1) = ub(ji,jj,1) + p2dt *(ua(ji,jj,1) + 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & 213 & / ( fse3u(ji,jj,1) * rau0 ) ) 214 #endif 164 215 END DO 165 216 END DO … … 167 218 DO jj = 2, jpjm1 168 219 DO ji = fs_2, fs_jpim1 ! vector opt. 169 zrhs = ub(ji,jj,jk) + p2dt * ua(ji,jj,jk) ! zrhs=right hand side 220 #if defined key_dynspg_ts 221 zrhs = ua(ji,jj,jk) ! zrhs=right hand side 222 #else 223 zrhs = ub(ji,jj,jk) + p2dt * ua(ji,jj,jk) 224 #endif 170 225 ua(ji,jj,jk) = zrhs - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * ua(ji,jj,jk-1) 171 226 END DO … … 186 241 END DO 187 242 243 #if ! defined key_dynspg_ts 188 244 ! Normalization to obtain the general momentum trend ua 189 245 DO jk = 1, jpkm1 … … 194 250 END DO 195 251 END DO 196 252 #endif 197 253 198 254 ! 3. Vertical diffusion on v … … 205 261 DO jj = 2, jpjm1 206 262 DO ji = fs_2, fs_jpim1 ! vector opt. 207 zcoef = -p2dt / fse3v(ji,jj,jk) 263 ze3va = ( 1._wp - r_vvl ) * fse3v_n(ji,jj,jk) + r_vvl * fse3v_a(ji,jj,jk) ! after scale factor at T-point 264 zcoef = - p2dt / ze3va 208 265 zzwi = zcoef * avmv (ji,jj,jk ) / fse3vw(ji,jj,jk ) 209 266 zwi(ji,jj,jk) = zzwi * vmask(ji,jj,jk) … … 214 271 END DO 215 272 END DO 216 DO jj = 2, jpjm1 ! Surface bou dary conditions273 DO jj = 2, jpjm1 ! Surface boundary conditions 217 274 DO ji = fs_2, fs_jpim1 ! vector opt. 218 275 zwi(ji,jj,1) = 0._wp … … 246 303 DO jj = 2, jpjm1 !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 == 247 304 DO ji = fs_2, fs_jpim1 ! vector opt. 248 va(ji,jj,1) = vb(ji,jj,1) + p2dt * ( va(ji,jj,1) + 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 249 & * r1_rau0 / fse3v(ji,jj,1) ) 305 ze3va = ( 1._wp - r_vvl ) * fse3v_n(ji,jj,1) + r_vvl * fse3v_a(ji,jj,1) 306 #if defined key_dynspg_ts 307 va(ji,jj,1) = va(ji,jj,1) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 308 & / ( ze3va * rau0 ) 309 #else 310 va(ji,jj,1) = vb(ji,jj,1) + p2dt *(va(ji,jj,1) + 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 311 & / ( fse3v(ji,jj,1) * rau0 ) ) 312 #endif 250 313 END DO 251 314 END DO … … 253 316 DO jj = 2, jpjm1 254 317 DO ji = fs_2, fs_jpim1 ! vector opt. 255 zrhs = vb(ji,jj,jk) + p2dt * va(ji,jj,jk) ! zrhs=right hand side 318 #if defined key_dynspg_ts 319 zrhs = va(ji,jj,jk) ! zrhs=right hand side 320 #else 321 zrhs = vb(ji,jj,jk) + p2dt * va(ji,jj,jk) 322 #endif 256 323 va(ji,jj,jk) = zrhs - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * va(ji,jj,jk-1) 257 324 END DO … … 259 326 END DO 260 327 ! 261 DO jj = 2, jpjm1 !== th rid recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk ==328 DO jj = 2, jpjm1 !== third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk == 262 329 DO ji = fs_2, fs_jpim1 ! vector opt. 263 330 va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) … … 273 340 274 341 ! Normalization to obtain the general momentum trend va 342 #if ! defined key_dynspg_ts 275 343 DO jk = 1, jpkm1 276 344 DO jj = 2, jpjm1 … … 280 348 END DO 281 349 END DO 282 350 #endif 351 352 ! J. Chanut: Lines below are useless ? 283 353 !! restore bottom layer avmu(v) 284 354 IF( ln_bfrimp ) THEN … … 292 362 ikbu = mbku(ji,jj) ! ocean bottom level at u- and v-points 293 363 ikbv = mbkv(ji,jj) ! (deepest ocean u- and v-points) 294 avmu(ji,jj,ikbu+1) = zavmu(ji,jj)295 avmv(ji,jj,ikbv+1) = zavmv(ji,jj)364 avmu(ji,jj,ikbu+1) = 0.e0 365 avmv(ji,jj,ikbv+1) = 0.e0 296 366 END DO 297 367 END DO … … 299 369 ! 300 370 CALL wrk_dealloc( jpi,jpj,jpk, zwi, zwd, zws) 301 CALL wrk_dealloc( jpi,jpj, zavmu, zavmv)302 371 ! 303 372 IF( nn_timing == 1 ) CALL timing_stop('dyn_zdf_imp') -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90
r3764 r4292 8 8 !! - ! 2010-05 (K. Mogensen, A. Weaver, M. Martin, D. Lea) Assimilation interface 9 9 !! - ! 2010-09 (D.Storkey and E.O'Dea) bug fixes for BDY module 10 !!---------------------------------------------------------------------- 11 12 !!---------------------------------------------------------------------- 13 !! ssh_wzv : after ssh & now vertical velocity 14 !! ssh_nxt : filter ans swap the ssh arrays 10 !! 3.3 ! 2011-10 (M. Leclair) split former ssh_wzv routine and remove all vvl related work 11 !!---------------------------------------------------------------------- 12 13 !!---------------------------------------------------------------------- 14 !! ssh_nxt : after ssh 15 !! ssh_swp : filter ans swap the ssh arrays 16 !! wzv : compute now vertical velocity 15 17 !!---------------------------------------------------------------------- 16 18 USE oce ! ocean dynamics and tracers variables … … 20 22 USE divcur ! hor. divergence and curl (div & cur routines) 21 23 USE iom ! I/O library 24 USE restart ! only for lrst_oce 22 25 USE in_out_manager ! I/O manager 23 26 USE prtctl ! Print control … … 28 31 USE obc_oce 29 32 USE bdy_oce 33 USE bdy_par 34 USE bdydyn2d ! bdy_ssh routine 30 35 USE diaar5, ONLY: lk_diaar5 31 36 USE iom 32 USE sbcrnf, ONLY: h_rnf, nk_rnf ! River runoff 37 USE sbcrnf, ONLY: h_rnf, nk_rnf, sbc_rnf_div ! River runoff 38 USE dynspg_ts, ONLY: ln_bt_fw 39 USE dynspg_oce, ONLY: lk_dynspg_ts 33 40 #if defined key_agrif 34 41 USE agrif_opa_update … … 44 51 PRIVATE 45 52 46 PUBLIC ssh_wzv ! called by step.F9047 53 PUBLIC ssh_nxt ! called by step.F90 54 PUBLIC wzv ! called by step.F90 55 PUBLIC ssh_swp ! called by step.F90 48 56 49 57 !! * Substitutions … … 57 65 CONTAINS 58 66 59 SUBROUTINE ssh_ wzv( kt )60 !!---------------------------------------------------------------------- 61 !! *** ROUTINE ssh_ wzv***67 SUBROUTINE ssh_nxt( kt ) 68 !!---------------------------------------------------------------------- 69 !! *** ROUTINE ssh_nxt *** 62 70 !! 63 !! ** Purpose : compute the after ssh (ssha), the now vertical velocity 64 !! and update the now vertical coordinate (lk_vvl=T). 65 !! 66 !! ** Method : - Using the incompressibility hypothesis, the vertical 67 !! velocity is computed by integrating the horizontal divergence 68 !! from the bottom to the surface minus the scale factor evolution. 69 !! The boundary conditions are w=0 at the bottom (no flux) and. 71 !! ** Purpose : compute the after ssh (ssha) 72 !! 73 !! ** Method : - Using the incompressibility hypothesis, the ssh increment 74 !! is computed by integrating the horizontal divergence and multiply by 75 !! by the time step. 70 76 !! 71 77 !! ** action : ssha : after sea surface height 72 !! wn : now vertical velocity73 !! sshu_a, sshv_a, sshf_a : after sea surface height (lk_vvl=T)74 !! hu, hv, hur, hvr : ocean depth and its inverse at u-,v-points75 78 !! 76 79 !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. 77 80 !!---------------------------------------------------------------------- 78 INTEGER, INTENT(in) :: kt ! time step79 !80 INTEGER :: ji, jj, jk ! dummy loop indices81 REAL(wp) :: zcoefu, zcoefv, zcoeff, z2dt, z1_2dt, z1_rau0 ! local scalars82 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d, zhdiv83 REAL(wp) , POINTER, DIMENSION(:,:,:) :: z3d84 !!---------------------------------------------------------------------- 85 ! 86 IF( nn_timing == 1 ) CALL timing_start('ssh_ wzv')87 ! 88 CALL wrk_alloc( jpi, jpj, z 2d, zhdiv )81 ! 82 REAL(wp), POINTER, DIMENSION(:,: ) :: zhdiv 83 INTEGER, INTENT(in) :: kt ! time step 84 ! 85 INTEGER :: jk ! dummy loop indice 86 REAL(wp) :: z2dt, z1_rau0 ! local scalars 87 !!---------------------------------------------------------------------- 88 ! 89 IF( nn_timing == 1 ) CALL timing_start('ssh_nxt') 90 ! 91 CALL wrk_alloc( jpi, jpj, zhdiv ) 89 92 ! 90 93 IF( kt == nit000 ) THEN 91 94 ! 92 95 IF(lwp) WRITE(numout,*) 93 IF(lwp) WRITE(numout,*) 'ssh_ wzv : after sea surface height and now vertical velocity'96 IF(lwp) WRITE(numout,*) 'ssh_nxt : after sea surface height' 94 97 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 95 98 ! 96 wn(:,:,jpk) = 0._wp ! bottom boundary condition: w=0 (set once for all)97 !98 IF( lk_vvl ) THEN ! before and now Sea SSH at u-, v-, f-points (vvl case only)99 DO jj = 1, jpjm1100 DO ji = 1, jpim1 ! caution: use of Vector Opt. not possible101 zcoefu = 0.5 * umask(ji,jj,1) / ( e1u(ji,jj) * e2u(ji,jj) )102 zcoefv = 0.5 * vmask(ji,jj,1) / ( e1v(ji,jj) * e2v(ji,jj) )103 zcoeff = 0.25 * umask(ji,jj,1) * umask(ji,jj+1,1)104 sshu_b(ji,jj) = zcoefu * ( e1t(ji ,jj) * e2t(ji ,jj) * sshb(ji ,jj) &105 & + e1t(ji+1,jj) * e2t(ji+1,jj) * sshb(ji+1,jj) )106 sshv_b(ji,jj) = zcoefv * ( e1t(ji,jj ) * e2t(ji,jj ) * sshb(ji,jj ) &107 & + e1t(ji,jj+1) * e2t(ji,jj+1) * sshb(ji,jj+1) )108 sshu_n(ji,jj) = zcoefu * ( e1t(ji ,jj) * e2t(ji ,jj) * sshn(ji ,jj) &109 & + e1t(ji+1,jj) * e2t(ji+1,jj) * sshn(ji+1,jj) )110 sshv_n(ji,jj) = zcoefv * ( e1t(ji,jj ) * e2t(ji,jj ) * sshn(ji,jj ) &111 & + e1t(ji,jj+1) * e2t(ji,jj+1) * sshn(ji,jj+1) )112 END DO113 END DO114 CALL lbc_lnk( sshu_b, 'U', 1. ) ; CALL lbc_lnk( sshu_n, 'U', 1. )115 CALL lbc_lnk( sshv_b, 'V', 1. ) ; CALL lbc_lnk( sshv_n, 'V', 1. )116 DO jj = 1, jpjm1117 DO ji = 1, jpim1 ! NO Vector Opt.118 sshf_n(ji,jj) = 0.5 * umask(ji,jj,1) * umask(ji,jj+1,1) &119 & / ( e1f(ji,jj ) * e2f(ji,jj ) ) &120 & * ( e1u(ji,jj ) * e2u(ji,jj ) * sshu_n(ji,jj ) &121 & + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) )122 END DO123 END DO124 CALL lbc_lnk( sshf_n, 'F', 1. )125 ENDIF126 !127 ENDIF128 129 ! !------------------------------------------!130 IF( lk_vvl ) THEN ! Regridding: Update Now Vertical coord. ! (only in vvl case)131 ! !------------------------------------------!132 DO jk = 1, jpkm1133 fsdept(:,:,jk) = fsdept_n(:,:,jk) ! now local depths stored in fsdep. arrays134 fsdepw(:,:,jk) = fsdepw_n(:,:,jk)135 fsde3w(:,:,jk) = fsde3w_n(:,:,jk)136 !137 fse3t (:,:,jk) = fse3t_n (:,:,jk) ! vertical scale factors stored in fse3. arrays138 fse3u (:,:,jk) = fse3u_n (:,:,jk)139 fse3v (:,:,jk) = fse3v_n (:,:,jk)140 fse3f (:,:,jk) = fse3f_n (:,:,jk)141 fse3w (:,:,jk) = fse3w_n (:,:,jk)142 fse3uw(:,:,jk) = fse3uw_n(:,:,jk)143 fse3vw(:,:,jk) = fse3vw_n(:,:,jk)144 END DO145 !146 hu(:,:) = hu_0(:,:) + sshu_n(:,:) ! now ocean depth (at u- and v-points)147 hv(:,:) = hv_0(:,:) + sshv_n(:,:)148 ! ! now masked inverse of the ocean depth (at u- and v-points)149 hur(:,:) = umask(:,:,1) / ( hu(:,:) + 1._wp - umask(:,:,1) )150 hvr(:,:) = vmask(:,:,1) / ( hv(:,:) + 1._wp - vmask(:,:,1) )151 !152 99 ENDIF 153 100 ! … … 162 109 zhdiv(:,:) = 0._wp 163 110 DO jk = 1, jpkm1 ! Horizontal divergence of barotropic transports 164 zhdiv(:,:) = zhdiv(:,:) + fse3t (:,:,jk) * hdivn(:,:,jk)111 zhdiv(:,:) = zhdiv(:,:) + fse3t_n(:,:,jk) * hdivn(:,:,jk) 165 112 END DO 166 113 ! ! Sea surface elevation time stepping 167 114 ! In forward Euler time stepping case, the same formulation as in the leap-frog case can be used 168 115 ! because emp_b field is initialized with the vlaues of emp field. Hence, 0.5 * ( emp + emp_b ) = emp 169 z1_rau0 = 0.5 /rau0116 z1_rau0 = 0.5_wp * r1_rau0 170 117 ssha(:,:) = ( sshb(:,:) - z2dt * ( z1_rau0 * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) ) ) * tmask(:,:,1) 171 118 … … 180 127 #endif 181 128 #if defined key_bdy 182 ssha(:,:) = ssha(:,:) * bdytmask(:,:) 183 CALL lbc_lnk( ssha, 'T', 1. ) ! absolutly compulsory !! (jmm) 184 #endif 129 ! bg jchanut tschanges 130 ! These lines are not necessary with time splitting since 131 ! boundary condition on sea level is set during ts loop 132 IF (lk_bdy) THEN 133 CALL lbc_lnk( ssha, 'T', 1. ) ! Not sure that's necessary 134 CALL bdy_ssh( ssha ) ! Duplicate sea level across open boundaries 135 ENDIF 136 #endif 137 ! end jchanut tschanges 185 138 #if defined key_asminc 186 139 ! ! Include the IAU weighted SSH increment … … 190 143 ENDIF 191 144 #endif 192 ! ! Sea Surface Height at u-,v- and f-points (vvl case only) 193 IF( lk_vvl ) THEN ! (required only in key_vvl case) 194 DO jj = 1, jpjm1 195 DO ji = 1, jpim1 ! NO Vector Opt. 196 sshu_a(ji,jj) = 0.5 * umask(ji,jj,1) / ( e1u(ji ,jj) * e2u(ji ,jj) ) & 197 & * ( e1t(ji ,jj) * e2t(ji ,jj) * ssha(ji ,jj) & 198 & + e1t(ji+1,jj) * e2t(ji+1,jj) * ssha(ji+1,jj) ) 199 sshv_a(ji,jj) = 0.5 * vmask(ji,jj,1) / ( e1v(ji,jj ) * e2v(ji,jj ) ) & 200 & * ( e1t(ji,jj ) * e2t(ji,jj ) * ssha(ji,jj ) & 201 & + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha(ji,jj+1) ) 145 146 ! !------------------------------! 147 ! ! outputs ! 148 ! !------------------------------! 149 CALL iom_put( "ssh" , sshn ) ! sea surface height 150 CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) ) ! square of sea surface height 151 ! 152 IF(ln_ctl) CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha - : ', mask1=tmask, ovlap=1 ) 153 ! 154 CALL wrk_dealloc( jpi, jpj, zhdiv ) 155 ! 156 IF( nn_timing == 1 ) CALL timing_stop('ssh_nxt') 157 ! 158 END SUBROUTINE ssh_nxt 159 160 161 SUBROUTINE wzv( kt ) 162 !!---------------------------------------------------------------------- 163 !! *** ROUTINE wzv *** 164 !! 165 !! ** Purpose : compute the now vertical velocity 166 !! 167 !! ** Method : - Using the incompressibility hypothesis, the vertical 168 !! velocity is computed by integrating the horizontal divergence 169 !! from the bottom to the surface minus the scale factor evolution. 170 !! The boundary conditions are w=0 at the bottom (no flux) and. 171 !! 172 !! ** action : wn : now vertical velocity 173 !! 174 !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. 175 !!---------------------------------------------------------------------- 176 ! 177 INTEGER, INTENT(in) :: kt ! time step 178 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d 179 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d, zhdiv 180 ! 181 INTEGER :: ji, jj, jk ! dummy loop indices 182 REAL(wp) :: z1_2dt ! local scalars 183 !!---------------------------------------------------------------------- 184 185 IF( nn_timing == 1 ) CALL timing_start('wzv') 186 ! 187 IF( kt == nit000 ) THEN 188 ! 189 IF(lwp) WRITE(numout,*) 190 IF(lwp) WRITE(numout,*) 'wzv : now vertical velocity ' 191 IF(lwp) WRITE(numout,*) '~~~~~ ' 192 ! 193 wn(:,:,jpk) = 0._wp ! bottom boundary condition: w=0 (set once for all) 194 ! 195 ENDIF 196 ! !------------------------------! 197 ! ! Now Vertical Velocity ! 198 ! !------------------------------! 199 z1_2dt = 1. / ( 2. * rdt ) ! set time step size (Euler/Leapfrog) 200 IF( neuler == 0 .AND. kt == nit000 ) z1_2dt = 1. / rdt 201 ! 202 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases 203 CALL wrk_alloc( jpi, jpj, jpk, zhdiv ) 204 ! 205 DO jk = 1, jpkm1 206 ! horizontal divergence of thickness diffusion transport ( velocity multiplied by e3t) 207 ! - ML - note: computation allready done in dom_vvl_sf_nxt. Could be optimized (not critical and clearer this way) 208 DO jj = 2, jpjm1 209 DO ji = fs_2, fs_jpim1 ! vector opt. 210 zhdiv(ji,jj,jk) = r1_e12t(ji,jj) * ( un_td(ji,jj,jk) - un_td(ji-1,jj,jk) + vn_td(ji,jj,jk) - vn_td(ji,jj-1,jk) ) 211 END DO 202 212 END DO 203 213 END DO 204 CALL lbc_lnk( sshu_a, 'U', 1. ) ; CALL lbc_lnk( sshv_a, 'V', 1. ) ! Boundaries conditions 205 ENDIF 206 207 ! !------------------------------! 208 ! ! Now Vertical Velocity ! 209 ! !------------------------------! 210 z1_2dt = 1.e0 / z2dt 211 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence 212 ! - ML - need 3 lines here because replacement of fse3t by its expression yields too long lines otherwise 213 wn(:,:,jk) = wn(:,:,jk+1) - fse3t_n(:,:,jk) * hdivn(:,:,jk) & 214 & - ( fse3t_a(:,:,jk) - fse3t_b(:,:,jk) ) & 215 & * tmask(:,:,jk) * z1_2dt 214 CALL lbc_lnk(zhdiv, 'T', 1.) ! - ML - Perhaps not necessary: not used for horizontal "connexions" 215 ! ! Is it problematic to have a wrong vertical velocity in boundary cells? 216 ! ! Same question holds for hdivn. Perhaps just for security 217 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence 218 ! computation of w 219 wn(:,:,jk) = wn(:,:,jk+1) - ( fse3t_n(:,:,jk) * hdivn(:,:,jk) + zhdiv(:,:,jk) & 220 & + z1_2dt * ( fse3t_a(:,:,jk) - fse3t_b(:,:,jk) ) ) * tmask(:,:,jk) 221 END DO 222 ! IF( ln_vvl_layer ) wn(:,:,:) = 0.e0 223 CALL wrk_dealloc( jpi, jpj, jpk, zhdiv ) 224 ELSE ! z_star and linear free surface cases 225 DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence 226 ! computation of w 227 wn(:,:,jk) = wn(:,:,jk+1) - ( fse3t_n(:,:,jk) * hdivn(:,:,jk) & 228 & + z1_2dt * ( fse3t_a(:,:,jk) - fse3t_b(:,:,jk) ) ) * tmask(:,:,jk) 229 END DO 230 ENDIF 231 216 232 #if defined key_bdy 217 233 wn(:,:,jk) = wn(:,:,jk) * bdytmask(:,:) 218 234 #endif 219 END DO 220 235 ! 221 236 ! !------------------------------! 222 237 ! ! outputs ! 223 238 ! !------------------------------! 224 CALL iom_put( "woce", wn ) ! vertical velocity 225 CALL iom_put( "ssh" , sshn ) ! sea surface height 226 CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) ) ! square of sea surface height 239 CALL iom_put( "woce", wn ) ! vertical velocity 227 240 IF( lk_diaar5 ) THEN ! vertical mass transport & its square value 241 CALL wrk_alloc( jpi, jpj, z2d ) 242 CALL wrk_alloc( jpi, jpj, jpk, z3d ) 228 243 ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 229 CALL wrk_alloc( jpi,jpj,jpk, z3d ) 230 z2d(:,:) = rau0 * e1t(:,:) * e2t(:,:) 244 z2d(:,:) = rau0 * e12t(:,:) 231 245 DO jk = 1, jpk 232 246 z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) … … 234 248 CALL iom_put( "w_masstr" , z3d ) 235 249 CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 236 CALL wrk_dealloc( jpi,jpj,jpk, z3d ) 237 ENDIF 238 ! 239 IF(ln_ctl) CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha - : ', mask1=tmask, ovlap=1 ) 240 ! 241 CALL wrk_dealloc( jpi, jpj, z2d, zhdiv ) 242 ! 243 IF( nn_timing == 1 ) CALL timing_stop('ssh_wzv') 244 ! 245 END SUBROUTINE ssh_wzv 246 247 248 SUBROUTINE ssh_nxt( kt ) 250 CALL wrk_dealloc( jpi, jpj, z2d ) 251 CALL wrk_dealloc( jpi, jpj, jpk, z3d ) 252 ENDIF 253 ! 254 IF( nn_timing == 1 ) CALL timing_stop('wzv') 255 256 257 END SUBROUTINE wzv 258 259 SUBROUTINE ssh_swp( kt ) 249 260 !!---------------------------------------------------------------------- 250 261 !! *** ROUTINE ssh_nxt *** … … 252 263 !! ** Purpose : achieve the sea surface height time stepping by 253 264 !! applying Asselin time filter and swapping the arrays 254 !! ssha already computed in ssh_ wzv265 !! ssha already computed in ssh_nxt 255 266 !! 256 267 !! ** Method : - apply Asselin time fiter to now ssh (excluding the forcing … … 266 277 !!---------------------------------------------------------------------- 267 278 INTEGER, INTENT(in) :: kt ! ocean time-step index 268 !! 269 INTEGER :: ji, jj ! dummy loop indices 270 REAL(wp) :: zec ! temporary scalar 271 !!---------------------------------------------------------------------- 272 ! 273 IF( nn_timing == 1 ) CALL timing_start('ssh_nxt') 279 !!---------------------------------------------------------------------- 280 ! 281 IF( nn_timing == 1 ) CALL timing_start('ssh_swp') 274 282 ! 275 283 IF( kt == nit000 ) THEN 276 284 IF(lwp) WRITE(numout,*) 277 IF(lwp) WRITE(numout,*) 'ssh_ nxt : next sea surface height (Asselin time filter + swap)'285 IF(lwp) WRITE(numout,*) 'ssh_swp : Asselin time filter and swap of sea surface height' 278 286 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 279 287 ENDIF 280 288 281 ! !--------------------------! 282 IF( lk_vvl ) THEN ! Variable volume levels ! (ssh at t-, u-, v, f-points) 283 ! !--------------------------! 284 ! 285 IF( neuler == 0 .AND. kt == nit000 ) THEN !** Euler time-stepping at first time-step : no filter 286 sshn (:,:) = ssha (:,:) ! now <-- after (before already = now) 287 sshu_n(:,:) = sshu_a(:,:) 288 sshv_n(:,:) = sshv_a(:,:) 289 DO jj = 1, jpjm1 ! ssh now at f-point 290 DO ji = 1, jpim1 ! NO Vector Opt. 291 sshf_n(ji,jj) = 0.5 * umask(ji,jj,1) * umask(ji,jj+1,1) & 292 & / ( e1f(ji,jj ) * e2f(ji,jj ) ) & 293 & * ( e1u(ji,jj ) * e2u(ji,jj ) * sshu_n(ji,jj ) & 294 & + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 295 END DO 296 END DO 297 CALL lbc_lnk( sshf_n, 'F', 1. ) ! Boundaries conditions 298 ! 299 ELSE !** Leap-Frog time-stepping: Asselin filter + swap 300 zec = atfp * rdt / rau0 301 DO jj = 1, jpj 302 DO ji = 1, jpi ! before <-- now filtered 303 sshb (ji,jj) = sshn (ji,jj) + atfp * ( sshb(ji,jj) - 2 * sshn(ji,jj) + ssha(ji,jj) ) & 304 & - zec * ( emp_b(ji,jj) - emp(ji,jj) ) * tmask(ji,jj,1) 305 sshn (ji,jj) = ssha (ji,jj) ! now <-- after 306 sshu_n(ji,jj) = sshu_a(ji,jj) 307 sshv_n(ji,jj) = sshv_a(ji,jj) 308 END DO 309 END DO 310 DO jj = 1, jpjm1 ! ssh now at f-point 311 DO ji = 1, jpim1 ! NO Vector Opt. 312 sshf_n(ji,jj) = 0.5 * umask(ji,jj,1) * umask(ji,jj+1,1) & 313 & / ( e1f(ji,jj ) * e2f(ji,jj ) ) & 314 & * ( e1u(ji,jj ) * e2u(ji,jj ) * sshu_n(ji,jj ) & 315 & + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 316 END DO 317 END DO 318 CALL lbc_lnk( sshf_n, 'F', 1. ) ! Boundaries conditions 319 ! 320 DO jj = 1, jpjm1 ! ssh before at u- & v-points 321 DO ji = 1, jpim1 ! NO Vector Opt. 322 sshu_b(ji,jj) = 0.5 * umask(ji,jj,1) / ( e1u(ji ,jj) * e2u(ji ,jj) ) & 323 & * ( e1t(ji ,jj) * e2t(ji ,jj) * sshb(ji ,jj) & 324 & + e1t(ji+1,jj) * e2t(ji+1,jj) * sshb(ji+1,jj) ) 325 sshv_b(ji,jj) = 0.5 * vmask(ji,jj,1) / ( e1v(ji,jj ) * e2v(ji,jj ) ) & 326 & * ( e1t(ji,jj ) * e2t(ji,jj ) * sshb(ji,jj ) & 327 & + e1t(ji,jj+1) * e2t(ji,jj+1) * sshb(ji,jj+1) ) 328 END DO 329 END DO 330 CALL lbc_lnk( sshu_b, 'U', 1. ) 331 CALL lbc_lnk( sshv_b, 'V', 1. ) ! Boundaries conditions 332 ! 333 ENDIF 334 ! !--------------------------! 335 ELSE ! fixed levels ! (ssh at t-point only) 336 ! !--------------------------! 337 ! 338 IF( neuler == 0 .AND. kt == nit000 ) THEN !** Euler time-stepping at first time-step : no filter 339 sshn(:,:) = ssha(:,:) ! now <-- after (before already = now) 340 ! 341 ELSE ! Leap-Frog time-stepping: Asselin filter + swap 342 DO jj = 1, jpj 343 DO ji = 1, jpi ! before <-- now filtered 344 sshb(ji,jj) = sshn(ji,jj) + atfp * ( sshb(ji,jj) - 2 * sshn(ji,jj) + ssha(ji,jj) ) 345 sshn(ji,jj) = ssha(ji,jj) ! now <-- after 346 END DO 347 END DO 348 ENDIF 349 ! 289 # if defined key_dynspg_ts 290 IF( ( neuler == 0 .AND. kt == nit000 ) .OR. ln_bt_fw ) THEN !** Euler time-stepping: no filter 291 # else 292 IF ( neuler == 0 .AND. kt == nit000 ) THEN !** Euler time-stepping at first time-step : no filter 293 #endif 294 sshb(:,:) = sshn(:,:) ! before <-- now 295 sshn(:,:) = ssha(:,:) ! now <-- after (before already = now) 296 ELSE !** Leap-Frog time-stepping: Asselin filter + swap 297 sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) ) ! before <-- now filtered 298 IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 299 sshn(:,:) = ssha(:,:) ! now <-- after 350 300 ENDIF 351 301 ! … … 357 307 IF(ln_ctl) CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb - : ', mask1=tmask, ovlap=1 ) 358 308 ! 359 IF( nn_timing == 1 ) CALL timing_stop('ssh_ nxt')360 ! 361 END SUBROUTINE ssh_ nxt309 IF( nn_timing == 1 ) CALL timing_stop('ssh_swp') 310 ! 311 END SUBROUTINE ssh_swp 362 312 363 313 !!====================================================================== -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90
r4245 r4292 136 136 137 137 ! vertical grid definition 138 CALL iom_set_axis_attr( "deptht", gdept_ 0)139 CALL iom_set_axis_attr( "depthu", gdept_ 0)140 CALL iom_set_axis_attr( "depthv", gdept_ 0)141 CALL iom_set_axis_attr( "depthw", gdepw_ 0)138 CALL iom_set_axis_attr( "deptht", gdept_1d ) 139 CALL iom_set_axis_attr( "depthu", gdept_1d ) 140 CALL iom_set_axis_attr( "depthv", gdept_1d ) 141 CALL iom_set_axis_attr( "depthw", gdepw_1d ) 142 142 # if defined key_floats 143 143 CALL iom_set_axis_attr( "nfloat", (/ (REAL(ji,wp), ji=1,nfloat) /) ) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/IOM/iom_ioipsl.F90
r4245 r4292 408 408 CALL flioputv( ioipslid, 'nav_lon' , glamt(ix1:ix2, iy1:iy2) ) 409 409 CALL flioputv( ioipslid, 'nav_lat' , gphit(ix1:ix2, iy1:iy2) ) 410 CALL flioputv( ioipslid, 'nav_lev' , gdept_ 0)410 CALL flioputv( ioipslid, 'nav_lev' , gdept_1d ) 411 411 ! +++ WRONG VALUE: to be improved but not really useful... 412 412 CALL flioputv( ioipslid, 'time_counter', kt ) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/IOM/iom_nf90.F90
r4245 r4292 532 532 CALL iom_nf90_check(NF90_PUT_VAR( if90id, idmy, gphit(ix1:ix2, iy1:iy2) ), clinfo) 533 533 CALL iom_nf90_check(NF90_INQ_VARID( if90id, 'nav_lev' , idmy ), clinfo) 534 CALL iom_nf90_check(NF90_PUT_VAR( if90id, idmy, gdept_ 0), clinfo)534 CALL iom_nf90_check(NF90_PUT_VAR( if90id, idmy, gdept_1d ), clinfo) 535 535 ! +++ WRONG VALUE: to be improved but not really useful... 536 536 CALL iom_nf90_check(NF90_INQ_VARID( if90id, 'time_counter', idmy ), clinfo) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90
r4206 r4292 23 23 USE eosbn2 ! equation of state (eos bn2 routine) 24 24 USE trdmld_oce ! ocean active mixed layer tracers trends variables 25 USE domvvl ! variable volume26 25 USE divcur ! hor. divergence and curl (div & cur routines) 27 26 USE sbc_ice, ONLY : lk_lim3 … … 30 29 PRIVATE 31 30 32 PUBLIC rst_opn ! routine called by step module 33 PUBLIC rst_write ! routine called by step module 34 PUBLIC rst_read ! routine called by opa module 31 PUBLIC rst_opn ! routine called by step module 32 PUBLIC rst_write ! routine called by step module 33 PUBLIC rst_read ! routine called by istate module 34 PUBLIC rst_read_open ! routine called in rst_read and (possibly) in dom_vvl_init 35 35 36 36 !! * Substitutions … … 120 120 CALL iom_rstput( kt, nitrst, numrow, 'hdivb' , hdivb ) 121 121 CALL iom_rstput( kt, nitrst, numrow, 'sshb' , sshb ) 122 IF( lk_vvl ) CALL iom_rstput( kt, nitrst, numrow, 'fse3t_b', fse3t_b(:,:,:) )123 122 ! 124 123 CALL iom_rstput( kt, nitrst, numrow, 'un' , un ) ! now fields … … 144 143 END SUBROUTINE rst_write 145 144 145 SUBROUTINE rst_read_open 146 !!---------------------------------------------------------------------- 147 !! *** ROUTINE rst_read_open *** 148 !! 149 !! ** Purpose : Open read files for restart (format fixed by jprstlib ) 150 !! 151 !! ** Method : Use a non-zero, positive value of numror to assess whether or not 152 !! the file has already been opened 153 !!---------------------------------------------------------------------- 154 INTEGER :: jlibalt = jprstlib 155 LOGICAL :: llok 156 !!---------------------------------------------------------------------- 157 158 IF( numror .LE. 0 ) THEN 159 IF(lwp) THEN ! Contol prints 160 WRITE(numout,*) 161 SELECT CASE ( jprstlib ) 162 CASE ( jpnf90 ) ; WRITE(numout,*) 'rst_read : read oce NetCDF restart file' 163 CASE ( jprstdimg ) ; WRITE(numout,*) 'rst_read : read oce binary restart file' 164 END SELECT 165 IF ( snc4set%luse ) WRITE(numout,*) 'rst_read : configured with NetCDF4 support' 166 WRITE(numout,*) '~~~~~~~~' 167 ENDIF 168 169 IF ( jprstlib == jprstdimg ) THEN 170 ! eventually read netcdf file (monobloc) for restarting on different number of processors 171 ! if {cn_ocerst_in}.nc exists, then set jlibalt to jpnf90 172 INQUIRE( FILE = TRIM(cn_ocerst_in)//'.nc', EXIST = llok ) 173 IF ( llok ) THEN ; jlibalt = jpnf90 ; ELSE ; jlibalt = jprstlib ; ENDIF 174 ENDIF 175 CALL iom_open( cn_ocerst_in, numror, kiolib = jlibalt ) 176 ENDIF 177 END SUBROUTINE rst_read_open 146 178 147 179 SUBROUTINE rst_read … … 154 186 !!---------------------------------------------------------------------- 155 187 REAL(wp) :: zrdt, zrdttra1 156 INTEGER :: jk , jlibalt = jprstlib188 INTEGER :: jk 157 189 LOGICAL :: llok 158 190 !!---------------------------------------------------------------------- 159 191 160 IF(lwp) THEN ! Contol prints 161 WRITE(numout,*) 162 SELECT CASE ( jprstlib ) 163 CASE ( jpnf90 ) ; WRITE(numout,*) 'rst_read : read oce NetCDF restart file ',TRIM(cn_ocerst_in)//'.nc' 164 CASE ( jprstdimg ) ; WRITE(numout,*) 'rst_read : read oce binary restart file' 165 END SELECT 166 IF ( snc4set%luse ) WRITE(numout,*) 'rst_read : configured with NetCDF4 support' 167 WRITE(numout,*) '~~~~~~~~' 168 ENDIF 169 170 IF ( jprstlib == jprstdimg ) THEN 171 ! eventually read netcdf file (monobloc) for restarting on different number of processors 172 ! if {cn_ocerst_in}.nc exists, then set jlibalt to jpnf90 173 INQUIRE( FILE = TRIM(cn_ocerst_in)//'.nc', EXIST = llok ) 174 IF ( llok ) THEN ; jlibalt = jpnf90 ; ELSE ; jlibalt = jprstlib ; ENDIF 175 ENDIF 176 CALL iom_open( cn_ocerst_in, numror, kiolib = jlibalt ) 192 CALL rst_read_open ! open restart for reading (if not already opened) 177 193 178 194 ! Check dynamics and tracer time-step consistency and force Euler restart if changed … … 194 210 CALL iom_get( numror, jpdom_autoglo, 'hdivb' , hdivb ) 195 211 CALL iom_get( numror, jpdom_autoglo, 'sshb' , sshb ) 196 IF( lk_vvl ) CALL iom_get( numror, jpdom_autoglo, 'fse3t_b', fse3t_b(:,:,:) )197 212 ELSE 198 213 neuler = 0 … … 230 245 hdivb(:,:,:) = hdivn(:,:,:) 231 246 sshb (:,:) = sshn (:,:) 232 IF( lk_vvl ) THEN233 DO jk = 1, jpk234 fse3t_b(:,:,jk) = fse3t_n(:,:,jk)235 END DO236 ENDIF237 247 ENDIF 238 248 ! -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn.F90
r4147 r4292 191 191 !!---------------------------------------------------------------------- 192 192 193 zm00 = TANH( ( pdam - gdept_ 0(1 ) ) / pwam )194 zm01 = TANH( ( pdam - gdept_ 0(jpkm1) ) / pwam )193 zm00 = TANH( ( pdam - gdept_1d(1 ) ) / pwam ) 194 zm01 = TANH( ( pdam - gdept_1d(jpkm1) ) / pwam ) 195 195 zmhs = zm00 / zm01 196 196 zmhb = ( 1.e0 - pbot ) / ( 1.e0 - zmhs ) / zm01 … … 232 232 !!---------------------------------------------------------------------- 233 233 234 zm00 = TANH( ( pdam - gdept_ 0(1 ) ) / pwam )235 zm01 = TANH( ( pdam - gdept_ 0(jpkm1) ) / pwam )234 zm00 = TANH( ( pdam - gdept_1d(1 ) ) / pwam ) 235 zm01 = TANH( ( pdam - gdept_1d(jpkm1) ) / pwam ) 236 236 zmhs = zm00 / zm01 237 237 zmhb = ( 1.e0 - pbot ) / ( 1.e0 - zmhs ) / zm01 … … 274 274 !!---------------------------------------------------------------------- 275 275 276 zm00 = TANH( ( pdam - gdept_ 0(1 ) ) / pwam )277 zm01 = TANH( ( pdam - gdept_ 0(jpkm1) ) / pwam )276 zm00 = TANH( ( pdam - gdept_1d(1 ) ) / pwam ) 277 zm01 = TANH( ( pdam - gdept_1d(jpkm1) ) / pwam ) 278 278 zmhs = zm00 / zm01 279 279 zmhb = ( 1.e0 - pbot ) / ( 1.e0 - zmhs ) / zm01 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_c3d.h90
r3294 r4292 386 386 387 387 DO jk=1, jpk 388 zcoef(jk) = 1.0_wp + NINT(9.0_wp*(gdept_ 0(jk)-800.0_wp)/(3000.0_wp-800.0_wp))388 zcoef(jk) = 1.0_wp + NINT(9.0_wp*(gdept_1d(jk)-800.0_wp)/(3000.0_wp-800.0_wp)) 389 389 zcoef(jk) = MIN(10.0_wp, MAX(1.0_wp, zcoef(jk))) 390 390 IF(lwp) WRITE(numout,'(4x,i3,6x,f7.3)') jk,zcoef(jk) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90
r4245 r4292 976 976 USE dom_oce, ONLY : & ! Ocean space and time domain variables 977 977 & rdt, & 978 & gdept_ 0, &978 & gdept_1d, & 979 979 & tmask, umask, vmask 980 980 USE phycst, ONLY : & ! Physical constants … … 1038 1038 & kstp, jpi, jpj, jpk, nit000, idaystp, & 1039 1039 & tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal), & 1040 & gdept_ 0, tmask, n1dint, n2dint,&1040 & gdept_1d, tmask, n1dint, n2dint, & 1041 1041 & kdailyavtypes = endailyavtypes ) 1042 1042 ELSE … … 1044 1044 & kstp, jpi, jpj, jpk, nit000, idaystp, & 1045 1045 & tsn(:,:,:,jp_tem), tsn(:,:,:,jp_sal), & 1046 & gdept_ 0, tmask, n1dint, n2dint)1046 & gdept_1d, tmask, n1dint, n2dint ) 1047 1047 ENDIF 1048 1048 END DO … … 1088 1088 ! zonal component of velocity 1089 1089 CALL obs_vel_opt( veldatqc(jveloset), kstp, jpi, jpj, jpk, & 1090 & nit000, idaystp, un, vn, gdept_ 0, umask, vmask, &1090 & nit000, idaystp, un, vn, gdept_1d, umask, vmask, & 1091 1091 n1dint, n2dint, ld_velav(jveloset) ) 1092 1092 END DO -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90
r2715 r4292 75 75 & glamt, & 76 76 & gphit, & 77 & gdept_ 0,&77 & gdept_1d,& 78 78 & tmask, & 79 79 & nproc … … 193 193 & profdata%var(1)%vdep, & 194 194 & glamt, gphit, & 195 & gdept_ 0,tmask, &195 & gdept_1d, tmask, & 196 196 & profdata%nqc, profdata%var(1)%nvqc, & 197 197 & iosdtobs, ilantobs, & … … 213 213 & profdata%var(2)%vdep, & 214 214 & glamt, gphit, & 215 & gdept_ 0,tmask, &215 & gdept_1d, tmask, & 216 216 & profdata%nqc, profdata%var(2)%nvqc, & 217 217 & iosdsobs, ilansobs, & … … 916 916 & glamt, glamu, glamv, & 917 917 & gphit, gphiu, gphiv, & 918 & gdept_ 0,&918 & gdept_1d, & 919 919 & tmask, umask, vmask, & 920 920 & nproc … … 1032 1032 & profdata%var(1)%vdep, & 1033 1033 & glamu, gphiu, & 1034 & gdept_ 0,umask, &1034 & gdept_1d, umask, & 1035 1035 & profdata%nqc, profdata%var(1)%nvqc, & 1036 1036 & iosduobs, ilanuobs, & … … 1052 1052 & profdata%var(2)%vdep, & 1053 1053 & glamv, gphiv, & 1054 & gdept_ 0,vmask, &1054 & gdept_1d, vmask, & 1055 1055 & profdata%nqc, profdata%var(2)%nvqc, & 1056 1056 & iosdvobs, ilanvobs, & … … 1709 1709 !! * Modules used 1710 1710 USE dom_oce, ONLY : & ! Geographical information 1711 & gdepw_ 01711 & gdepw_1d 1712 1712 1713 1713 !! * Arguments … … 1826 1826 & .OR. ( pobsphi(jobs) > 90. ) & 1827 1827 & .OR. ( pobsdep(jobsp) < 0.0 ) & 1828 & .OR. ( pobsdep(jobsp) > gdepw_ 0(kpk)) ) THEN1828 & .OR. ( pobsdep(jobsp) > gdepw_1d(kpk)) ) THEN 1829 1829 kobsqc(jobsp) = kobsqc(jobsp) + 11 1830 1830 kosdobs = kosdobs + 1 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_prof.F90
r2715 r4292 793 793 !----------------------------------------------------------------------- 794 794 IF ( ldt3d ) THEN 795 CALL obs_level_search( jpk, gdept_ 0, &795 CALL obs_level_search( jpk, gdept_1d, & 796 796 & profdata%nvprot(1), profdata%var(1)%vdep, & 797 797 & profdata%var(1)%mvk ) 798 798 ENDIF 799 799 IF ( lds3d ) THEN 800 CALL obs_level_search( jpk, gdept_ 0, &800 CALL obs_level_search( jpk, gdept_1d, & 801 801 & profdata%nvprot(2), profdata%var(2)%vdep, & 802 802 & profdata%var(2)%mvk ) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_vel.F90
r2715 r4292 614 614 ! Model level search 615 615 !----------------------------------------------------------------------- 616 CALL obs_level_search( jpk, gdept_ 0,&616 CALL obs_level_search( jpk, gdept_1d, & 617 617 & profdata%nvprot(1), profdata%var(1)%vdep, & 618 618 & profdata%var(1)%mvk ) 619 CALL obs_level_search( jpk, gdept_ 0,&619 CALL obs_level_search( jpk, gdept_1d, & 620 620 & profdata%nvprot(2), profdata%var(2)%vdep, & 621 621 & profdata%var(2)%mvk ) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90
r4230 r4292 100 100 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sss_m !: mean (nn_fsbc time-step) surface sea salinity [psu] 101 101 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssh_m !: mean (nn_fsbc time-step) sea surface height [m] 102 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3t_m !: mean (nn_fsbc time-step) sea surface height [m] 102 103 103 104 !! * Substitutions … … 114 115 !! *** FUNCTION sbc_oce_alloc *** 115 116 !!--------------------------------------------------------------------- 116 INTEGER :: ierr( 4)117 INTEGER :: ierr(5) 117 118 !!--------------------------------------------------------------------- 118 119 ierr(:) = 0 … … 135 136 & ssu_m (jpi,jpj) , sst_m(jpi,jpj) , & 136 137 & ssv_m (jpi,jpj) , sss_m (jpi,jpj), ssh_m(jpi,jpj) , STAT=ierr(4) ) 138 ! 139 #if defined key_vvl 140 ALLOCATE( e3t_m(jpi,jpj) , STAT=ierr(5) ) 141 #endif 137 142 ! 138 143 sbc_oce_alloc = MAXVAL( ierr ) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90
r4230 r4292 412 412 ! Freezing/melting potential 413 413 ! Calculated over NEMO leapfrog timestep (hence 2*dt) 414 nfrzmlt(:,:)=rau0*rcp*fse3t_m(:,: ,1)*(Tocnfrz-sst_m(:,:))/(2.0*dt)414 nfrzmlt(:,:)=rau0*rcp*fse3t_m(:,:)*(Tocnfrz-sst_m(:,:))/(2.0*dt) 415 415 416 416 ztmp(:,:) = nfrzmlt(:,:) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90
r4147 r4292 388 388 IF( rn_hrnf > 0._wp ) THEN 389 389 nkrnf = 2 390 DO WHILE( nkrnf /= jpkm1 .AND. gdepw_ 0(nkrnf+1) < rn_hrnf ) ; nkrnf = nkrnf + 1 ; END DO390 DO WHILE( nkrnf /= jpkm1 .AND. gdepw_1d(nkrnf+1) < rn_hrnf ) ; nkrnf = nkrnf + 1 ; END DO 391 391 IF( ln_sco ) CALL ctl_warn( 'sbc_rnf: number of levels over which Kz is increased is computed for zco...' ) 392 392 ENDIF -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90
r3680 r4292 26 26 PUBLIC sbc_ssm ! routine called by step.F90 27 27 PUBLIC sbc_ssm_init ! routine called by sbcmod.F90 28 28 29 29 LOGICAL, SAVE :: l_ssm_mean = .FALSE. ! keep track of whether means have been read 30 30 ! from restart file 31 31 32 32 !! * Substitutions 33 33 # include "domzgr_substitute.h90" … … 67 67 ELSE ; ssh_m(:,:) = sshn(:,:) 68 68 ENDIF 69 69 ! 70 IF( lk_vvl ) fse3t_m(:,:) = fse3t_n(:,:,1) 70 71 ! 71 72 ELSE … … 84 85 ELSE ; ssh_m(:,:) = zcoef * sshn(:,:) 85 86 ENDIF 87 IF( lk_vvl ) fse3t_m(:,:) = zcoef * fse3t_n(:,:,1) 86 88 ! ! ---------------------------------------- ! 87 89 ELSEIF( MOD( kt - 2 , nn_fsbc ) == 0 ) THEN ! Initialisation: New mean computation ! … … 92 94 sss_m(:,:) = 0.e0 93 95 ssh_m(:,:) = 0.e0 96 IF( lk_vvl ) fse3t_m(:,:) = 0.e0 94 97 ENDIF 95 98 ! ! ---------------------------------------- ! … … 104 107 ELSE ; ssh_m(:,:) = ssh_m(:,:) + sshn(:,:) 105 108 ENDIF 109 IF( lk_vvl ) fse3t_m(:,:) = fse3t_m(:,:) + fse3t_n(:,:,1) 106 110 107 111 ! ! ---------------------------------------- ! … … 114 118 ssv_m(:,:) = ssv_m(:,:) * zcoef ! 115 119 ssh_m(:,:) = ssh_m(:,:) * zcoef ! mean SSH [m] 120 IF( lk_vvl ) fse3t_m(:,:) = fse3t_m(:,:) * zcoef ! mean vertical scale factor [m] 116 121 ! 117 122 ENDIF … … 130 135 CALL iom_rstput( kt, nitrst, numrow, 'sss_m' , sss_m ) 131 136 CALL iom_rstput( kt, nitrst, numrow, 'ssh_m' , ssh_m ) 137 IF( lk_vvl ) THEN 138 CALL iom_rstput( kt, nitrst, numrow, 'fse3t_m' , fse3t_m(:,:) ) 139 END IF 132 140 ! 133 141 ENDIF … … 168 176 CALL iom_get( numror, jpdom_autoglo, 'sss_m' , sss_m ) ! " " salinity (T-point) 169 177 CALL iom_get( numror, jpdom_autoglo, 'ssh_m' , ssh_m ) ! " " height (T-point) 178 IF( lk_vvl ) CALL iom_get( numror, jpdom_autoglo, 'fse3t_m', fse3t_m(:,:) ) 170 179 ! 171 180 IF( zf_sbc /= REAL( nn_fsbc, wp ) ) THEN ! nn_fsbc has changed between 2 runs … … 178 187 sss_m(:,:) = zcoef * sss_m(:,:) 179 188 ssh_m(:,:) = zcoef * ssh_m(:,:) 189 IF( lk_vvl ) fse3t_m(:,:) = zcoef * fse3t_m(:,:) 180 190 ELSE 181 191 IF(lwp) WRITE(numout,*) '~~~~~~~ mean fields read in the ocean restart file' -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbctide.F90
r3651 r4292 1 1 MODULE sbctide 2 !!================================================================================= 3 !! *** MODULE sbctide *** 4 !! Initialization of tidal forcing 5 !! History : 9.0 ! 07 (O. Le Galloudec) Original code 6 !!================================================================================= 7 !! * Modules used 8 USE oce ! ocean dynamics and tracers variables 9 USE dom_oce ! ocean space and time domain 10 USE in_out_manager ! I/O units 11 USE ioipsl ! NetCDF IPSL library 12 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 13 USE phycst 14 USE daymod 15 USE dynspg_oce 16 USE tideini 17 USE iom 2 !!====================================================================== 3 !! *** MODULE sbctide *** 4 !! Initialization of tidal forcing 5 !!====================================================================== 6 !! History : 9.0 ! 2007 (O. Le Galloudec) Original code 7 !!---------------------------------------------------------------------- 8 USE oce ! ocean dynamics and tracers variables 9 USE dom_oce ! ocean space and time domain 10 USE phycst 11 USE daymod 12 USE dynspg_oce 13 USE tideini 14 ! 15 USE iom 16 USE in_out_manager ! I/O units 17 USE ioipsl ! NetCDF IPSL library 18 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 18 19 19 IMPLICIT NONE20 PUBLIC20 IMPLICIT NONE 21 PUBLIC 21 22 22 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pot_astro23 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: pot_astro ! 23 24 24 25 #if defined key_tide 26 !!---------------------------------------------------------------------- 27 !! 'key_tide' : tidal potential 28 !!---------------------------------------------------------------------- 29 !! sbc_tide : 30 !! tide_init_potential : 31 !!---------------------------------------------------------------------- 25 32 26 LOGICAL, PUBLIC, PARAMETER :: lk_tide = .TRUE. 27 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_pot,phi_pot 28 !!--------------------------------------------------------------------------------- 29 !! OPA 9.0 , LODYC-IPSL (2003) 30 !!--------------------------------------------------------------------------------- 33 LOGICAL, PUBLIC, PARAMETER :: lk_tide = .TRUE. 34 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_pot, phi_pot 31 35 36 !!---------------------------------------------------------------------- 37 !! NEMO/OPA 3.5 , NEMO Consortium (2013) 38 !! $Id: $ 39 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 40 !!---------------------------------------------------------------------- 32 41 CONTAINS 33 42 34 SUBROUTINE sbc_tide( kt )35 !!----------------------------------------------------------------------36 !! *** ROUTINE sbc_tide ***37 !!----------------------------------------------------------------------38 !! * Arguments39 INTEGER, INTENT( in ) :: kt ! ocean time-step40 !!----------------------------------------------------------------------43 SUBROUTINE sbc_tide( kt ) 44 !!---------------------------------------------------------------------- 45 !! *** ROUTINE sbc_tide *** 46 !!---------------------------------------------------------------------- 47 INTEGER, INTENT( in ) :: kt ! ocean time-step 48 INTEGER :: jk ! dummy loop index 49 !!---------------------------------------------------------------------- 41 50 42 IF ( kt == nit000 .AND. .NOT. lk_dynspg_ts ) CALL ctl_stop( 'STOP', 'sbc_tide : tidal potential use only with time splitting' ) 43 44 IF ( nsec_day == NINT(0.5 * rdttra(1)) ) THEN 51 IF( nsec_day == NINT(0.5_wp * rdttra(1)) ) THEN ! start a new day 52 ! 53 IF( kt == nit000 ) THEN 54 ALLOCATE( amp_pot(jpi,jpj,nb_harmo), & 55 & phi_pot(jpi,jpj,nb_harmo), pot_astro(jpi,jpj) ) 56 ENDIF 57 ! 58 amp_pot(:,:,:) = 0._wp 59 phi_pot(:,:,:) = 0._wp 60 pot_astro(:,:) = 0._wp 61 ! 62 CALL tide_harmo( omega_tide, v0tide, utide, ftide, ntide, nb_harmo ) 63 ! 64 kt_tide = kt 65 ! 66 IF(lwp) THEN 67 WRITE(numout,*) 68 WRITE(numout,*) 'sbc_tide : Update of the components and (re)Init. the potential at kt=', kt 69 WRITE(numout,*) '~~~~~~~~ ' 70 DO jk = 1, nb_harmo 71 WRITE(numout,*) Wave(ntide(jk))%cname_tide, utide(jk), ftide(jk), v0tide(jk), omega_tide(jk) 72 END DO 73 ENDIF 74 ! 75 IF( ln_tide_pot ) CALL tide_init_potential 76 ! 77 ENDIF 45 78 ! 46 kt_tide = kt 47 48 IF(lwp) THEN 49 WRITE(numout,*) 50 WRITE(numout,*) 'sbc_tide : (re)Initialization of the tidal potential at kt=',kt 51 WRITE(numout,*) '~~~~~~~ ' 52 ENDIF 53 54 IF(lwp) THEN 55 IF ( kt == nit000 ) WRITE(numout,*) 'Apply astronomical potential : ln_tide_pot =', ln_tide_pot 56 CALL flush(numout) 57 ENDIF 58 59 IF ( kt == nit000 ) ALLOCATE(amp_pot(jpi,jpj,nb_harmo)) 60 IF ( kt == nit000 ) ALLOCATE(phi_pot(jpi,jpj,nb_harmo)) 61 IF ( kt == nit000 ) ALLOCATE(pot_astro(jpi,jpj)) 62 63 amp_pot(:,:,:) = 0.e0 64 phi_pot(:,:,:) = 0.e0 65 pot_astro(:,:) = 0.e0 66 67 IF ( ln_tide_pot ) CALL tide_init_potential 68 ! 69 ENDIF 70 71 END SUBROUTINE sbc_tide 72 73 SUBROUTINE tide_init_potential 74 !!---------------------------------------------------------------------- 75 !! *** ROUTINE tide_init_potential *** 76 !!---------------------------------------------------------------------- 77 !! * Local declarations 78 INTEGER :: ji,jj,jk 79 REAL(wp) :: zcons,ztmp1,ztmp2,zlat,zlon 79 END SUBROUTINE sbc_tide 80 80 81 81 82 DO jk=1,nb_harmo 83 zcons=0.7*Wave(ntide(jk))%equitide*ftide(jk) 84 do ji=1,jpi 85 do jj=1,jpj 86 ztmp1 = amp_pot(ji,jj,jk)*COS(phi_pot(ji,jj,jk)) 87 ztmp2 = -amp_pot(ji,jj,jk)*SIN(phi_pot(ji,jj,jk)) 88 zlat = gphit(ji,jj)*rad !! latitude en radian 89 zlon = glamt(ji,jj)*rad !! longitude en radian 90 ! le potentiel est composé des effets des astres: 91 IF (Wave(ntide(jk))%nutide .EQ.1) THEN 92 ztmp1= ztmp1 + zcons*(SIN(2.*zlat))*COS(v0tide(jk)+utide(jk)+Wave(ntide(jk))%nutide*zlon) 93 ztmp2= ztmp2 - zcons*(SIN(2.*zlat))*SIN(v0tide(jk)+utide(jk)+Wave(ntide(jk))%nutide*zlon) 94 ENDIF 95 IF (Wave(ntide(jk))%nutide.EQ.2) THEN 96 ztmp1= ztmp1 + zcons*(COS(zlat)**2)*COS(v0tide(jk)+utide(jk)+Wave(ntide(jk))%nutide*zlon) 97 ztmp2= ztmp2 - zcons*(COS(zlat)**2)*SIN(v0tide(jk)+utide(jk)+Wave(ntide(jk))%nutide*zlon) 98 ENDIF 99 amp_pot(ji,jj,jk)=SQRT(ztmp1**2+ztmp2**2) 100 phi_pot(ji,jj,jk)=ATAN2(-ztmp2/MAX(1.E-10,SQRT(ztmp1**2+ztmp2**2)),ztmp1/MAX(1.E-10,SQRT(ztmp1**2+ztmp2**2))) 101 enddo 102 enddo 103 END DO 82 SUBROUTINE tide_init_potential 83 !!---------------------------------------------------------------------- 84 !! *** ROUTINE tide_init_potential *** 85 !!---------------------------------------------------------------------- 86 INTEGER :: ji, jj, jk ! dummy loop indices 87 REAL(wp) :: zcons, ztmp1, ztmp2, zlat, zlon, ztmp, zamp, zcs ! local scalar 88 !!---------------------------------------------------------------------- 104 89 105 END SUBROUTINE tide_init_potential 90 DO jk = 1, nb_harmo 91 zcons = 0.7_wp * Wave(ntide(jk))%equitide * ftide(jk) 92 DO ji = 1, jpi 93 DO jj = 1, jpj 94 ztmp1 = amp_pot(ji,jj,jk) * COS( phi_pot(ji,jj,jk) ) 95 ztmp2 = -amp_pot(ji,jj,jk) * SIN( phi_pot(ji,jj,jk) ) 96 zlat = gphit(ji,jj)*rad !! latitude en radian 97 zlon = glamt(ji,jj)*rad !! longitude en radian 98 ztmp = v0tide(jk) + utide(jk) + Wave(ntide(jk))%nutide * zlon 99 ! le potentiel est composé des effets des astres: 100 IF ( Wave(ntide(jk))%nutide == 1 ) THEN ; zcs = zcons * SIN( 2._wp*zlat ) 101 ELSEIF( Wave(ntide(jk))%nutide == 2 ) THEN ; zcs = zcons * COS( zlat )**2 102 ELSE ; zcs = 0._wp 103 ENDIF 104 ztmp1 = ztmp1 + zcs * COS( ztmp ) 105 ztmp2 = ztmp2 - zcs * SIN( ztmp ) 106 zamp = SQRT( ztmp1*ztmp1 + ztmp2*ztmp2 ) 107 amp_pot(ji,jj,jk) = zamp 108 phi_pot(ji,jj,jk) = ATAN2( -ztmp2 / MAX( 1.e-10_wp , zamp ) , & 109 & ztmp1 / MAX( 1.e-10_wp, zamp ) ) 110 END DO 111 END DO 112 END DO 113 ! 114 END SUBROUTINE tide_init_potential 106 115 107 116 #else … … 116 125 END SUBROUTINE sbc_tide 117 126 #endif 127 118 128 !!====================================================================== 119 120 129 END MODULE sbctide -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/sbcwave.F90
r4230 r4292 151 151 DO jj = 1, jpj-1 152 152 DO ji = 1, jpi-1 153 usd3d(ji,jj,jk) = usd2d(ji,jj)*exp(2.0*uwavenum(ji,jj)*(-MIN( gdept (ji,jj,jk) , gdept(ji+1,jj ,jk))))154 vsd3d(ji,jj,jk) = vsd2d(ji,jj)*exp(2.0*vwavenum(ji,jj)*(-MIN( gdept (ji,jj,jk) , gdept(ji ,jj+1,jk))))153 usd3d(ji,jj,jk) = usd2d(ji,jj)*exp(2.0*uwavenum(ji,jj)*(-MIN( gdept_0(ji,jj,jk) , gdept_0(ji+1,jj ,jk)))) 154 vsd3d(ji,jj,jk) = vsd2d(ji,jj)*exp(2.0*vwavenum(ji,jj)*(-MIN( gdept_0(ji,jj,jk) , gdept_0(ji ,jj+1,jk)))) 155 155 END DO 156 156 END DO 157 usd3d(jpi,:,jk) = usd2d(jpi,:)*exp( 2.0*uwavenum(jpi,:)*(-gdept (jpi,:,jk)) )158 vsd3d(:,jpj,jk) = vsd2d(:,jpj)*exp( 2.0*vwavenum(:,jpj)*(-gdept (:,jpj,jk)) )157 usd3d(jpi,:,jk) = usd2d(jpi,:)*exp( 2.0*uwavenum(jpi,:)*(-gdept_0(jpi,:,jk)) ) 158 vsd3d(:,jpj,jk) = vsd2d(:,jpj)*exp( 2.0*vwavenum(:,jpj)*(-gdept_0(:,jpj,jk)) ) 159 159 END DO 160 160 -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/tide.h90
r3294 r4292 1 !! History : 9.0 ! 07 (O. Le Galloudec) Original code 1 !!---------------------------------------------------------------------- 2 !! History : 3.2 ! 2007 (O. Le Galloudec) Original code 3 !!---------------------------------------------------------------------- 2 4 3 ! Wave(1)= tide(name_tide,equitide,nutide,nt,ns,nh,np,np1,shift,nksi,nnu0,nnu1,nnu2,R,formula) 4 5 6 Wave(1)= tide('M2' ,0.242297,2 ,2 ,-2,2 ,0 ,0 ,0 ,2 ,-2 ,0 ,0 ,0,78) 7 Wave(2)= tide('N2' ,0.046313,2 ,2 ,-3,2 ,1 ,0 ,0 ,2 ,-2 ,0 ,0 ,0,78) 8 Wave(3)= tide('2N2' ,0.006184,2 ,2 ,-4,2 ,2 ,0 ,0 ,2 ,-2 ,0 ,0 ,0,78) 9 Wave(4)= tide('S2' ,0.113572,2 ,2 , 0,0 ,0 ,0 ,0 ,0 , 0 ,0 ,0 ,0,0) 10 Wave(5)= tide('K2' ,0.030875,2 ,2 , 0,2 ,0 ,0 ,0 ,0 , 0 ,0 ,-2 ,0,235) 11 12 Wave(6)= tide('K1' ,0.142408,1 ,1 , 0,1 ,0 ,0 ,-90 ,0 , 0 ,-1 ,0 ,0,227) 13 Wave(7)= tide('O1' ,0.101266,1 ,1 ,-2,1 ,0 ,0 ,+90 ,2 ,-1 , 0 ,0 ,0,75) 14 Wave(8)= tide('Q1' ,0.019387,1 ,1 ,-3,1 ,1 ,0 ,+90 ,2 ,-1 , 0 ,0 ,0,75) 15 Wave(9)= tide('P1' ,0.047129,1 ,1 , 0,-1,0 ,0 ,+90 ,0 , 0 , 0 ,0 ,0,0) 16 17 Wave(10)= tide('M4' ,0.000000,4 ,4 ,-4, 4,0 ,0 ,0 ,4 , -4 , 0 ,0 ,0,1) 18 19 Wave(11) = tide('Mf' ,0.042017,0 ,0 , 2, 0,0 ,0 ,0 ,-2 , 0 , 0 ,0 ,0,74) 20 Wave(12) = tide('Mm' ,0.022191,0 ,0 , 1,0 ,-1,0 ,0 ,0 , 0 , 0 ,0 ,0,73) 21 Wave(13) = tide('Msqm' ,0.000667,0 ,0 , 4,-2, 0,0 ,0 ,-2 , 0 , 0 ,0 ,0,74) 22 Wave(14) = tide('Mtm' ,0.008049,0 ,0 , 3, 0,-1,0 ,0 ,-2 , 0 , 0 ,0 ,0,74) 23 24 Wave(15) = tide('S1' ,0.000000,1 ,1, 0, 0, 0,0 ,0 , 0 , 0 , 0 ,0 ,0,0) 25 Wave(16) = tide('MU2' ,0.005841,2 ,2, -4, 4, 0,0 ,0 ,2 ,-2 , 0, 0 ,0,78) 26 Wave(17) = tide('NU2' ,0.009094,2 ,2, -3, 4,-1,0 ,0 ,2 ,-2 , 0, 0 ,0,78) 27 Wave(18) = tide('L2' ,0.006694,2 ,2, -1, 2,-1,0 ,+180 ,2 ,-2 , 0, 0 ,0,215) 28 Wave(19) = tide('T2' ,0.006614,2 ,2, 0,-1, 0,1 ,0 ,0 , 0 , 0, 0 ,0,0) 5 ! !! name_tide , equitide , nutide , nt , ns , nh , np , np1 , shift , nksi , nnu0 , nnu1 , nnu2 , R , formula !! 6 ! !! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !! 7 Wave( 1) = tide( 'M2' , 0.242297 , 2 , 2 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) 8 Wave( 2) = tide( 'N2' , 0.046313 , 2 , 2 , -3 , 2 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) 9 Wave( 3) = tide( '2N2' , 0.006184 , 2 , 2 , -4 , 2 , 2 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) 10 Wave( 4) = tide( 'S2' , 0.113572 , 2 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) 11 Wave( 5) = tide( 'K2' , 0.030875 , 2 , 2 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , -2 , 0 , 235 ) 12 ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! 13 Wave( 6) = tide( 'K1' , 0.142408 , 1 , 1 , 0 , 1 , 0 , 0 , -90 , 0 , 0 , -1 , 0 , 0 , 227 ) 14 Wave( 7) = tide( 'O1' , 0.101266 , 1 , 1 , -2 , 1 , 0 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) 15 Wave( 8) = tide( 'Q1' , 0.019387 , 1 , 1 , -3 , 1 , 1 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) 16 Wave( 9) = tide( 'P1' , 0.047129 , 1 , 1 , 0 , -1 , 0 , 0 , +90 , 0 , 0 , 0 , 0 , 0 , 0 ) 17 ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! 18 Wave(10) = tide( 'M4' , 0.000000 , 4 , 4 , -4 , 4 , 0 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) 19 ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! 20 Wave(11) = tide( 'Mf' , 0.042017 , 0 , 0 , 2 , 0 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) 21 Wave(12) = tide( 'Mm' , 0.022191 , 0 , 0 , 1 , 0 , -1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) 22 Wave(13) = tide( 'Msqm' , 0.000667 , 0 , 0 , 4 , -2 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) 23 Wave(14) = tide( 'Mtm' , 0.008049 , 0 , 0 , 3 , 0 , -1 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) 24 ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! 25 Wave(15) = tide( 'S1' , 0.000000 , 1 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) 26 Wave(16) = tide( 'MU2' , 0.005841 , 2 , 2 , -4 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) 27 Wave(17) = tide( 'NU2' , 0.009094 , 2 , 2 , -3 , 4 , -1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) 28 Wave(18) = tide( 'L2' , 0.006694 , 2 , 2 , -1 , 2 , -1 , 0 , +180 , 2 , -2 , 0 , 0 , 0 , 215 ) 29 Wave(19) = tide( 'T2' , 0.006614 , 2 , 2 , 0 , -1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/tide_mod.F90
r3670 r4292 1 1 MODULE tide_mod 2 !!================================================================================= 3 !! *** MODULE tide_mod *** 4 !! Compute nodal modulations corrections and pulsations 5 !!================================================================================= 6 !!--------------------------------------------------------------------------------- 7 !! OPA 9.0 , LODYC-IPSL (2003) 8 !!--------------------------------------------------------------------------------- 9 USE dom_oce ! ocean space and time domain 10 USE phycst 11 USE daymod 12 13 IMPLICIT NONE 14 PRIVATE 15 16 REAL(wp) :: sh_T, sh_s, sh_h, sh_p, sh_p1, & 17 sh_xi, sh_nu, sh_nuprim, sh_nusec, sh_R, & 18 sh_I, sh_x1ra, sh_N 19 20 INTEGER,PUBLIC, PARAMETER :: & 21 jpmax_harmo = 19 ! maximum number of harmonic 22 23 TYPE, PUBLIC :: tide 24 CHARACTER(LEN=4) :: cname_tide 25 REAL(wp) :: equitide 26 INTEGER :: nutide 27 INTEGER :: nt,ns,nh,np,np1,shift 28 INTEGER :: nksi,nnu0,nnu1,nnu2,R 29 INTEGER :: nformula 30 END TYPE tide 31 32 TYPE(tide), PUBLIC, DIMENSION(jpmax_harmo) :: Wave 33 34 !! * Accessibility 35 PUBLIC tide_harmo 36 PUBLIC nodal_factort 37 PUBLIC tide_init_Wave 38 2 !!====================================================================== 3 !! *** MODULE tide_mod *** 4 !! Compute nodal modulations corrections and pulsations 5 !!====================================================================== 6 !! History : 1.0 ! 2007 (O. Le Galloudec) Original code 7 !!---------------------------------------------------------------------- 8 USE dom_oce ! ocean space and time domain 9 USE phycst ! physical constant 10 USE daymod ! calendar 11 12 IMPLICIT NONE 13 PRIVATE 14 15 PUBLIC tide_harmo ! called by tideini and diaharm modules 16 PUBLIC tide_init_Wave ! called by tideini and diaharm modules 17 18 INTEGER, PUBLIC, PARAMETER :: jpmax_harmo = 19 !: maximum number of harmonic 19 20 TYPE, PUBLIC :: tide 21 CHARACTER(LEN=4) :: cname_tide 22 REAL(wp) :: equitide 23 INTEGER :: nutide 24 INTEGER :: nt, ns, nh, np, np1, shift 25 INTEGER :: nksi, nnu0, nnu1, nnu2, R 26 INTEGER :: nformula 27 END TYPE tide 28 29 TYPE(tide), PUBLIC, DIMENSION(jpmax_harmo) :: Wave !: 30 31 REAL(wp) :: sh_T, sh_s, sh_h, sh_p, sh_p1 ! astronomic angles 32 REAL(wp) :: sh_xi, sh_nu, sh_nuprim, sh_nusec, sh_R ! 33 REAL(wp) :: sh_I, sh_x1ra, sh_N ! 34 35 !!---------------------------------------------------------------------- 36 !! NEMO/OPA 3.3 , LOCEAN-IPSL (2010) 37 !! $Id:$ 38 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 39 !!---------------------------------------------------------------------- 39 40 CONTAINS 40 41 41 SUBROUTINE tide_init_Wave 42 43 # include "tide.h90" 44 45 END SUBROUTINE tide_init_Wave 46 47 SUBROUTINE tide_harmo( pomega, pvt, put , pcor, ktide ,kc) 48 49 INTEGER, DIMENSION(kc), INTENT( in ) :: & 50 ktide ! Indice of tidal constituents 51 52 INTEGER, INTENT( in ) :: & 53 kc ! Total number of tidal constituents 54 55 REAL (wp), DIMENSION(kc), INTENT( out ) :: & 56 pomega ! pulsation in radians/s 57 58 REAL (wp), DIMENSION(kc), INTENT( out ) :: & 59 pvt, & ! 60 put, & ! 61 pcor ! 62 63 CALL astronomic_angle 64 CALL tide_pulse(pomega, ktide ,kc) 65 CALL tide_vuf( pvt, put, pcor, ktide ,kc) 66 67 END SUBROUTINE tide_harmo 68 69 SUBROUTINE astronomic_angle 70 71 !!---------------------------------------------------------------------- 72 !! 73 !! tj is time elapsed since 1st January 1900, 0 hour, counted in julian 74 !! century (e.g. time in days divide by 36525) 75 !!---------------------------------------------------------------------- 76 77 REAL(wp) :: cosI,p,q,t2,t4,sin2I,s2,tgI2,P1,sh_tgn2,at1,at2 78 REAL(wp) :: zqy,zsy,zday,zdj,zhfrac 79 80 zqy=AINT((nyear-1901.)/4.) 81 zsy=nyear-1900. 82 83 zdj=dayjul(nyear,nmonth,nday) 84 zday=zdj+zqy-1. 85 86 zhfrac=nsec_day/3600. 87 88 !---------------------------------------------------------------------- 89 ! Sh_n Longitude of ascending lunar node 90 !---------------------------------------------------------------------- 91 92 sh_N=(259.1560564-19.328185764*zsy-.0529539336*zday-.0022064139*zhfrac)*rad 93 !---------------------------------------------------------------------- 94 ! T mean solar angle (Greenwhich time) 95 !---------------------------------------------------------------------- 96 sh_T=(180.+zhfrac*(360./24.))*rad 97 !---------------------------------------------------------------------- 98 ! h mean solar Longitude 99 !---------------------------------------------------------------------- 100 101 sh_h=(280.1895014-.238724988*zsy+.9856473288*zday+.0410686387*zhfrac)*rad 102 !---------------------------------------------------------------------- 103 ! s mean lunar Longitude 104 !---------------------------------------------------------------------- 105 106 sh_s=(277.0256206+129.38482032*zsy+13.176396768*zday+.549016532*zhfrac)*rad 107 !---------------------------------------------------------------------- 108 ! p1 Longitude of solar perigee 109 !---------------------------------------------------------------------- 110 111 sh_p1=(281.2208569+.01717836*zsy+.000047064*zday+.000001961*zhfrac)*rad 112 !---------------------------------------------------------------------- 113 ! p Longitude of lunar perigee 114 !---------------------------------------------------------------------- 115 116 sh_p=(334.3837214+40.66246584*zsy+.111404016*zday+.004641834*zhfrac)*rad 117 118 sh_N =mod(sh_N ,2*rpi) 119 sh_s =mod(sh_s ,2*rpi) 120 sh_h =mod(sh_h, 2*rpi) 121 sh_p =mod(sh_p, 2*rpi) 122 sh_p1=mod(sh_p1,2*rpi) 123 124 cosI=0.913694997 -0.035692561 *cos(sh_N) 125 126 sh_I=acos(cosI) 127 128 sin2I=sin(sh_I) 129 sh_tgn2=tan(sh_N/2.0) 130 131 at1=atan(1.01883*sh_tgn2) 132 at2=atan(0.64412*sh_tgn2) 133 134 sh_xi=-at1-at2+sh_N 135 136 if (sh_N > rpi) sh_xi=sh_xi-2.0*rpi 137 138 sh_nu=at1-at2 139 140 !---------------------------------------------------------------------- 141 ! For constituents l2 k1 k2 142 !---------------------------------------------------------------------- 143 144 tgI2=tan(sh_I/2.0) 145 P1=sh_p-sh_xi 146 147 t2=tgI2*tgI2 148 t4=t2*t2 149 sh_x1ra=sqrt(1.0-12.0*t2*cos(2.0*P1)+36.0*t4) 150 151 p=sin(2.0*P1) 152 q=1.0/(6.0*t2)-cos(2.0*P1) 153 sh_R=atan(p/q) 154 155 p=sin(2.0*sh_I)*sin(sh_nu) 156 q=sin(2.0*sh_I)*cos(sh_nu)+0.3347 157 sh_nuprim=atan(p/q) 158 159 s2=sin(sh_I)*sin(sh_I) 160 p=s2*sin(2.0*sh_nu) 161 q=s2*cos(2.0*sh_nu)+0.0727 162 sh_nusec=0.5*atan(p/q) 163 164 END SUBROUTINE astronomic_angle 165 166 SUBROUTINE tide_pulse( pomega, ktide ,kc) 167 !!---------------------------------------------------------------------- 168 !! *** ROUTINE tide_pulse *** 169 !! 170 !! ** Purpose : Compute tidal frequencies 171 !! 172 !!---------------------------------------------------------------------- 173 !! * Arguments 174 INTEGER, DIMENSION(kc), INTENT( in ) :: & 175 ktide ! Indice of tidal constituents 176 177 INTEGER, INTENT( in ) :: & 178 kc ! Total number of tidal constituents 179 180 REAL (wp), DIMENSION(kc), INTENT( out ) :: & 181 pomega ! pulsation in radians/s 182 183 !! * Local declarations 184 INTEGER :: jh 185 REAL(wp) :: zscale = 36525*24.0 186 REAL(wp) :: zomega_T= 13149000.0 187 REAL(wp) :: zomega_s= 481267.892 188 REAL(wp) :: zomega_h= 36000.76892 189 REAL(wp) :: zomega_p= 4069.0322056 190 REAL(wp) :: zomega_n= 1934.1423972 191 REAL(wp) :: zomega_p1= 1.719175 192 !!---------------------------------------------------------------------- 193 194 DO jh=1,kc 195 pomega(jh) = zomega_T * Wave(ktide(jh))%nT & 196 + zomega_s * Wave(ktide(jh))%ns & 197 + zomega_h * Wave(ktide(jh))%nh & 198 + zomega_p * Wave(ktide(jh))%np & 199 + zomega_p1* Wave(ktide(jh))%np1 200 pomega(jh) = (pomega(jh)/zscale)*rad/3600. 201 END DO 202 203 END SUBROUTINE tide_pulse 204 205 SUBROUTINE tide_vuf( pvt, put, pcor, ktide ,kc) 206 !!---------------------------------------------------------------------- 207 !! *** ROUTINE tide_vuf *** 208 !! 209 !! ** Purpose : Compute nodal modulation corrections 210 !! 211 !! ** Outputs : 212 !! vt: Pase of tidal potential relative to Greenwich (radians) 213 !! ut: Phase correction u due to nodal motion (radians) 214 !! ft: Nodal correction factor 215 !! 216 !! ** Inputs : 217 !! tname: array of constituents names (dimension<=nc) 218 !! nc: number of constituents 219 !! 220 !!---------------------------------------------------------------------- 221 !! * Arguments 222 INTEGER, DIMENSION(kc), INTENT( in ) :: & 223 ktide ! Indice of tidal constituents 224 INTEGER, INTENT( in ) :: & 225 kc ! Total number of tidal constituents 226 REAL (wp), DIMENSION(kc), INTENT( out ) :: & 227 pvt, & ! 228 put, & ! 229 pcor ! 230 !! * Local declarations 231 INTEGER :: jh 232 !!---------------------------------------------------------------------- 233 234 DO jh =1,kc 235 ! Phase of the tidal potential relative to the Greenwhich 236 ! meridian (e.g. the position of the fictuous celestial body). Units are 237 ! radian: 238 pvt(jh) = sh_T *Wave(ktide(jh))%nT & 239 +sh_s *Wave(ktide(jh))%ns & 240 +sh_h *Wave(ktide(jh))%nh & 241 +sh_p *Wave(ktide(jh))%np & 242 +sh_p1*Wave(ktide(jh))%np1 & 243 +Wave(ktide(jh))%shift*rad 42 SUBROUTINE tide_init_Wave 43 # include "tide.h90" 44 END SUBROUTINE tide_init_Wave 45 46 47 SUBROUTINE tide_harmo( pomega, pvt, put , pcor, ktide ,kc) 48 !!---------------------------------------------------------------------- 49 !!---------------------------------------------------------------------- 50 INTEGER , DIMENSION(kc), INTENT(in ) :: ktide ! Indice of tidal constituents 51 INTEGER , INTENT(in ) :: kc ! Total number of tidal constituents 52 REAL(wp), DIMENSION(kc), INTENT(out) :: pomega ! pulsation in radians/s 53 REAL(wp), DIMENSION(kc), INTENT(out) :: pvt, put, pcor ! 54 !!---------------------------------------------------------------------- 55 ! 56 CALL astronomic_angle 57 CALL tide_pulse( pomega, ktide ,kc ) 58 CALL tide_vuf ( pvt, put, pcor, ktide ,kc ) 59 ! 60 END SUBROUTINE tide_harmo 61 62 63 SUBROUTINE astronomic_angle 64 !!---------------------------------------------------------------------- 65 !! tj is time elapsed since 1st January 1900, 0 hour, counted in julian 66 !! century (e.g. time in days divide by 36525) 67 !!---------------------------------------------------------------------- 68 REAL(wp) :: cosI, p, q, t2, t4, sin2I, s2, tgI2, P1, sh_tgn2, at1, at2 69 REAL(wp) :: zqy , zsy, zday, zdj, zhfrac 70 !!---------------------------------------------------------------------- 71 ! 72 zqy = AINT( (nyear-1901.)/4. ) 73 zsy = nyear - 1900. 74 ! 75 zdj = dayjul( nyear, nmonth, nday ) 76 zday = zdj + zqy - 1. 77 ! 78 zhfrac = nsec_day / 3600. 79 ! 80 !---------------------------------------------------------------------- 81 ! Sh_n Longitude of ascending lunar node 82 !---------------------------------------------------------------------- 83 sh_N=(259.1560564-19.328185764*zsy-.0529539336*zday-.0022064139*zhfrac)*rad 84 !---------------------------------------------------------------------- 85 ! T mean solar angle (Greenwhich time) 86 !---------------------------------------------------------------------- 87 sh_T=(180.+zhfrac*(360./24.))*rad 88 !---------------------------------------------------------------------- 89 ! h mean solar Longitude 90 !---------------------------------------------------------------------- 91 sh_h=(280.1895014-.238724988*zsy+.9856473288*zday+.0410686387*zhfrac)*rad 92 !---------------------------------------------------------------------- 93 ! s mean lunar Longitude 94 !---------------------------------------------------------------------- 95 sh_s=(277.0256206+129.38482032*zsy+13.176396768*zday+.549016532*zhfrac)*rad 96 !---------------------------------------------------------------------- 97 ! p1 Longitude of solar perigee 98 !---------------------------------------------------------------------- 99 sh_p1=(281.2208569+.01717836*zsy+.000047064*zday+.000001961*zhfrac)*rad 100 !---------------------------------------------------------------------- 101 ! p Longitude of lunar perigee 102 !---------------------------------------------------------------------- 103 sh_p=(334.3837214+40.66246584*zsy+.111404016*zday+.004641834*zhfrac)*rad 104 105 sh_N = MOD( sh_N ,2*rpi ) 106 sh_s = MOD( sh_s ,2*rpi ) 107 sh_h = MOD( sh_h, 2*rpi ) 108 sh_p = MOD( sh_p, 2*rpi ) 109 sh_p1= MOD( sh_p1,2*rpi ) 110 111 cosI = 0.913694997 -0.035692561 *cos(sh_N) 112 113 sh_I = ACOS( cosI ) 114 115 sin2I = sin(sh_I) 116 sh_tgn2 = tan(sh_N/2.0) 117 118 at1=atan(1.01883*sh_tgn2) 119 at2=atan(0.64412*sh_tgn2) 120 121 sh_xi=-at1-at2+sh_N 122 123 IF( sh_N > rpi ) sh_xi=sh_xi-2.0*rpi 124 125 sh_nu = at1 - at2 126 127 !---------------------------------------------------------------------- 128 ! For constituents l2 k1 k2 129 !---------------------------------------------------------------------- 130 131 tgI2 = tan(sh_I/2.0) 132 P1 = sh_p-sh_xi 133 134 t2 = tgI2*tgI2 135 t4 = t2*t2 136 sh_x1ra = sqrt( 1.0-12.0*t2*cos(2.0*P1)+36.0*t4 ) 137 138 p = sin(2.0*P1) 139 q = 1.0/(6.0*t2)-cos(2.0*P1) 140 sh_R = atan(p/q) 141 142 p = sin(2.0*sh_I)*sin(sh_nu) 143 q = sin(2.0*sh_I)*cos(sh_nu)+0.3347 144 sh_nuprim = atan(p/q) 145 146 s2 = sin(sh_I)*sin(sh_I) 147 p = s2*sin(2.0*sh_nu) 148 q = s2*cos(2.0*sh_nu)+0.0727 149 sh_nusec = 0.5*atan(p/q) 150 ! 151 END SUBROUTINE astronomic_angle 152 153 154 SUBROUTINE tide_pulse( pomega, ktide ,kc ) 155 !!---------------------------------------------------------------------- 156 !! *** ROUTINE tide_pulse *** 157 !! 158 !! ** Purpose : Compute tidal frequencies 159 !!---------------------------------------------------------------------- 160 INTEGER , INTENT(in ) :: kc ! Total number of tidal constituents 161 INTEGER , DIMENSION(kc), INTENT(in ) :: ktide ! Indice of tidal constituents 162 REAL(wp), DIMENSION(kc), INTENT(out) :: pomega ! pulsation in radians/s 163 ! 164 INTEGER :: jh 165 REAL(wp) :: zscale 166 REAL(wp) :: zomega_T = 13149000.0_wp 167 REAL(wp) :: zomega_s = 481267.892_wp 168 REAL(wp) :: zomega_h = 36000.76892_wp 169 REAL(wp) :: zomega_p = 4069.0322056_wp 170 REAL(wp) :: zomega_n = 1934.1423972_wp 171 REAL(wp) :: zomega_p1= 1.719175_wp 172 !!---------------------------------------------------------------------- 173 ! 174 zscale = rad / ( 36525._wp * 86400._wp ) 175 ! 176 DO jh = 1, kc 177 pomega(jh) = ( zomega_T * Wave( ktide(jh) )%nT & 178 & + zomega_s * Wave( ktide(jh) )%ns & 179 & + zomega_h * Wave( ktide(jh) )%nh & 180 & + zomega_p * Wave( ktide(jh) )%np & 181 & + zomega_p1* Wave( ktide(jh) )%np1 ) * zscale 182 END DO 183 ! 184 END SUBROUTINE tide_pulse 185 186 187 SUBROUTINE tide_vuf( pvt, put, pcor, ktide ,kc ) 188 !!---------------------------------------------------------------------- 189 !! *** ROUTINE tide_vuf *** 190 !! 191 !! ** Purpose : Compute nodal modulation corrections 192 !! 193 !! ** Outputs : vt: Phase of tidal potential relative to Greenwich (radians) 194 !! ut: Phase correction u due to nodal motion (radians) 195 !! ft: Nodal correction factor 196 !!---------------------------------------------------------------------- 197 INTEGER , INTENT(in ) :: kc ! Total number of tidal constituents 198 INTEGER , DIMENSION(kc), INTENT(in ) :: ktide ! Indice of tidal constituents 199 REAL(wp), DIMENSION(kc), INTENT(out) :: pvt, put, pcor ! 200 ! 201 INTEGER :: jh ! dummy loop index 202 !!---------------------------------------------------------------------- 203 ! 204 DO jh = 1, kc 205 ! Phase of the tidal potential relative to the Greenwhich 206 ! meridian (e.g. the position of the fictuous celestial body). Units are radian: 207 pvt(jh) = sh_T * Wave( ktide(jh) )%nT & 208 & + sh_s * Wave( ktide(jh) )%ns & 209 & + sh_h * Wave( ktide(jh) )%nh & 210 & + sh_p * Wave( ktide(jh) )%np & 211 & + sh_p1* Wave( ktide(jh) )%np1 & 212 & + Wave( ktide(jh) )%shift * rad 213 ! 214 ! Phase correction u due to nodal motion. Units are radian: 215 put(jh) = sh_xi * Wave( ktide(jh) )%nksi & 216 & + sh_nu * Wave( ktide(jh) )%nnu0 & 217 & + sh_nuprim * Wave( ktide(jh) )%nnu1 & 218 & + sh_nusec * Wave( ktide(jh) )%nnu2 & 219 & + sh_R * Wave( ktide(jh) )%R 220 221 ! Nodal correction factor: 222 pcor(jh) = nodal_factort( Wave( ktide(jh) )%nformula ) 223 END DO 224 ! 225 END SUBROUTINE tide_vuf 226 227 228 RECURSIVE FUNCTION nodal_factort( kformula ) RESULT( zf ) 229 !!---------------------------------------------------------------------- 230 !!---------------------------------------------------------------------- 231 INTEGER, INTENT(in) :: kformula 232 ! 233 REAL(wp) :: zf 234 REAL(wp) :: zs, zf1, zf2 235 !!---------------------------------------------------------------------- 236 ! 237 SELECT CASE( kformula ) 238 ! 239 CASE( 0 ) !== formule 0, solar waves 240 zf = 1.0 241 ! 242 CASE( 1 ) !== formule 1, compound waves (78 x 78) 243 zf=nodal_factort(78) 244 zf = zf * zf 245 ! 246 CASE ( 2 ) !== formule 2, compound waves (78 x 0) === (78) 247 zf1= nodal_factort(78) 248 zf = nodal_factort( 0) 249 zf = zf1 * zf 244 250 ! 245 ! Phase correction u due to nodal motion. Units are radian: 246 put(jh) = sh_xi *Wave(ktide(jh))%nksi & 247 +sh_nu *Wave(ktide(jh))%nnu0 & 248 +sh_nuprim*Wave(ktide(jh))%nnu1 & 249 +sh_nusec *Wave(ktide(jh))%nnu2 & 250 +sh_R *Wave(ktide(jh))%R 251 252 ! Nodal correction factor: 253 pcor(jh) = nodal_factort(Wave(ktide(jh))%nformula) 254 END DO 255 256 END SUBROUTINE tide_vuf 257 258 recursive function nodal_factort(kformula) result (zf) 259 !!---------------------------------------------------------------------- 260 INTEGER, INTENT(IN) :: kformula 261 REAL(wp) :: zf 262 REAL(wp) :: zs,zf1,zf2 263 264 SELECT CASE (kformula) 265 266 !! formule 0, solar waves 267 268 case ( 0 ) 269 zf=1.0 270 271 !! formule 1, compound waves (78 x 78) 272 273 case ( 1 ) 274 zf=nodal_factort(78) 275 zf=zf*zf 276 277 !! formule 2, compound waves (78 x 0) === (78) 278 279 case ( 2 ) 280 zf1=nodal_factort(78) 281 zf=nodal_factort(0) 282 zf=zf1*zf 283 284 !! formule 4, compound waves (78 x 235) 285 286 case ( 4 ) 287 zf1=nodal_factort(78) 288 zf=nodal_factort(235) 289 zf=zf1*zf 290 291 !! formule 5, compound waves (78 *78 x 235) 292 293 case ( 5 ) 294 zf1=nodal_factort(78) 295 zf=nodal_factort(235) 296 zf=zf*zf1*zf1 297 298 !! formule 6, compound waves (78 *78 x 0) 299 300 case ( 6 ) 301 zf1=nodal_factort(78) 302 zf=nodal_factort(0) 303 zf=zf*zf1*zf1 304 305 !! formule 7, compound waves (75 x 75) 306 307 case ( 7 ) 308 zf=nodal_factort(75) 309 zf=zf*zf 310 311 !! formule 8, compound waves (78 x 0 x 235) 312 313 case ( 8 ) 314 zf=nodal_factort(78) 315 zf1=nodal_factort(0) 316 zf2=nodal_factort(235) 317 zf=zf*zf1*zf2 318 319 !! formule 9, compound waves (78 x 0 x 227) 320 321 case ( 9 ) 322 zf=nodal_factort(78) 323 zf1=nodal_factort(0) 324 zf2=nodal_factort(227) 325 zf=zf*zf1*zf2 326 327 !! formule 10, compound waves (78 x 227) 328 329 case ( 10 ) 330 zf=nodal_factort(78) 331 zf1=nodal_factort(227) 332 zf=zf*zf1 333 334 !! formule 11, compound waves (75 x 0) 335 336 case ( 11 ) 337 zf=nodal_factort(75) 338 zf=nodal_factort(0) 339 zf=zf*zf1 340 341 !! formule 12, compound waves (78 x 78 x 78 x 0) 342 343 case ( 12 ) 344 zf1=nodal_factort(78) 345 zf=nodal_factort(0) 346 zf=zf*zf1*zf1*zf1 347 348 !! formule 13, compound waves (78 x 75) 349 350 case ( 13 ) 351 zf1=nodal_factort(78) 352 zf=nodal_factort(75) 353 zf=zf*zf1 354 355 !! formule 14, compound waves (235 x 0) === (235) 356 357 case ( 14 ) 358 zf=nodal_factort(235) 359 zf1=nodal_factort(0) 360 zf=zf*zf1 361 362 !! formule 15, compound waves (235 x 75) 363 364 case ( 15 ) 365 zf=nodal_factort(235) 366 zf1=nodal_factort(75) 367 zf=zf*zf1 368 369 !! formule 16, compound waves (78 x 0 x 0) === (78) 370 371 case ( 16 ) 372 zf=nodal_factort(78) 373 zf1=nodal_factort(0) 374 zf=zf*zf1*zf1 375 376 !! formule 17, compound waves (227 x 0) 377 378 case ( 17 ) 379 zf1=nodal_factort(227) 380 zf=nodal_factort(0) 381 zf=zf*zf1 382 383 !! formule 18, compound waves (78 x 78 x 78 ) 384 385 case ( 18 ) 386 zf1=nodal_factort(78) 387 zf=zf1*zf1*zf1 388 389 !! formule 19, compound waves (78 x 0 x 0 x 0) === (78) 390 391 case ( 19 ) 392 zf=nodal_factort(78) 393 zf1=nodal_factort(0) 394 zf=zf*zf1*zf1 395 396 !! formule 73 397 398 case ( 73 ) 399 zs=sin(sh_I) 400 zf=(2./3.-zs*zs)/0.5021 401 402 !! formule 74 403 404 case ( 74 ) 405 zs=sin(sh_I) 406 zf=zs*zs/0.1578 407 408 !! formule 75 409 410 case ( 75 ) 411 zs=cos (sh_I/2) 412 zf=sin (sh_I)*zs*zs/0.3800 413 414 !! formule 76 415 416 case ( 76 ) 417 zf=sin (2*sh_I)/0.7214 418 419 !! formule 77 420 421 case ( 77 ) 422 zs=sin (sh_I/2) 423 zf=sin (sh_I)*zs*zs/0.0164 424 425 !! formule 78 426 427 case ( 78 ) 428 zs=cos (sh_I/2) 429 zf=zs*zs*zs*zs/0.9154 430 431 !! formule 79 432 433 case ( 79 ) 434 zs=sin(sh_I) 435 zf=zs*zs/0.1565 436 437 !! formule 144 438 439 case ( 144 ) 440 zs=sin (sh_I/2) 441 zf=(1-10*zs*zs+15*zs*zs*zs*zs)*cos(sh_I/2)/0.5873 442 443 !! formule 149 444 445 case ( 149 ) 446 zs=cos (sh_I/2) 447 zf=zs*zs*zs*zs*zs*zs/0.8758 448 449 !! formule 215 450 451 case ( 215 ) 452 zs=cos (sh_I/2) 453 zf=zs*zs*zs*zs/0.9154*sh_x1ra 454 455 !! formule 227 456 457 case ( 227 ) 458 zs=sin (2*sh_I) 459 zf=sqrt (0.8965*zs*zs+0.6001*zs*cos (sh_nu)+0.1006) 460 461 !! formule 235 462 463 case ( 235 ) 464 zs=sin (sh_I) 465 zf=sqrt (19.0444*zs*zs*zs*zs+2.7702*zs*zs*cos (2*sh_nu)+.0981) 466 467 END SELECT 468 469 end function nodal_factort 470 471 function dayjul(kyr,kmonth,kday) 472 ! 473 !*** THIS ROUTINE COMPUTES THE JULIAN DAY (AS A REAL VARIABLE) 474 ! 475 INTEGER,INTENT(IN) :: kyr,kmonth,kday 476 INTEGER,DIMENSION(12) :: idayt,idays 477 INTEGER :: inc,ji 478 REAL(wp) :: dayjul,zyq 479 480 DATA idayt/0.,31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334./ 481 idays(1)=0. 482 idays(2)=31. 483 inc=0. 484 zyq=MOD((kyr-1900.),4.) 485 IF(zyq .eq. 0.) inc=1. 486 DO ji=3,12 487 idays(ji)=idayt(ji)+inc 488 END DO 489 dayjul=idays(kmonth)+kday 490 491 END FUNCTION dayjul 492 251 CASE ( 4 ) !== formule 4, compound waves (78 x 235) 252 zf1 = nodal_factort( 78) 253 zf = nodal_factort(235) 254 zf = zf1 * zf 255 ! 256 CASE ( 5 ) !== formule 5, compound waves (78 *78 x 235) 257 zf1 = nodal_factort( 78) 258 zf = nodal_factort(235) 259 zf = zf * zf1 * zf1 260 ! 261 CASE ( 6 ) !== formule 6, compound waves (78 *78 x 0) 262 zf1 = nodal_factort(78) 263 zf = nodal_factort( 0) 264 zf = zf * zf1 * zf1 265 ! 266 CASE( 7 ) !== formule 7, compound waves (75 x 75) 267 zf = nodal_factort(75) 268 zf = zf * zf 269 ! 270 CASE( 8 ) !== formule 8, compound waves (78 x 0 x 235) 271 zf = nodal_factort( 78) 272 zf1 = nodal_factort( 0) 273 zf2 = nodal_factort(235) 274 zf = zf * zf1 * zf2 275 ! 276 CASE( 9 ) !== formule 9, compound waves (78 x 0 x 227) 277 zf = nodal_factort( 78) 278 zf1 = nodal_factort( 0) 279 zf2 = nodal_factort(227) 280 zf = zf * zf1 * zf2 281 ! 282 CASE( 10 ) !== formule 10, compound waves (78 x 227) 283 zf = nodal_factort( 78) 284 zf1 = nodal_factort(227) 285 zf = zf * zf1 286 ! 287 CASE( 11 ) !== formule 11, compound waves (75 x 0) 288 !!gm bug???? zf 2 fois ! 289 zf = nodal_factort(75) 290 zf = nodal_factort( 0) 291 zf = zf * zf1 292 ! 293 CASE( 12 ) !== formule 12, compound waves (78 x 78 x 78 x 0) 294 zf1 = nodal_factort(78) 295 zf = nodal_factort( 0) 296 zf = zf * zf1 * zf1 * zf1 297 ! 298 CASE( 13 ) !== formule 13, compound waves (78 x 75) 299 zf1 = nodal_factort(78) 300 zf = nodal_factort(75) 301 zf = zf * zf1 302 ! 303 CASE( 14 ) !== formule 14, compound waves (235 x 0) === (235) 304 zf = nodal_factort(235) 305 zf1 = nodal_factort( 0) 306 zf = zf * zf1 307 ! 308 CASE( 15 ) !== formule 15, compound waves (235 x 75) 309 zf = nodal_factort(235) 310 zf1 = nodal_factort( 75) 311 zf = zf * zf1 312 ! 313 CASE( 16 ) !== formule 16, compound waves (78 x 0 x 0) === (78) 314 zf = nodal_factort(78) 315 zf1 = nodal_factort( 0) 316 zf = zf * zf1 * zf1 317 ! 318 CASE( 17 ) !== formule 17, compound waves (227 x 0) 319 zf1 = nodal_factort(227) 320 zf = nodal_factort( 0) 321 zf = zf * zf1 322 ! 323 CASE( 18 ) !== formule 18, compound waves (78 x 78 x 78 ) 324 zf1 = nodal_factort(78) 325 zf = zf1 * zf1 * zf1 326 ! 327 CASE( 19 ) !== formule 19, compound waves (78 x 0 x 0 x 0) === (78) 328 !!gm bug2 ==>>> here identical to formule 16, a third multiplication by zf1 is missing 329 zf = nodal_factort(78) 330 zf1 = nodal_factort( 0) 331 zf = zf * zf1 * zf1 332 ! 333 CASE( 73 ) !== formule 73 334 zs = sin(sh_I) 335 zf = (2./3.-zs*zs)/0.5021 336 ! 337 CASE( 74 ) !== formule 74 338 zs = sin(sh_I) 339 zf = zs * zs / 0.1578 340 ! 341 CASE( 75 ) !== formule 75 342 zs = cos(sh_I/2) 343 zf = sin(sh_I) * zs * zs / 0.3800 344 ! 345 CASE( 76 ) !== formule 76 346 zf = sin(2*sh_I) / 0.7214 347 ! 348 CASE( 77 ) !== formule 77 349 zs = sin(sh_I/2) 350 zf = sin(sh_I) * zs * zs / 0.0164 351 ! 352 CASE( 78 ) !== formule 78 353 zs = cos(sh_I/2) 354 zf = zs * zs * zs * zs / 0.9154 355 ! 356 CASE( 79 ) !== formule 79 357 zs = sin(sh_I) 358 zf = zs * zs / 0.1565 359 ! 360 CASE( 144 ) !== formule 144 361 zs = sin(sh_I/2) 362 zf = ( 1-10*zs*zs+15*zs*zs*zs*zs ) * cos(sh_I/2) / 0.5873 363 ! 364 CASE( 149 ) !== formule 149 365 zs = cos(sh_I/2) 366 zf = zs*zs*zs*zs*zs*zs / 0.8758 367 ! 368 CASE( 215 ) !== formule 215 369 zs = cos(sh_I/2) 370 zf = zs*zs*zs*zs / 0.9154 * sh_x1ra 371 ! 372 CASE( 227 ) !== formule 227 373 zs = sin(2*sh_I) 374 zf = sqrt( 0.8965*zs*zs+0.6001*zs*cos (sh_nu)+0.1006 ) 375 ! 376 CASE ( 235 ) !== formule 235 377 zs = sin(sh_I) 378 zf = sqrt( 19.0444*zs*zs*zs*zs + 2.7702*zs*zs*cos(2*sh_nu) + .0981 ) 379 ! 380 END SELECT 381 ! 382 END FUNCTION nodal_factort 383 384 385 FUNCTION dayjul( kyr, kmonth, kday ) 386 !!---------------------------------------------------------------------- 387 !! *** THIS ROUTINE COMPUTES THE JULIAN DAY (AS A REAL VARIABLE) 388 !!---------------------------------------------------------------------- 389 INTEGER,INTENT(in) :: kyr, kmonth, kday 390 ! 391 INTEGER,DIMENSION(12) :: idayt, idays 392 INTEGER :: inc, ji 393 REAL(wp) :: dayjul, zyq 394 ! 395 DATA idayt/0.,31.,59.,90.,120.,151.,181.,212.,243.,273.,304.,334./ 396 !!---------------------------------------------------------------------- 397 ! 398 idays(1) = 0. 399 idays(2) = 31. 400 inc = 0. 401 zyq = MOD( kyr-1900. , 4. ) 402 IF( zyq == 0.) inc = 1. 403 DO ji = 3, 12 404 idays(ji)=idayt(ji)+inc 405 END DO 406 dayjul = idays(kmonth) + kday 407 ! 408 END FUNCTION dayjul 409 410 !!====================================================================== 493 411 END MODULE tide_mod -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/tideini.F90
r4147 r4292 1 1 MODULE tideini 2 !!================================================================================= 3 !! *** MODULE tideini *** 4 !! Initialization of tidal forcing 5 !! History : 9.0 ! 07 (O. Le Galloudec) Original code 6 !!================================================================================= 7 !! * Modules used 8 USE oce ! ocean dynamics and tracers variables 9 USE dom_oce ! ocean space and time domain 10 USE in_out_manager ! I/O units 11 USE ioipsl ! NetCDF IPSL library 12 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 13 USE phycst 14 USE daymod 15 USE dynspg_oce 16 USE tide_mod 17 USE iom 2 !!====================================================================== 3 !! *** MODULE tideini *** 4 !! Initialization of tidal forcing 5 !!====================================================================== 6 !! History : 1.0 ! 2007 (O. Le Galloudec) Original code 7 !!---------------------------------------------------------------------- 8 USE oce ! ocean dynamics and tracers variables 9 USE dom_oce ! ocean space and time domain 10 USE phycst 11 USE daymod 12 USE dynspg_oce 13 USE tide_mod 14 ! 15 USE iom 16 USE in_out_manager ! I/O units 17 USE ioipsl ! NetCDF IPSL library 18 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 18 19 19 IMPLICIT NONE20 PUBLIC20 IMPLICIT NONE 21 PUBLIC 21 22 22 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: & 23 omega_tide, & 24 v0tide, & 25 utide, & 26 ftide 23 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: omega_tide !: 24 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: v0tide !: 25 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: utide !: 26 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: ftide !: 27 27 28 LOGICAL, PUBLIC :: ln_tide_pot , ln_tide_ramp 29 REAL(wp), PUBLIC :: rdttideramp 30 INTEGER, PUBLIC :: nb_harmo 31 INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:) :: ntide 32 INTEGER, PUBLIC :: kt_tide 28 LOGICAL , PUBLIC :: ln_tide_pot !: 29 LOGICAL , PUBLIC :: ln_tide_ramp !: 30 INTEGER , PUBLIC :: nb_harmo !: 31 INTEGER , PUBLIC :: kt_tide !: 32 REAL(wp), PUBLIC :: rdttideramp !: 33 34 INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: ntide !: 33 35 34 !!--------------------------------------------------------------------------------- 35 !! OPA 9.0 , LODYC-IPSL (2003) 36 !!--------------------------------------------------------------------------------- 37 36 !!---------------------------------------------------------------------- 37 !! NEMO/OPA 3.5 , NEMO Consortium (2013) 38 !! $Id: $ 39 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 40 !!---------------------------------------------------------------------- 38 41 CONTAINS 39 42 … … 72 75 ! 73 76 nb_harmo=0 74 DO jk=1,jpmax_harmo 75 DO ji=1,jpmax_harmo 76 IF(TRIM(clname(jk)) .eq. Wave(ji)%cname_tide) THEN 77 nb_harmo=nb_harmo+1 78 ENDIF 77 DO jk = 1, jpmax_harmo 78 DO ji = 1,jpmax_harmo 79 IF( TRIM(clname(jk)) == Wave(ji)%cname_tide ) nb_harmo = nb_harmo + 1 79 80 END DO 80 END DO81 END DO 81 82 ! 82 83 IF(lwp) THEN 83 WRITE(numout,*) ' Namelist nam_tide' 84 WRITE(numout,*) ' nb_harmo = ', nb_harmo 85 WRITE(numout,*) ' ln_tide_ramp = ', ln_tide_ramp 86 WRITE(numout,*) ' rdttideramp = ', rdttideramp 87 IF (ln_tide_ramp.AND.((nitend-nit000+1)*rdt/rday < rdttideramp)) & 88 & CALL ctl_stop('rdttideramp must be lower than run duration') 89 IF (ln_tide_ramp.AND.(rdttideramp<0.)) & 90 & CALL ctl_stop('rdttideramp must be positive') 91 CALL flush(numout) 84 WRITE(numout,*) ' Namelist nam_tide' 85 WRITE(numout,*) ' Apply astronomical potential : ln_tide_pot =', ln_tide_pot 86 WRITE(numout,*) ' nb_harmo = ', nb_harmo 87 WRITE(numout,*) ' ln_tide_ramp = ', ln_tide_ramp 88 WRITE(numout,*) ' rdttideramp = ', rdttideramp 92 89 ENDIF 90 IF( ln_tide_ramp.AND.((nitend-nit000+1)*rdt/rday < rdttideramp) ) & 91 & CALL ctl_stop('rdttideramp must be lower than run duration') 92 IF( ln_tide_ramp.AND.(rdttideramp<0.) ) & 93 & CALL ctl_stop('rdttideramp must be positive') 93 94 ! 94 ALLOCATE(ntide(nb_harmo)) 95 DO jk=1,nb_harmo 96 DO ji=1,jpmax_harmo 97 IF (TRIM(clname(jk)) .eq. Wave(ji)%cname_tide) THEN 95 IF( .NOT. lk_dynspg_ts ) CALL ctl_warn( 'sbc_tide : use of time splitting is recommended' ) 96 ! 97 ALLOCATE( ntide(nb_harmo) ) 98 DO jk = 1, nb_harmo 99 DO ji = 1, jpmax_harmo 100 IF( TRIM(clname(jk)) .eq. Wave(ji)%cname_tide ) THEN 98 101 ntide(jk) = ji 99 102 EXIT … … 102 105 END DO 103 106 ! 104 ALLOCATE(omega_tide(nb_harmo)) 105 ALLOCATE(v0tide (nb_harmo)) 106 ALLOCATE(utide (nb_harmo)) 107 ALLOCATE(ftide (nb_harmo)) 107 ALLOCATE( omega_tide(nb_harmo), v0tide (nb_harmo), & 108 & utide (nb_harmo), ftide (nb_harmo) ) 108 109 kt_tide = kt 109 110 ! 110 ENDIF 111 112 IF ( nsec_day == NINT(0.5 * rdttra(1)) ) THEN 113 ! 114 IF(lwp) THEN 115 WRITE(numout,*) 116 WRITE(numout,*) 'tide_ini : Update of the tidal components at kt=',kt 117 WRITE(numout,*) '~~~~~~~~ ' 118 ENDIF 119 CALL tide_harmo(omega_tide, v0tide, utide, ftide, ntide, nb_harmo) 120 DO jk =1,nb_harmo 121 IF(lwp) WRITE(numout,*) Wave(ntide(jk))%cname_tide,utide(jk),ftide(jk),v0tide(jk),omega_tide(jk) 122 call flush(numout) 123 END DO 124 ! 125 kt_tide = kt 126 ! 127 ENDIF 128 129 END SUBROUTINE tide_init 130 111 ENDIF 112 ! 113 END SUBROUTINE tide_init 114 115 !!====================================================================== 131 116 END MODULE tideini -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/SBC/updtide.F90
r3651 r4292 1 1 MODULE updtide 2 !!================================================================================= 3 !! *** MODULE updtide *** 4 !! Initialization of tidal forcing 5 !! History : 9.0 ! 07 (O. Le Galloudec) Original code 6 !!================================================================================= 2 !!====================================================================== 3 !! *** MODULE updtide *** 4 !! Initialization of tidal forcing 5 !!====================================================================== 6 !! History : 9.0 ! 07 (O. Le Galloudec) Original code 7 !!---------------------------------------------------------------------- 7 8 #if defined key_tide 8 !! * Modules used 9 USE oce ! ocean dynamics and tracers variables 10 USE dom_oce ! ocean space and time domain 11 USE in_out_manager ! I/O units 12 USE phycst 13 USE sbctide 14 USE dynspg_oce 15 USE tideini, ONLY: ln_tide_ramp, rdttideramp 9 !!---------------------------------------------------------------------- 10 !! 'key_tide' : tidal potential 11 !!---------------------------------------------------------------------- 12 !! upd_tide : update tidal potential 13 !!---------------------------------------------------------------------- 14 USE oce ! ocean dynamics and tracers variables 15 USE dom_oce ! ocean space and time domain 16 USE in_out_manager ! I/O units 17 USE phycst ! physical constant 18 USE sbctide ! tide potential variable 19 USE tideini, ONLY: ln_tide_ramp, rdttideramp 16 20 17 IMPLICIT NONE18 PUBLIC21 IMPLICIT NONE 22 PUBLIC 19 23 20 !! * Routine accessibility 21 PUBLIC upd_tide 22 !!--------------------------------------------------------------------------------- 23 !! OPA 9.0 , LODYC-IPSL (2003) 24 !!--------------------------------------------------------------------------------- 25 24 PUBLIC upd_tide ! called in dynspg_... modules 25 26 !!---------------------------------------------------------------------- 27 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 28 !! $Id: sbcfwb.F90 3625 2012-11-21 13:19:18Z acc $ 29 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 30 !!---------------------------------------------------------------------- 26 31 CONTAINS 27 32 28 SUBROUTINE upd_tide (kt,kit) 29 !!---------------------------------------------------------------------- 30 !! *** ROUTINE upd_tide *** 31 !!---------------------------------------------------------------------- 32 !! * Local declarations 33 SUBROUTINE upd_tide( kt, kit, kbaro, koffset ) 34 !!---------------------------------------------------------------------- 35 !! *** ROUTINE upd_tide *** 36 !! 37 !! ** Purpose : provide at each time step the astronomical potential 38 !! 39 !! ** Method : computed from pulsation and amplitude of all tide components 40 !! 41 !! ** Action : pot_astro actronomical potential 42 !!---------------------------------------------------------------------- 43 INTEGER, INTENT(in) :: kt ! ocean time-step index 44 INTEGER, INTENT(in), OPTIONAL :: kit ! external mode sub-time-step index (lk_dynspg_ts=T only) 45 INTEGER, INTENT(in), OPTIONAL :: kbaro ! number of sub-time-step (lk_dynspg_ts=T only) 46 INTEGER, INTENT(in), OPTIONAL :: koffset ! time offset in number 47 ! of sub-time-steps (lk_dynspg_ts=T only) 48 ! 49 INTEGER :: joffset ! local integer 50 INTEGER :: ji, jj, jk ! dummy loop indices 51 REAL(wp) :: zt, zramp ! local scalar 52 REAL(wp), DIMENSION(nb_harmo) :: zwt 53 !!---------------------------------------------------------------------- 54 ! 55 ! ! tide pulsation at model time step (or sub-time-step) 56 zt = ( kt - kt_tide ) * rdt 57 ! 58 joffset = 0 59 IF( PRESENT( koffset ) ) joffset = koffset 60 ! 61 IF( PRESENT( kit ) .AND. PRESENT( kbaro ) ) THEN 62 zt = zt + ( kit + 0.5_wp * ( joffset - 1 ) ) * rdt / REAL( kbaro, wp ) 63 ELSE 64 zt = zt + joffset * rdt 65 ENDIF 66 ! 67 zwt(:) = omega_tide(:) * zt 33 68 34 INTEGER, INTENT( in ) :: kt,kit ! ocean time-step index 35 INTEGER :: ji,jj,jk 36 REAL (wp) :: zramp 37 REAL (wp), DIMENSION(nb_harmo) :: zwt 38 !............................................................................... 39 40 pot_astro(:,:)=0.e0 41 zramp = 1.e0 42 43 IF (lk_dynspg_ts) THEN 44 zwt(:) = omega_tide(:)* ((kt-kt_tide)*rdt + kit*(rdt/REAL(nn_baro,wp))) 45 IF (ln_tide_ramp) THEN 46 zramp = MIN(MAX( ((kt-nit000)*rdt + kit*(rdt/REAL(nn_baro,wp)))/(rdttideramp*rday),0.),1.) 47 ENDIF 48 ELSE 49 zwt(:) = omega_tide(:)*(kt-kt_tide)*rdt 50 IF (ln_tide_ramp) THEN 51 zramp = MIN(MAX( ((kt-nit000)*rdt)/(rdttideramp*rday),0.),1.) 52 ENDIF 53 ENDIF 54 55 do jk=1,nb_harmo 56 do ji=1,jpi 57 do jj=1,jpj 58 pot_astro(ji,jj)=pot_astro(ji,jj) + zramp*(amp_pot(ji,jj,jk)*COS(zwt(jk)+phi_pot(ji,jj,jk))) 59 enddo 60 enddo 61 enddo 62 63 END SUBROUTINE upd_tide 69 pot_astro(:,:) = 0._wp ! update tidal potential (sum of all harmonics) 70 DO jk = 1, nb_harmo 71 pot_astro(:,:) = pot_astro(:,:) + amp_pot(:,:,jk) * COS( zwt(jk) + phi_pot(:,:,jk) ) 72 END DO 73 ! 74 IF( ln_tide_ramp ) THEN ! linear increase if asked 75 zt = ( kt - nit000 ) * rdt 76 IF( PRESENT( kit ) .AND. PRESENT( kbaro ) ) zt = zt + kit * rdt / REAL( kbaro, wp ) 77 zramp = MIN( MAX( zt / (rdttideramp*rday) , 0._wp ) , 1._wp ) 78 pot_astro(:,:) = zramp * pot_astro(:,:) 79 ENDIF 80 ! 81 END SUBROUTINE upd_tide 64 82 65 83 #else … … 68 86 !!---------------------------------------------------------------------- 69 87 CONTAINS 70 SUBROUTINE upd_tide( kt,kit ) ! Empty routine 71 INTEGER,INTENT (IN) :: kt, kit 88 SUBROUTINE upd_tide( kt, kit, kbaro, koffset ) ! Empty routine 89 INTEGER, INTENT(in) :: kt ! integer arg, dummy routine 90 INTEGER, INTENT(in), OPTIONAL :: kit ! optional arg, dummy routine 91 INTEGER, INTENT(in), OPTIONAL :: kbaro ! optional arg, dummy routine 92 INTEGER, INTENT(in), OPTIONAL :: koffset ! optional arg, dummy routine 72 93 WRITE(*,*) 'upd_tide: You should not have seen this print! error?', kt 73 94 END SUBROUTINE upd_tide -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90
r4162 r4292 74 74 CONTAINS 75 75 76 SUBROUTINE eos_insitu( pts, prd )76 SUBROUTINE eos_insitu( pts, prd, pdep ) 77 77 !!---------------------------------------------------------------------- 78 78 !! *** ROUTINE eos_insitu *** … … 114 114 ! ! 2 : salinity [psu] 115 115 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] 116 REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdep ! depth [m] 116 117 !! 117 118 INTEGER :: ji, jj, jk ! dummy loop indices … … 140 141 zt = pts (ji,jj,jk,jp_tem) 141 142 zs = pts (ji,jj,jk,jp_sal) 142 zh = fsdept(ji,jj,jk) ! depth143 zh = pdep(ji,jj,jk) ! depth 143 144 zsr= zws (ji,jj,jk) ! square root salinity 144 145 ! … … 198 199 199 200 200 SUBROUTINE eos_insitu_pot( pts, prd, prhop )201 SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 201 202 !!---------------------------------------------------------------------- 202 203 !! *** ROUTINE eos_insitu_pot *** … … 249 250 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] 250 251 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prhop ! potential density (surface referenced) 252 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] 251 253 ! 252 254 INTEGER :: ji, jj, jk ! dummy loop indices … … 271 273 zt = pts (ji,jj,jk,jp_tem) 272 274 zs = pts (ji,jj,jk,jp_sal) 273 zh = fsdept(ji,jj,jk) ! depth275 zh = pdep(ji,jj,jk) ! depth 274 276 zsr= zws (ji,jj,jk) ! square root salinity 275 277 ! -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90
r4245 r4292 15 15 USE oce ! ocean dynamics and active tracers 16 16 USE dom_oce ! ocean space and time domain 17 USE domvvl ! variable vertical scale factors 17 18 USE traadv_cen2 ! 2nd order centered scheme (tra_adv_cen2 routine) 18 19 USE traadv_tvd ! TVD scheme (tra_adv_tvd routine) … … 94 95 zwn(:,:,jk) = e1t(:,:) * e2t(:,:) * wn(:,:,jk) 95 96 END DO 97 ! 98 IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN 99 zun(:,:,:) = zun(:,:,:) + un_td(:,:,:) 100 zvn(:,:,:) = zvn(:,:,:) + vn_td(:,:,:) 101 ENDIF 102 ! 96 103 zun(:,:,jpk) = 0._wp ! no transport trough the bottom 97 104 zvn(:,:,jpk) = 0._wp ! no transport trough the bottom -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90
r4147 r4292 66 66 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahu_bbl_0, ahv_bbl_0 ! diffusive bbl flux coefficients at u and v-points 67 67 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: e3u_bbl_0, e3v_bbl_0 ! thichness of the bbl (e3) at u and v-points (PUBLIC for TAM) 68 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:), PUBLIC :: r1_e1e2t ! inverse of the cell surface at t-point [1/m2] (PUBLIC for TAM)69 68 70 69 !! * Substitutions … … 85 84 & vtr_bbl (jpi,jpj) , ahv_bbl (jpi,jpj) , mbkv_d (jpi,jpj) , mgrhv(jpi,jpj) , & 86 85 & ahu_bbl_0(jpi,jpj) , ahv_bbl_0(jpi,jpj) , & 87 & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , r1_e1e2t(jpi,jpj) , STAT= tra_bbl_alloc)86 & e3u_bbl_0(jpi,jpj) , e3v_bbl_0(jpi,jpj) , STAT= tra_bbl_alloc ) 88 87 ! 89 88 IF( lk_mpp ) CALL mpp_sum ( tra_bbl_alloc ) … … 217 216 # endif 218 217 ik = mbkt(ji,jj) ! bottom T-level index 219 zbtr = r1_e1 e2t(ji,jj) / fse3t(ji,jj,ik)218 zbtr = r1_e12t(ji,jj) / fse3t(ji,jj,ik) 220 219 pta(ji,jj,ik,jn) = pta(ji,jj,ik,jn) & 221 220 & + ( ahu_bbl(ji ,jj ) * ( zptb(ji+1,jj ) - zptb(ji ,jj ) ) & … … 279 278 ! 280 279 ! ! up -slope T-point (shelf bottom point) 281 zbtr = r1_e1 e2t(iis,jj) / fse3t(iis,jj,ikus)280 zbtr = r1_e12t(iis,jj) / fse3t(iis,jj,ikus) 282 281 ztra = zu_bbl * ( ptb(iid,jj,ikus,jn) - ptb(iis,jj,ikus,jn) ) * zbtr 283 282 pta(iis,jj,ikus,jn) = pta(iis,jj,ikus,jn) + ztra 284 283 ! 285 284 DO jk = ikus, ikud-1 ! down-slope upper to down T-point (deep column) 286 zbtr = r1_e1 e2t(iid,jj) / fse3t(iid,jj,jk)285 zbtr = r1_e12t(iid,jj) / fse3t(iid,jj,jk) 287 286 ztra = zu_bbl * ( ptb(iid,jj,jk+1,jn) - ptb(iid,jj,jk,jn) ) * zbtr 288 287 pta(iid,jj,jk,jn) = pta(iid,jj,jk,jn) + ztra 289 288 END DO 290 289 ! 291 zbtr = r1_e1 e2t(iid,jj) / fse3t(iid,jj,ikud)290 zbtr = r1_e12t(iid,jj) / fse3t(iid,jj,ikud) 292 291 ztra = zu_bbl * ( ptb(iis,jj,ikus,jn) - ptb(iid,jj,ikud,jn) ) * zbtr 293 292 pta(iid,jj,ikud,jn) = pta(iid,jj,ikud,jn) + ztra … … 301 300 ! 302 301 ! up -slope T-point (shelf bottom point) 303 zbtr = r1_e1 e2t(ji,ijs) / fse3t(ji,ijs,ikvs)302 zbtr = r1_e12t(ji,ijs) / fse3t(ji,ijs,ikvs) 304 303 ztra = zv_bbl * ( ptb(ji,ijd,ikvs,jn) - ptb(ji,ijs,ikvs,jn) ) * zbtr 305 304 pta(ji,ijs,ikvs,jn) = pta(ji,ijs,ikvs,jn) + ztra 306 305 ! 307 306 DO jk = ikvs, ikvd-1 ! down-slope upper to down T-point (deep column) 308 zbtr = r1_e1 e2t(ji,ijd) / fse3t(ji,ijd,jk)307 zbtr = r1_e12t(ji,ijd) / fse3t(ji,ijd,jk) 309 308 ztra = zv_bbl * ( ptb(ji,ijd,jk+1,jn) - ptb(ji,ijd,jk,jn) ) * zbtr 310 309 pta(ji,ijd,jk,jn) = pta(ji,ijd,jk,jn) + ztra 311 310 END DO 312 311 ! ! down-slope T-point (deep bottom point) 313 zbtr = r1_e1 e2t(ji,ijd) / fse3t(ji,ijd,ikvd)312 zbtr = r1_e12t(ji,ijd) / fse3t(ji,ijd,ikvd) 314 313 ztra = zv_bbl * ( ptb(ji,ijs,ikvs,jn) - ptb(ji,ijd,ikvd,jn) ) * zbtr 315 314 pta(ji,ijd,ikvd,jn) = pta(ji,ijd,ikvd,jn) + ztra … … 423 422 ztb (ji,jj) = tsb(ji,jj,ik,jp_tem) * tmask(ji,jj,1) ! bottom before T and S 424 423 zsb (ji,jj) = tsb(ji,jj,ik,jp_sal) * tmask(ji,jj,1) 425 zdep(ji,jj) = fsdept_0(ji,jj,ik)! bottom T-level reference depth424 zdep(ji,jj) = gdept_0(ji,jj,ik) ! bottom T-level reference depth 426 425 ! 427 426 zub(ji,jj) = un(ji,jj,mbku(ji,jj)) ! bottom velocity … … 601 600 IF( nn_eos /= 0 ) CALL ctl_stop ( ' bbl parameterisation requires eos = 0. We stop.' ) 602 601 603 604 ! !* inverse of surface of T-cells605 r1_e1e2t(:,:) = 1._wp / ( e1t(:,:) * e2t(:,:) )606 607 602 ! !* vertical index of "deep" bottom u- and v-points 608 603 DO jj = 1, jpjm1 ! (the "shelf" bottom k-indices are mbku and mbkv) … … 612 607 END DO 613 608 END DO 614 ! convert einto REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk609 ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk 615 610 zmbk(:,:) = REAL( mbku_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'U',1.) ; mbku_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 616 611 zmbk(:,:) = REAL( mbkv_d(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv_d(:,:) = MAX( INT( zmbk(:,:) ), 1 ) 617 612 618 613 !* sign of grad(H) at u- and v-points 619 614 mgrhu(jpi,:) = 0. ; mgrhu(:,jpj) = 0. ; mgrhv(jpi,:) = 0. ; mgrhv(:,jpj) = 0. 620 615 DO jj = 1, jpjm1 621 616 DO ji = 1, jpim1 622 mgrhu(ji,jj) = INT( SIGN( 1.e0, fsdept_0(ji+1,jj,mbkt(ji+1,jj)) - fsdept_0(ji,jj,mbkt(ji,jj)) ) )623 mgrhv(ji,jj) = INT( SIGN( 1.e0, fsdept_0(ji,jj+1,mbkt(ji,jj+1)) - fsdept_0(ji,jj,mbkt(ji,jj)) ) )617 mgrhu(ji,jj) = INT( SIGN( 1.e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) 618 mgrhv(ji,jj) = INT( SIGN( 1.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) 624 619 END DO 625 620 END DO 626 621 627 622 DO jj = 1, jpjm1 !* bbl thickness at u- (v-) point 628 DO ji = 1, jpim1 629 e3u_bbl_0(ji,jj) = MIN( fse3u_0(ji,jj,mbkt(ji+1,jj )), fse3u_0(ji,jj,mbkt(ji,jj)) )630 e3v_bbl_0(ji,jj) = MIN( fse3v_0(ji,jj,mbkt(ji ,jj+1)), fse3v_0(ji,jj,mbkt(ji,jj)) )623 DO ji = 1, jpim1 ! minimum of top & bottom e3u_0 (e3v_0) 624 e3u_bbl_0(ji,jj) = MIN( e3u_0(ji,jj,mbkt(ji+1,jj )), e3u_0(ji,jj,mbkt(ji,jj)) ) 625 e3v_bbl_0(ji,jj) = MIN( e3v_0(ji,jj,mbkt(ji ,jj+1)), e3v_0(ji,jj,mbkt(ji,jj)) ) 631 626 END DO 632 627 END DO -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90
r4247 r4292 795 795 clname = 'dist.coast' 796 796 itime = 0 797 CALL ymds2ju( 0 , 1 , 1 , 0._wp , zdate0 )798 CALL restini( 'NONE', jpi , jpj , glamt, gphit , &799 & jpk , gdept_ 0, clname, itime, zdate0, &797 CALL ymds2ju( 0 , 1 , 1 , 0._wp , zdate0 ) 798 CALL restini( 'NONE', jpi , jpj , glamt, gphit , & 799 & jpk , gdept_1d, clname, itime, zdate0, & 800 800 & rdt , icot ) 801 801 CALL restput( icot, 'Tcoast', jpi, jpj, jpk, 0, pdct ) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90
r3294 r4292 110 110 DO jj = 1, jpjm1 111 111 DO ji = 1, fs_jpim1 ! vector opt. 112 zeeu(ji,jj) = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) * umask(ji,jj,jk)113 zeev(ji,jj) = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) * vmask(ji,jj,jk)112 zeeu(ji,jj) = re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) * umask(ji,jj,jk) 113 zeev(ji,jj) = re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) * vmask(ji,jj,jk) 114 114 END DO 115 115 END DO … … 133 133 DO jj = 2, jpjm1 ! Second derivative (divergence) time the eddy diffusivity coefficient 134 134 DO ji = fs_2, fs_jpim1 ! vector opt. 135 zbtr = 1.0 / ( e1 t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )135 zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 136 136 zlt(ji,jj) = fsahtt(ji,jj,jk) * zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & 137 137 & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) … … 151 151 DO ji = fs_2, fs_jpim1 ! vector opt. 152 152 ! horizontal diffusive trends 153 zbtr = 1.0 / ( e1 t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )153 zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 154 154 ztra = zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) 155 155 ! add it to the general tracer trends -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90
r3805 r4292 210 210 DO jj = 1, jpjm1 211 211 DO ji = 1, jpim1 212 zabe1 = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj)213 zabe2 = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj)212 zabe1 = re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 213 zabe2 = re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 214 214 215 215 zmku = 1./MAX( tmask(ji+1,jj,jk )+tmask(ji,jj,jk+1) & … … 279 279 DO jk = 2, jpkm1 280 280 DO ji = 2, jpim1 281 zcof0 = e1 t(ji,jj) * e2t(ji,jj) / fse3w(ji,jj,jk) &281 zcof0 = e12t(ji,jj) / fse3w_n(ji,jj,jk) & 282 282 & * ( wslpi(ji,jj,jk) * wslpi(ji,jj,jk) & 283 283 & + wslpj(ji,jj,jk) * wslpj(ji,jj,jk) ) … … 310 310 DO ji = 2, jpim1 311 311 ! eddy coef. divided by the volume element 312 zbtr = 1.0 / ( e1 t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )312 zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 313 313 ! vertical divergence 314 314 ztav = fsahtt(ji,jj,jk) * ( zftw(ji,jk) - zftw(ji,jk+1) ) … … 322 322 DO ji = 2, jpim1 323 323 ! inverse of the volume element 324 zbtr = 1.0 / ( e1 t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )324 zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 325 325 ! vertical divergence 326 326 ztav = zftw(ji,jk) - zftw(ji,jk+1) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
r3805 r4292 176 176 DO jj = 1 , jpjm1 177 177 DO ji = 1, fs_jpim1 ! vector opt. 178 zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj)179 zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj)178 zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 179 zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 180 180 ! 181 181 zmsku = 1. / MAX( tmask(ji+1,jj,jk ) + tmask(ji,jj,jk+1) & … … 201 201 DO jj = 2 , jpjm1 202 202 DO ji = fs_2, fs_jpim1 ! vector opt. 203 zbtr = 1.0 / ( e1 t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )203 zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 204 204 ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) 205 205 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra … … 288 288 DO jj = 2, jpjm1 289 289 DO ji = fs_2, fs_jpim1 ! vector opt. 290 zbtr = 1.0 / ( e1 t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )290 zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 291 291 ztra = ( ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1) ) * zbtr 292 292 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90
r3294 r4292 31 31 32 32 PUBLIC tra_ldf_lap ! routine called by step.F90 33 34 REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) :: e1ur, e2vr ! scale factor coefficients35 33 36 34 !! * Substitutions … … 85 83 IF(lwp) WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype 86 84 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' 87 !88 IF( .NOT. ALLOCATED( e1ur ) ) THEN89 ! This routine may be called for both active and passive tracers.90 ! Allocate and set saved arrays on first call only.91 ALLOCATE( e1ur(jpi,jpj), e2vr(jpi,jpj), STAT=ierr )92 IF( lk_mpp ) CALL mpp_sum( ierr )93 IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'tra_ldf_lap : unable to allocate arrays' )94 !95 e1ur(:,:) = e2u(:,:) / e1u(:,:)96 e2vr(:,:) = e1v(:,:) / e2v(:,:)97 ENDIF98 85 ENDIF 99 86 … … 107 94 DO jj = 1, jpjm1 108 95 DO ji = 1, fs_jpim1 ! vector opt. 109 zabe1 = fsahtu(ji,jj,jk) * umask(ji,jj,jk) * e1ur(ji,jj) * fse3u(ji,jj,jk)110 zabe2 = fsahtv(ji,jj,jk) * vmask(ji,jj,jk) * e2vr(ji,jj) * fse3v(ji,jj,jk)96 zabe1 = fsahtu(ji,jj,jk) * umask(ji,jj,jk) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 97 zabe2 = fsahtv(ji,jj,jk) * vmask(ji,jj,jk) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 111 98 ztu(ji,jj,jk) = zabe1 * ( ptb(ji+1,jj ,jk,jn) - ptb(ji,jj,jk,jn) ) 112 99 ztv(ji,jj,jk) = zabe2 * ( ptb(ji ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) … … 120 107 ikv = mbkv(ji,jj) 121 108 IF( iku == jk ) THEN 122 zabe1 = fsahtu(ji,jj,iku) * umask(ji,jj,iku) * e1ur(ji,jj) * fse3u(ji,jj,iku)109 zabe1 = fsahtu(ji,jj,iku) * umask(ji,jj,iku) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,iku) 123 110 ztu(ji,jj,jk) = zabe1 * pgu(ji,jj,jn) 124 111 ENDIF 125 112 IF( ikv == jk ) THEN 126 zabe2 = fsahtv(ji,jj,ikv) * vmask(ji,jj,ikv) * e2vr(ji,jj) * fse3v(ji,jj,ikv)113 zabe2 = fsahtv(ji,jj,ikv) * vmask(ji,jj,ikv) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,ikv) 127 114 ztv(ji,jj,jk) = zabe2 * pgv(ji,jj,jn) 128 115 ENDIF … … 136 123 DO jj = 2, jpjm1 137 124 DO ji = fs_2, fs_jpim1 ! vector opt. 138 zbtr = 1._wp / ( e1 t(ji,jj) *e2t(ji,jj) * fse3t(ji,jj,jk) )125 zbtr = 1._wp / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 139 126 ! horizontal diffusive trends added to the general tracer trends 140 127 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zbtr * ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90
r4207 r4292 466 466 ENDIF 467 467 468 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_ 0(nksr+1), ' m'468 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 469 469 ! 470 470 IF( nn_chldta == 1 ) THEN !* Chl data : set sf_chl structure … … 507 507 !CDIR NOVERRCHK 508 508 DO ji = 1, jpi 509 zc0 = ze0(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * xsi0r )510 zc1 = ze1(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * zekb(ji,jj) )511 zc2 = ze2(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * zekg(ji,jj) )512 zc3 = ze3(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * zekr(ji,jj) )509 zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * xsi0r ) 510 zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekb(ji,jj) ) 511 zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekg(ji,jj) ) 512 zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_0(ji,jj,jk-1) * zekr(ji,jj) ) 513 513 ze0(ji,jj,jk) = zc0 514 514 ze1(ji,jj,jk) = zc1 … … 536 536 IF(lwp) THEN 537 537 WRITE(numout,*) 538 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_ 0(nksr+1), ' m'538 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 539 539 ENDIF 540 540 ! -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfini.F90
r4147 r4292 154 154 ELSE ! Background profile of avt (fit a theoretical/observational profile (Krauss 1990) 155 155 avmb(:) = rn_avm0 156 avtb(:) = rn_avt0 + ( 3.e-4_wp - 2._wp * rn_avt0 ) * 1.e-4_wp * gdepw_ 0(:) ! m2/s156 avtb(:) = rn_avt0 + ( 3.e-4_wp - 2._wp * rn_avt0 ) * 1.e-4_wp * gdepw_1d(:) ! m2/s 157 157 IF(ln_sco .AND. lwp) CALL ctl_warn( 'avtb profile not valid in sco' ) 158 158 ENDIF -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r4289 r4292 385 385 CALL istate_init ! ocean initial state (Dynamics and tracers) 386 386 387 IF( lk_tide ) CALL tide_init( nit000 ) ! Initialisation of the tidal harmonics 388 389 IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation 390 IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays 391 IF( lk_bdy ) CALL bdytide_init ! Open boundaries initialisation of tidal harmonic forcing 387 IF( lk_tide ) CALL tide_init( nit000 ) ! Initialisation of the tidal harmonics 388 389 IF( lk_bdy ) CALL bdy_init ! Open boundaries initialisation 390 IF( lk_bdy ) CALL bdy_dta_init ! Open boundaries initialisation of external data arrays 391 IF( lk_bdy .AND. lk_tide ) & 392 & CALL bdytide_init ! Open boundaries initialisation of tidal harmonic forcing 392 393 393 394 CALL dyn_nept_init ! simplified form of Neptune effect -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/oce.F90
r4205 r4292 22 22 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ub , un , ua !: i-horizontal velocity [m/s] 23 23 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vb , vn , va !: j-horizontal velocity [m/s] 24 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ua_sv, va_sv !: Saved trends (time spliting) [m/s2] 24 25 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wn !: vertical velocity [m/s] 25 26 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: rotb , rotn !: relative vorticity [s-1] … … 36 37 !! ------------ ! fields ! fields ! trends ! 37 38 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:), TARGET :: sshb , sshn , ssha !: sea surface height at t-point [m] 38 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshu_b , sshu_n , sshu_a !: sea surface height at u-point [m]39 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshv_b , sshv_n , sshv_a !: sea surface height at u-point [m]40 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshf_n !: sea surface height at f-point [m]41 39 ! 42 40 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spgu, spgv !: horizontal surface pressure gradient … … 76 74 ALLOCATE( ub (jpi,jpj,jpk) , un (jpi,jpj,jpk) , ua(jpi,jpj,jpk) , & 77 75 & vb (jpi,jpj,jpk) , vn (jpi,jpj,jpk) , va(jpi,jpj,jpk) , & 76 & ua_sv(jpi,jpj,jpk) , va_sv(jpi,jpj,jpk) , & 78 77 & wn (jpi,jpj,jpk) , & 79 78 & rotb (jpi,jpj,jpk) , rotn (jpi,jpj,jpk) , & … … 82 81 & rn2b (jpi,jpj,jpk) , rn2 (jpi,jpj,jpk) , STAT=ierr(1) ) 83 82 ! 84 ALLOCATE( rhd (jpi,jpj,jpk) , & 85 & rhop(jpi,jpj,jpk) , & 86 & rke (jpi,jpj,jpk) , & 87 & sshb (jpi,jpj) , sshn (jpi,jpj) , ssha (jpi,jpj) , & 88 & sshu_b(jpi,jpj) , sshu_n(jpi,jpj) , sshu_a(jpi,jpj) , & 89 & sshv_b(jpi,jpj) , sshv_n(jpi,jpj) , sshv_a(jpi,jpj) , & 90 & sshf_n(jpi,jpj) , & 91 & spgu (jpi,jpj) , spgv(jpi,jpj) , & 92 & gtsu(jpi,jpj,jpts), gtsv(jpi,jpj,jpts), & 93 & gru(jpi,jpj) , grv(jpi,jpj) , STAT=ierr(2) ) 83 ALLOCATE(rhd (jpi,jpj,jpk) , & 84 & rhop(jpi,jpj,jpk) , & 85 & sshb (jpi,jpj) , sshn (jpi,jpj) , ssha (jpi,jpj) , & 86 & spgu (jpi,jpj) , spgv(jpi,jpj) , & 87 & gtsu(jpi,jpj,jpts), gtsv(jpi,jpj,jpts), & 88 & gru(jpi,jpj) , grv(jpi,jpj) , STAT=ierr(2) ) 94 89 ! 95 90 ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(3) ) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/step.F90
r4230 r4292 95 95 ! Update data, open boundaries, surface boundary condition (including sea-ice) 96 96 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 97 IF( lk_tide ) CALL sbc_tide( kstp ) 98 IF( lk_obc ) CALL obc_dta ( kstp ) ! update dynamic and tracer data at open boundaries 99 IF( lk_obc ) CALL obc_rad ( kstp ) ! compute phase velocities at open boundaries 100 IF( lk_bdy ) CALL bdy_dta ( kstp, time_offset=+1 ) ! update dynamic & tracer data at open boundaries 101 97 102 CALL sbc ( kstp ) ! Sea Boundary Condition (including sea-ice) 98 99 IF( lk_tide.AND.(kstp /= nit000 )) CALL tide_init ( kstp ) 100 IF( lk_tide ) CALL sbc_tide( kstp ) 101 IF( lk_obc ) CALL obc_dta( kstp ) ! update dynamic and tracer data at open boundaries 102 IF( lk_obc ) CALL obc_rad( kstp ) ! compute phase velocities at open boundaries 103 IF( lk_bdy ) CALL bdy_dta( kstp, time_offset=+1 ) ! update dynamic and tracer data at open boundaries 104 105 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 106 ! Ocean dynamics : ssh, wn, hdiv, rot ! 107 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 108 CALL ssh_wzv( kstp ) ! after ssh & vertical velocity 103 ! clem: moved here for bdy ice purpose 104 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 105 ! Ocean dynamics : hdiv, rot, ssh, e3, wn 106 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 107 CALL zdf_bfr( kstp ) ! bottom friction (if quadratic) 108 CALL ssh_nxt ( kstp ) ! after ssh (includes call to div_cur) 109 IF( lk_dynspg_ts ) THEN 110 CALL wzv ( kstp ) ! now cross-level velocity 111 ! In case the time splitting case, update almost all momentum trends here: 112 ! Note that the computation of vertical velocity above, hence "after" sea level 113 ! is necessary to compute momentum advection for the rhs of barotropic loop: 114 CALL eos ( tsn, rhd, rhop ) ! now in situ density for hpg computation 115 IF( ln_zps ) CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv, & ! zps: now hor. derivative 116 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 117 118 ua(:,:,:) = 0.e0 ! set dynamics trends to zero 119 va(:,:,:) = 0.e0 120 IF( ln_asmiau .AND. & 121 & ln_dyninc ) CALL dyn_asm_inc ( kstp ) ! apply dynamics assimilation increment 122 IF( ln_neptsimp ) CALL dyn_nept_cor ( kstp ) ! subtract Neptune velocities (simplified) 123 IF( lk_bdy ) CALL bdy_dyn3d_dmp( kstp ) ! bdy damping trends 124 CALL dyn_adv ( kstp ) ! advection (vector or flux form) 125 CALL dyn_vor ( kstp ) ! vorticity term including Coriolis 126 CALL dyn_ldf ( kstp ) ! lateral mixing 127 IF( ln_neptsimp ) CALL dyn_nept_cor ( kstp ) ! add Neptune velocities (simplified) 128 #if defined key_agrif 129 IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_dyn ! momentum sponge 130 #endif 131 CALL dyn_hpg( kstp ) ! horizontal gradient of Hydrostatic pressure 132 CALL dyn_spg( kstp, indic ) ! surface pressure gradient 133 134 hdivb(:,:,:) = hdivn(:,:,:) ! Store now divergence and rot temporarly, revert to these below 135 rotb(:,:,:) = rotn(:,:,:) 136 ua_sv(:,:,:) = ua(:,:,:) ! Save trends (barotropic trend has been fully updated) 137 va_sv(:,:,:) = va(:,:,:) 138 139 CALL div_cur( kstp ) ! Horizontal divergence & Relative vorticity (2nd call in time-split case) 140 ENDIF 141 IF( lk_vvl ) CALL dom_vvl_sf_nxt( kstp ) ! after vertical scale factors 142 CALL wzv ( kstp ) ! now cross-level velocity (original) 109 143 110 144 !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> … … 115 149 ! 116 150 ! VERTICAL PHYSICS 117 CALL zdf_bfr( kstp ) ! bottom friction118 119 151 ! ! Vertical eddy viscosity and diffusivity coefficients 120 152 IF( lk_zdfric ) CALL zdf_ric( kstp ) ! Richardson number dependent Kz … … 122 154 IF( lk_zdfgls ) CALL zdf_gls( kstp ) ! GLS closure scheme for Kz 123 155 IF( lk_zdfkpp ) CALL zdf_kpp( kstp ) ! KPP closure scheme for Kz 124 IF( lk_zdfcst ) THEN! Constant Kz (reset avt, avm[uv] to the background value)156 IF( lk_zdfcst ) THEN ! Constant Kz (reset avt, avm[uv] to the background value) 125 157 avt (:,:,:) = rn_avt0 * tmask(:,:,:) 126 158 avmu(:,:,:) = rn_avm0 * umask(:,:,:) … … 146 178 ! 147 179 IF( lk_ldfslp ) THEN ! slope of lateral mixing 148 CALL eos( tsb, rhd )! before in situ density180 CALL eos( tsb, rhd, gdept_0(:,:,:) ) ! before in situ density 149 181 IF( ln_zps ) CALL zps_hde( kstp, jpts, tsb, gtsu, gtsv, & ! Partial steps: before horizontal gradient 150 182 & rhd, gru , grv ) ! of t, s, rd at the last ocean level … … 193 225 tsa(:,:,:,:) = 0.e0 ! set tracer trends to zero 194 226 195 !write(numout,*) "MAV kt",kstp196 !write(numout,'(a5,3(1x,f21.18))') "INIn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11)197 !write(numout,'(a5,3(1x,f21.18))') "INIa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11)198 227 IF( ln_asmiau .AND. & 199 228 & ln_trainc ) CALL tra_asm_inc( kstp ) ! apply tracer assimilation increment … … 205 234 IF( lk_bdy ) CALL bdy_tra_dmp( kstp ) ! bdy damping trends 206 235 CALL tra_adv ( kstp ) ! horizontal & vertical advection 207 !write(numout,'(a5,3(1x,f21.18))') "ADVn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11)208 !write(numout,'(a5,3(1x,f21.18))') "ADVa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11)209 236 IF( lk_zdfkpp ) CALL tra_kpp ( kstp ) ! KPP non-local tracer fluxes 210 237 CALL tra_ldf ( kstp ) ! lateral mixing 211 !write(numout,'(a5,3(1x,f21.18))') "LDFn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11)212 !write(numout,'(a5,3(1x,f21.18))') "LDFa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11)213 238 #if defined key_agrif 214 239 IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_tra ! tracers sponge 215 240 #endif 216 241 CALL tra_zdf ( kstp ) ! vertical mixing and after tracer fields 217 !do jk=1,jpk218 !write(numout,'(a5,3(1x,f21.18))') "ZDFn:",tsn(5,10,jk,jp_tem),tsn(5,10,jk,jp_sal),tmask(5,10,jk)219 !write(numout,'(a5,3(1x,f21.18))') "ZDFa:",tsa(5,10,jk,jp_tem),tsa(5,10,jk,jp_sal),ssha(5,10)220 !end do221 242 222 243 IF( ln_dynhpg_imp ) THEN ! semi-implicit hpg (time stepping then eos) 223 244 IF( ln_zdfnpc ) CALL tra_npc( kstp ) ! update after fields by non-penetrative convection 224 245 CALL tra_nxt( kstp ) ! tracer fields at next time step 225 CALL eos ( tsa, rhd, rhop )! Time-filtered in situ density for hpg computation246 CALL eos ( tsa, rhd, rhop, fsdept_n(:,:,:) ) ! Time-filtered in situ density for hpg computation 226 247 IF( ln_zps ) CALL zps_hde( kstp, jpts, tsa, gtsu, gtsv, & ! zps: time filtered hor. derivative 227 248 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 228 249 229 250 ELSE ! centered hpg (eos then time stepping) 230 CALL eos ( tsn, rhd, rhop ) ! now in situ density for hpg computation 231 IF( ln_zps ) CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv, & ! zps: now hor. derivative 251 IF ( .NOT. lk_dynspg_ts ) THEN ! eos already called in time-split case 252 CALL eos ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 253 IF( ln_zps ) CALL zps_hde( kstp, jpts, tsn, gtsu, gtsv, & ! zps: now hor. derivative 232 254 & rhd, gru , grv ) ! of t, s, rd at the last ocean level 233 !write(numout,'(a5,3(1x,f21.18))') "ZPSn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(24,11) 234 !write(numout,'(a5,3(1x,f21.18))') "ZPSa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11) 255 ENDIF 235 256 IF( ln_zdfnpc ) CALL tra_npc( kstp ) ! update after fields by non-penetrative convection 236 257 CALL tra_nxt( kstp ) ! tracer fields at next time step 237 !write(numout,'(a5,3(1x,f21.18))') "NXTn:",tsn(24,11,1,jp_tem),tsn(24,11,1,jp_sal),sshn(25,11)238 !write(numout,'(a5,3(1x,f21.18))') "NXTa:",tsa(24,11,1,jp_tem),tsa(24,11,1,jp_sal),ssha(24,11)239 258 ENDIF 240 259 … … 242 261 ! Dynamics (tsa used as workspace) 243 262 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 263 IF( lk_dynspg_ts ) THEN 264 ! revert to previously computed momentum tendencies 265 ! (not using ua, va as temporary arrays during tracers' update could avoid that) 266 ua(:,:,:) = ua_sv(:,:,:) 267 va(:,:,:) = va_sv(:,:,:) 268 ! Revert now divergence and rotational to previously computed ones 269 !(needed because of the time swap in div_cur, at the beginning of each time step) 270 hdivn(:,:,:) = hdivb(:,:,:) 271 rotn(:,:,:) = rotb(:,:,:) 272 273 CALL dyn_bfr( kstp ) ! bottom friction 274 CALL dyn_zdf( kstp ) ! vertical diffusion 275 ELSE 244 276 ua(:,:,:) = 0.e0 ! set dynamics trends to zero 245 277 va(:,:,:) = 0.e0 246 278 247 IF( ln_asmiau .AND. &248 & ln_dyninc )CALL dyn_asm_inc( kstp ) ! apply dynamics assimilation increment249 IF( ln_bkgwri )CALL asm_bkg_wri( kstp ) ! output background fields250 IF( ln_neptsimp )CALL dyn_nept_cor( kstp ) ! subtract Neptune velocities (simplified)251 IF( lk_bdy )CALL bdy_dyn3d_dmp(kstp ) ! bdy damping trends279 IF( ln_asmiau .AND. & 280 & ln_dyninc ) CALL dyn_asm_inc( kstp ) ! apply dynamics assimilation increment 281 IF( ln_bkgwri ) CALL asm_bkg_wri( kstp ) ! output background fields 282 IF( ln_neptsimp ) CALL dyn_nept_cor( kstp ) ! subtract Neptune velocities (simplified) 283 IF( lk_bdy ) CALL bdy_dyn3d_dmp(kstp ) ! bdy damping trends 252 284 CALL dyn_adv( kstp ) ! advection (vector or flux form) 253 285 CALL dyn_vor( kstp ) ! vorticity term including Coriolis 254 286 CALL dyn_ldf( kstp ) ! lateral mixing 255 IF( ln_neptsimp )CALL dyn_nept_cor( kstp ) ! add Neptune velocities (simplified)256 #if defined key_agrif 257 IF(.NOT. Agrif_Root())CALL Agrif_Sponge_dyn ! momemtum sponge287 IF( ln_neptsimp ) CALL dyn_nept_cor( kstp ) ! add Neptune velocities (simplified) 288 #if defined key_agrif 289 IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_dyn ! momemtum sponge 258 290 #endif 259 291 CALL dyn_hpg( kstp ) ! horizontal gradient of Hydrostatic pressure … … 261 293 CALL dyn_zdf( kstp ) ! vertical diffusion 262 294 CALL dyn_spg( kstp, indic ) ! surface pressure gradient 295 ENDIF 263 296 CALL dyn_nxt( kstp ) ! lateral velocity at next time step 264 297 265 CALL ssh_nxt( kstp ) ! sea surface height at next time step 298 CALL ssh_swp( kstp ) ! swap of sea surface height 299 IF( lk_vvl ) CALL dom_vvl_sf_swp( kstp ) ! swap of vertical scale factors 266 300 267 301 IF( ln_diahsb ) CALL dia_hsb( kstp ) ! - ML - global conservation diagnostics -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/step_oce.F90
r4152 r4292 11 11 USE ldftra_oce ! ocean tracer - trends 12 12 USE ldfdyn_oce ! ocean dynamics - trends 13 USE divcur ! hor. divergence and curl (div & cur routines) 13 14 USE in_out_manager ! I/O manager 14 15 USE iom ! … … 64 65 USE bdydyn3d ! bdy cond. for baroclinic vel. (bdy_dyn3d routine) 65 66 66 USE sshwzv ! vertical velocity and ssh (ssh_wzv routine) 67 USE sshwzv ! vertical velocity and ssh (ssh_nxt routine) 68 ! (ssh_swp routine) 69 ! (wzv routine) 70 USE domvvl ! variable vertical scale factors (dom_vvl_sf_nxt routine) 71 ! (dom_vvl_sf_swp routine) 67 72 68 73 USE ldfslp ! iso-neutral slopes (ldf_slp routine) -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/SAS_SRC/diawri.F90
r4148 r4292 220 220 & nit000-1, zjulian, zdt, nh_T, nid_T, domain_id=nidom, snc4chunks=snc4set ) 221 221 CALL histvert( nid_T, "deptht", "Vertical T levels", & ! Vertical grid: gdept 222 & "m", ipk, gdept_ 0, nz_T, "down" )222 & "m", ipk, gdept_1d, nz_T, "down" ) 223 223 ! ! Index of ocean points 224 224 CALL wheneq( jpi*jpj , tmask, 1, 1., ndex_hT, ndim_hT ) ! surface … … 232 232 & nit000-1, zjulian, zdt, nh_U, nid_U, domain_id=nidom, snc4chunks=snc4set ) 233 233 CALL histvert( nid_U, "depthu", "Vertical U levels", & ! Vertical grid: gdept 234 & "m", ipk, gdept_ 0, nz_U, "down" )234 & "m", ipk, gdept_1d, nz_U, "down" ) 235 235 ! ! Index of ocean points 236 236 CALL wheneq( jpi*jpj , umask, 1, 1., ndex_hU, ndim_hU ) ! surface … … 244 244 & nit000-1, zjulian, zdt, nh_V, nid_V, domain_id=nidom, snc4chunks=snc4set ) 245 245 CALL histvert( nid_V, "depthv", "Vertical V levels", & ! Vertical grid : gdept 246 & "m", ipk, gdept_ 0, nz_V, "down" )246 & "m", ipk, gdept_1d, nz_V, "down" ) 247 247 ! ! Index of ocean points 248 248 CALL wheneq( jpi*jpj , vmask, 1, 1., ndex_hV, ndim_hV ) ! surface … … 394 394 1, jpi, 1, jpj, nit000-1, zjulian, zdt, nh_i, id_i, domain_id=nidom, snc4chunks=snc4set ) ! Horizontal grid : glamt and gphit 395 395 CALL histvert( id_i, "deptht", "Vertical T levels", & ! Vertical grid : gdept 396 "m", jpk, gdept_ 0, nz_i, "down")396 "m", jpk, gdept_1d, nz_i, "down") 397 397 398 398 ! Declare all the output fields as NetCDF variables -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/C14b/trcwri_c14b.F90
r3680 r4292 36 36 DO jn = jp_c14b0, jp_c14b1 37 37 cltra = TRIM( ctrcnm(jn) ) ! short title for tracer 38 CALL iom_put( cltra, trn(:,:,:,jn) ) 38 IF( lk_vvl ) THEN 39 CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) ) 40 ELSE 41 CALL iom_put( cltra, trn(:,:,:,jn) ) 42 ENDIF 39 43 END DO 40 44 ! -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/CFC/trcwri_cfc.F90
r3680 r4292 36 36 DO jn = jp_cfc0, jp_cfc1 37 37 cltra = TRIM( ctrcnm(jn) ) ! short title for tracer 38 CALL iom_put( cltra, trn(:,:,:,jn) ) 38 IF( lk_vvl ) THEN 39 CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) ) 40 ELSE 41 CALL iom_put( cltra, trn(:,:,:,jn) ) 42 ENDIF 39 43 END DO 40 44 ! -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcwri_my_trc.F90
r3680 r4292 36 36 DO jn = jp_myt0, jp_myt1 37 37 cltra = TRIM( ctrcnm(jn) ) ! short title for tracer 38 CALL iom_put( cltra, trn(:,:,:,jn) ) 38 IF( lk_vvl ) THEN 39 CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) ) 40 ELSE 41 CALL iom_put( cltra, trn(:,:,:,jn) ) 42 ENDIF 39 43 END DO 40 44 ! -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90
r4147 r4292 371 371 nksrp = trc_oce_ext_lev( r_si2, 0.33e2 ) ! max level of light extinction (Blue Chl=0.01) 372 372 ! 373 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksrp, ' ref depth = ', gdepw_ 0(nksrp+1), ' m'373 IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksrp, ' ref depth = ', gdepw_1d(nksrp+1), ' m' 374 374 ! 375 375 etot (:,:,:) = 0._wp -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sed.F90
r3443 r4292 19 19 USE dom_oce , ONLY : glamt => glamt !: longitude of t-point (degre) 20 20 USE dom_oce , ONLY : gphit => gphit !: latitude of t-point (degre) 21 USE dom_oce , ONLY : e3t_ 0 => e3t_0!: reference depth of t-points (m)21 USE dom_oce , ONLY : e3t_1d => e3t_1d !: reference depth of t-points (m) 22 22 USE dom_oce , ONLY : mbkt => mbkt !: vertical index of the bottom last T- ocean level 23 23 USE dom_oce , ONLY : tmask => tmask !: land/ocean mask at t-points -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/PISCES/SED/sedini.F90
r3443 r4292 142 142 DO ji = 1, jpi 143 143 ikt = mbkt(ji,jj) 144 IF( tmask(ji,jj,ikt) == 1 ) epkbot(ji,jj) = e3t_ 0(ikt)144 IF( tmask(ji,jj,ikt) == 1 ) epkbot(ji,jj) = e3t_1d(ikt) 145 145 ENDDO 146 146 ENDDO -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/PISCES/trcwri_pisces.F90
r3680 r4292 21 21 PUBLIC trc_wri_pisces 22 22 23 # include "top_substitute.h90" 23 24 CONTAINS 24 25 … … 39 40 DO jn = jp_pcs0, jp_pcs1 40 41 cltra = TRIM( ctrcnm(jn) ) ! short title for tracer 42 IF( lk_vvl ) THEN 43 CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) ) 44 ELSE 45 CALL iom_put( cltra, trn(:,:,:,jn) ) 46 ENDIF 41 47 CALL iom_put( cltra, trn(:,:,:,jn) * zrfact ) 42 48 END DO … … 47 53 IF( jn == jppo4 ) zrfact = po4r * 1.0e+6 48 54 cltra = TRIM( ctrcnm(jn) ) ! short title for tracer 49 CALL iom_put( cltra, trn(:,:,:,jn) * zrfact ) 55 IF( lk_vvl ) THEN 56 CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) * zrfact ) 57 ELSE 58 CALL iom_put( cltra, trn(:,:,:,jn) * zrfact ) 59 ENDIF 50 60 END DO 51 61 #endif -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90
r4148 r4292 70 70 USE oce , ONLY : sshb => sshb !: sea surface height at t-point [m] 71 71 USE oce , ONLY : ssha => ssha !: sea surface height at t-point [m] 72 USE oce , ONLY : sshu_n => sshu_n !: sea surface height at u-point [m]73 USE oce , ONLY : sshu_b => sshu_b !: sea surface height at u-point [m]74 USE oce , ONLY : sshu_a => sshu_a !: sea surface height at u-point [m]75 USE oce , ONLY : sshv_n => sshv_n !: sea surface height at v-point [m]76 USE oce , ONLY : sshv_b => sshv_b !: sea surface height at v-point [m]77 USE oce , ONLY : sshv_a => sshv_a !: sea surface height at v-point [m]78 USE oce , ONLY : sshf_n => sshf_n !: sea surface height at v-point [m]79 72 USE oce , ONLY : l_traldf_rot => l_traldf_rot !: rotated laplacian operator for lateral diffusion 80 73 #if defined key_offline -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/trcdia.F90
r3294 r4292 187 187 188 188 ! Vertical grid for tracer : gdept 189 CALL histvert( nit5, 'deptht', 'Vertical T levels', 'm', ipk, gdept_ 0, ndepit5)189 CALL histvert( nit5, 'deptht', 'Vertical T levels', 'm', ipk, gdept_1d, ndepit5) 190 190 191 191 ! Index of ocean points in 3D and 2D (surface) … … 308 308 ! Vertical grid for 2d and 3d arrays 309 309 310 CALL histvert( nitd, 'deptht', 'Vertical T levels','m', ipk, gdept_ 0, ndepitd)310 CALL histvert( nitd, 'deptht', 'Vertical T levels','m', ipk, gdept_1d, ndepitd) 311 311 312 312 ! Declare all the output fields as NETCDF variables … … 439 439 & iiter, zjulian, zdt, nhoritb, nitb , domain_id=nidom, snc4chunks=snc4set ) 440 440 ! Vertical grid for biological trends 441 CALL histvert(nitb, 'deptht', 'Vertical T levels', 'm', ipk, gdept_ 0, ndepitb)441 CALL histvert(nitb, 'deptht', 'Vertical T levels', 'm', ipk, gdept_1d, ndepitb) 442 442 443 443 ! Declare all the output fields as NETCDF variables -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/trcdta.F90
r4230 r4292 188 188 DO ji = 1, jpi 189 189 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 190 zl = fsdept_ 0(ji,jj,jk)191 IF( zl < gdept_ 0(1 ) ) THEN! above the first level of data190 zl = fsdept_n(ji,jj,jk) 191 IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data 192 192 ztp(jk) = sf_dta(1)%fnow(ji,jj,1) 193 ELSEIF( zl > gdept_ 0(jpk) ) THEN! below the last level of data193 ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data 194 194 ztp(jk) = sf_dta(1)%fnow(ji,jj,jpkm1) 195 195 ELSE ! inbetween : vertical interpolation between jkk & jkk+1 196 196 DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1) 197 IF( (zl-gdept_ 0(jkk)) * (zl-gdept_0(jkk+1)) <= 0._wp ) THEN198 zi = ( zl - gdept_ 0(jkk) ) / (gdept_0(jkk+1)-gdept_0(jkk))197 IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 198 zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 199 199 ztp(jk) = sf_dta(1)%fnow(ji,jj,jkk) + ( sf_dta(1)%fnow(ji,jj,jkk+1) - & 200 200 sf_dta(1)%fnow(ji,jj,jkk) ) * zi … … 219 219 ik = mbkt(ji,jj) 220 220 IF( ik > 1 ) THEN 221 zl = ( gdept_ 0(ik) - fsdept_0(ji,jj,ik) ) / ( gdept_0(ik) - gdept_0(ik-1) )221 zl = ( gdept_1d(ik) - fsdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 222 222 sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik-1) 223 223 ENDIF -
branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/TOP_SRC/trcsub.F90
r4148 r4292 79 79 ! 80 80 sshb_hold (:,:) = sshn (:,:) 81 82 81 !!Z~ sshu_b_hold(:,:) = sshu_n(:,:) 82 !!Z~ sshv_b_hold(:,:) = sshv_n(:,:) 83 83 emp_b_hold (:,:) = emp_b (:,:) 84 84 ! … … 117 117 ! 118 118 sshn_tm (:,:) = sshn_tm (:,:) + sshn (:,:) 119 120 119 !!Z~ sshu_n_tm(:,:) = sshu_n_tm(:,:) + sshu_n(:,:) 120 !!Z~ sshv_n_tm(:,:) = sshv_n_tm(:,:) + sshv_n(:,:) 121 121 rnf_tm (:,:) = rnf_tm (:,:) + rnf (:,:) 122 122 h_rnf_tm (:,:) = h_rnf_tm (:,:) + h_rnf (:,:) … … 197 197 # endif 198 198 sshn_temp (:,:) = sshn (:,:) 199 200 201 199 !!Z~ sshu_n_temp(:,:) = sshu_n(:,:) 200 !!Z~ sshv_n_temp(:,:) = sshv_n(:,:) 201 !!Z~ sshf_n_temp(:,:) = sshf_n(:,:) 202 202 sshb_temp (:,:) = sshb (:,:) 203 204 203 !!Z~ sshu_b_temp(:,:) = sshu_b(:,:) 204 !!Z~ sshv_b_temp(:,:) = sshv_b(:,:) 205 205 ssha_temp (:,:) = ssha (:,:) 206 207 206 !!Z~ sshu_a_temp(:,:) = sshu_a(:,:) 207 !!Z~ sshv_a_temp(:,:) = sshv_a(:,:) 208 208 rnf_temp (:,:) = rnf (:,:) 209 209 h_rnf_temp (:,:) = h_rnf (:,:) … … 309 309 # endif 310 310 sshn_tm (:,:) = sshn_tm (:,:) + sshn (:,:) 311 312 311 !!Z~ sshu_n_tm(:,:) = sshu_n_tm (:,:) + sshu_n(:,:) 312 !!Z~ sshv_n_tm(:,:) = sshv_n_tm (:,:) + sshv_n(:,:) 313 313 rnf_tm (:,:) = rnf_tm (:,:) + rnf (:,:) 314 314 h_rnf_tm (:,:) = h_rnf_tm (:,:) + h_rnf (:,:) … … 321 321 ! 322 322 sshn (:,:) = sshn_tm (:,:) * r1_ndttrcp1 323 324 323 !!Z~ sshu_n (:,:) = sshu_n_tm (:,:) * r1_ndttrcp1 324 !!Z~ sshv_n (:,:) = sshv_n_tm (:,:) * r1_ndttrcp1 325 325 sshb (:,:) = sshb_hold (:,:) 326 327 326 !!Z~ sshu_b (:,:) = sshu_b_hold(:,:) 327 !!Z~ sshv_b (:,:) = sshv_b_hold(:,:) 328 328 rnf (:,:) = rnf_tm (:,:) * r1_ndttrcp1 329 329 h_rnf (:,:) = h_rnf_tm (:,:) * r1_ndttrcp1 … … 486 486 #endif 487 487 CALL lbc_lnk( sshn (:,:) , 'T', 1. ) 488 489 490 488 !!Z~ CALL lbc_lnk( sshu_n(:,:) , 'U', 1. ) 489 !!Z~ CALL lbc_lnk( sshv_n(:,:) , 'V', 1. ) 490 !!Z~ CALL lbc_lnk( sshf_n(:,:) , 'F', 1. ) 491 491 CALL lbc_lnk( sshb (:,:) , 'T', 1. ) 492 493 492 !!Z~ CALL lbc_lnk( sshu_b(:,:) , 'U', 1. ) 493 !!Z~ CALL lbc_lnk( sshv_b(:,:) , 'V', 1. ) 494 494 CALL lbc_lnk( ssha (:,:) , 'T', 1. ) 495 496 495 !!Z~ CALL lbc_lnk( sshu_a(:,:) , 'U', 1. ) 496 !!Z~ CALL lbc_lnk( sshv_a(:,:) , 'V', 1. ) 497 497 CALL lbc_lnk( rnf (:,:) , 'T', 1. ) 498 498 CALL lbc_lnk( h_rnf (:,:) , 'T', 1. ) … … 592 592 #endif 593 593 sshn_tm (:,:) = sshn (:,:) 594 595 594 !!Z~ sshu_n_tm(:,:) = sshu_n(:,:) 595 !!Z~ sshv_n_tm(:,:) = sshv_n(:,:) 596 596 rnf_tm (:,:) = rnf (:,:) 597 597 h_rnf_tm (:,:) = h_rnf (:,:) … … 695 695 sshb (:,:) = sshb_temp (:,:) 696 696 ssha (:,:) = ssha_temp (:,:) 697 698 699 700 701 702 703 697 !!Z~ sshu_n(:,:) = sshu_n_temp(:,:) 698 !!Z~ sshu_b(:,:) = sshu_b_temp(:,:) 699 !!Z~ sshu_a(:,:) = sshu_a_temp(:,:) 700 !!Z~ sshv_n(:,:) = sshv_n_temp(:,:) 701 !!Z~ sshv_b(:,:) = sshv_b_temp(:,:) 702 !!Z~ sshv_a(:,:) = sshv_a_temp(:,:) 703 !!Z~ sshf_n(:,:) = sshf_n_temp(:,:) 704 704 rnf (:,:) = rnf_temp (:,:) 705 705 h_rnf (:,:) = h_rnf_temp (:,:) … … 816 816 ! 817 817 sshb_hold (:,:) = sshn (:,:) 818 819 818 !!Z~ sshu_b_hold(:,:) = sshu_n(:,:) 819 !!Z~ sshv_b_hold(:,:) = sshv_n(:,:) 820 820 emp_b_hold (:,:) = emp (:,:) 821 821 sshn_tm (:,:) = sshn (:,:) 822 823 822 !!Z~ sshu_n_tm (:,:) = sshu_n(:,:) 823 !!Z~ sshv_n_tm (:,:) = sshv_n(:,:) 824 824 rnf_tm (:,:) = rnf (:,:) 825 825 h_rnf_tm (:,:) = h_rnf (:,:) … … 951 951 END DO 952 952 ! 953 954 953 !!Z~ hu(:,:) = hu_0(:,:) + sshu_n(:,:) ! now ocean depth (at u- and v-points) 954 !!Z~ hv(:,:) = hv_0(:,:) + sshv_n(:,:) 955 955 ! ! now masked inverse of the ocean depth (at u- and v-points) 956 956 hur(:,:) = umask(:,:,1) / ( hu(:,:) + 1._wp - umask(:,:,1) ) … … 992 992 993 993 ! ! Sea Surface Height at u-,v- and f-points (vvl case only) 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 994 !!Z~ IF( lk_vvl ) THEN ! (required only in key_vvl case) 995 !!Z~ DO jj = 1, jpjm1 996 !!Z~ DO ji = 1, jpim1 ! NO Vector Opt. 997 !!Z~ sshu_a(ji,jj) = 0.5 * umask(ji,jj,1) / ( e1u(ji ,jj) * e2u(ji ,jj) ) & 998 !!Z~ & * ( e1t(ji ,jj) * e2t(ji ,jj) * ssha(ji ,jj) & 999 !!Z~ & + e1t(ji+1,jj) * e2t(ji+1,jj) * ssha(ji+1,jj) ) 1000 !!Z~ sshv_a(ji,jj) = 0.5 * vmask(ji,jj,1) / ( e1v(ji,jj ) * e2v(ji,jj ) ) & 1001 !!Z~ & * ( e1t(ji,jj ) * e2t(ji,jj ) * ssha(ji,jj ) & 1002 !!Z~ & + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha(ji,jj+1) ) 1003 !!Z~ END DO 1004 !!Z~ END DO 1005 !!Z~ CALL lbc_lnk( sshu_a, 'U', 1. ) ; CALL lbc_lnk( sshv_a, 'V', 1. ) ! Boundaries conditions 1006 !!Z~ ENDIF 1007 1007 1008 1008
Note: See TracChangeset
for help on using the changeset viewer.