- Timestamp:
- 2020-03-26T15:59:52+01:00 (4 years ago)
- Location:
- NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE
- Files:
-
- 1 added
- 1 copied
-
. (added)
-
domvvl.F90 (copied) (copied from NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/OCE/DOM/domvvl.F90) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2020/dev_r12527_Gurvan_ShallowWater/src/SWE/domvvl.F90
r12529 r12614 166 166 ! !== Set of all other vertical scale factors ==! (now and before) 167 167 ! ! Horizontal interpolation of e3t 168 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U169 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3u(:,:,:,Kmm), 'U' )170 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V171 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3v(:,:,:,Kmm), 'V' )172 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' ) ! from U to F168 CALL dom_vvl_interpol( ssh(:,:,Kbb), e3u(:,:,:,Kbb), 'U' ) ! from T to U 169 CALL dom_vvl_interpol( ssh(:,:,Kmm), e3u(:,:,:,Kmm), 'U' ) 170 CALL dom_vvl_interpol( ssh(:,:,Kbb), e3v(:,:,:,Kbb), 'V' ) ! from T to V 171 CALL dom_vvl_interpol( ssh(:,:,Kmm), e3v(:,:,:,Kmm), 'V' ) 172 CALL dom_vvl_interpol( ssh(:,:,Kmm), e3f(:,:,:), 'F' ) ! from U to F 173 173 ! ! Vertical interpolation of e3t,u,v 174 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W175 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w (:,:,:,Kbb), 'W' )176 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) ! from U to UW177 CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' )178 CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) ! from V to UW179 CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' )174 CALL dom_vvl_interpol( ssh(:,:,Kmm), e3w (:,:,:,Kmm), 'W' ) ! from T to W 175 CALL dom_vvl_interpol( ssh(:,:,Kbb), e3w (:,:,:,Kbb), 'W' ) 176 CALL dom_vvl_interpol( ssh(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) ! from U to UW 177 CALL dom_vvl_interpol( ssh(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 178 CALL dom_vvl_interpol( ssh(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) ! from V to UW 179 CALL dom_vvl_interpol( ssh(:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 180 180 181 181 ! We need to define e3[tuv]_a for AGRIF initialisation (should not be a problem for the restartability...) … … 549 549 ! *********************************** ! 550 550 551 CALL dom_vvl_interpol( e3t(:,:,:,Kaa), e3u(:,:,:,Kaa), 'U' )552 CALL dom_vvl_interpol( e3t(:,:,:,Kaa), e3v(:,:,:,Kaa), 'V' )551 CALL dom_vvl_interpol( ssh(:,:,Kaa), e3u(:,:,:,Kaa), 'U' ) 552 CALL dom_vvl_interpol( ssh(:,:,Kaa), e3v(:,:,:,Kaa), 'V' ) 553 553 554 554 ! *********************************** ! … … 633 633 ! - JC - hu(:,:,:,Kbb), hv(:,:,:,:,Kbb), hur_b, hvr_b also 634 634 635 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3f(:,:,:), 'F' )635 CALL dom_vvl_interpol( ssh(:,:,Kmm), e3f(:,:,:), 'F' ) 636 636 637 637 ! Vertical scale factor interpolations 638 CALL dom_vvl_interpol( e3t(:,:,:,Kmm), e3w(:,:,:,Kmm), 'W' )639 CALL dom_vvl_interpol( e3u(:,:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' )640 CALL dom_vvl_interpol( e3v(:,:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' )641 CALL dom_vvl_interpol( e3t(:,:,:,Kbb), e3w(:,:,:,Kbb), 'W' )642 CALL dom_vvl_interpol( e3u(:,:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' )643 CALL dom_vvl_interpol( e3v(:,:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' )638 CALL dom_vvl_interpol( ssh(:,:,Kmm), e3w(:,:,:,Kmm), 'W' ) 639 CALL dom_vvl_interpol( ssh(:,:,Kmm), e3uw(:,:,:,Kmm), 'UW' ) 640 CALL dom_vvl_interpol( ssh(:,:,Kmm), e3vw(:,:,:,Kmm), 'VW' ) 641 CALL dom_vvl_interpol( ssh(:,:,Kbb), e3w(:,:,:,Kbb), 'W' ) 642 CALL dom_vvl_interpol( ssh(:,:,Kbb), e3uw(:,:,:,Kbb), 'UW' ) 643 CALL dom_vvl_interpol( ssh(:,:,Kbb), e3vw(:,:,:,Kbb), 'VW' ) 644 644 645 645 ! t- and w- points depth (set the isf depth as it is in the initial step) … … 674 674 675 675 676 SUBROUTINE dom_vvl_interpol( p e3_in, pe3_out, pout)676 SUBROUTINE dom_vvl_interpol( pssh, pe3, cdp ) 677 677 !!--------------------------------------------------------------------- 678 678 !! *** ROUTINE dom_vvl__interpol *** … … 684 684 !! - vertical interpolation: simple averaging 685 685 !!---------------------------------------------------------------------- 686 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3_in ! input e3 to be interpolated 687 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3_out ! output interpolated e3 688 CHARACTER(LEN=*) , INTENT(in ) :: pout ! grid point of out scale factors 689 ! ! = 'U', 'V', 'W, 'F', 'UW' or 'VW' 690 ! 691 INTEGER :: ji, jj, jk ! dummy loop indices 692 REAL(wp) :: zlnwd ! =1./0. when ln_wd_il = T/F 693 !!---------------------------------------------------------------------- 694 ! 695 IF(ln_wd_il) THEN 696 zlnwd = 1.0_wp 697 ELSE 698 zlnwd = 0.0_wp 699 END IF 700 ! 701 SELECT CASE ( pout ) !== type of interpolation ==! 686 REAL(wp), DIMENSION(:,:) , INTENT(in ) :: pssh ! input e3 NOT used here (ssh is used instead) 687 REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: pe3 ! scale factor e3 to be updated [m] 688 CHARACTER(LEN=*) , INTENT(in ) :: cdp ! grid point of the scale factor ( 'U', 'V', 'W, 'F', 'UW' or 'VW' ) 689 ! 690 INTEGER :: ji, jj, jk ! dummy loop indices 691 REAL(wp), DIMENSION(jpi,jpj) :: zc3 ! 2D workspace 692 !!---------------------------------------------------------------------- 693 ! 694 SELECT CASE ( cdp ) !== type of interpolation ==! 702 695 ! 703 696 CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean 704 DO_3D_10_10( 1, jpk ) 705 pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2u(ji,jj) & 706 & * ( e1e2t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & 707 & + e1e2t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) ) 708 END_3D 709 CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'U', 1._wp ) 710 pe3_out(:,:,:) = pe3_out(:,:,:) + e3u_0(:,:,:) 697 DO_2D_00_00 698 zc3(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) & 699 & + e1e2t(ji+1,jj) * pssh(ji+1,jj) ) * r1_hu_0(ji,jj) * r1_e1e2u(ji,jj) 700 END_2D 701 CALL lbc_lnk( 'domvvl', zc3(:,:), 'U', 1._wp ) 702 ! 703 DO jk = 1, jpkm1 704 pe3(:,:,jk) = e3u_0(:,:,jk) * ( 1.0_wp + zc3(:,:) ) 705 END DO 711 706 ! 712 707 CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean 713 DO_3D_10_10( 1, jpk ) 714 pe3_out(ji,jj,jk) = 0.5_wp * ( vmask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2v(ji,jj) & 715 & * ( e1e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & 716 & + e1e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) ) 717 END_3D 718 CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'V', 1._wp ) 719 pe3_out(:,:,:) = pe3_out(:,:,:) + e3v_0(:,:,:) 708 DO_2D_00_00 709 zc3(ji,jj) = 0.5_wp * ( e1e2t(ji,jj ) * pssh(ji,jj ) & 710 & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj) 711 END_2D 712 CALL lbc_lnk( 'domvvl', zc3(:,:), 'V', 1._wp ) 713 ! 714 DO jk = 1, jpkm1 715 pe3(:,:,jk) = e3v_0(:,:,jk) * ( 1.0_wp + zc3(:,:) ) 716 END DO 720 717 ! 721 718 CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean 722 DO_3D_10_10( 1, jpk ) 723 pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * umask(ji,jj+1,jk) * (1.0_wp - zlnwd) + zlnwd ) & 724 & * r1_e1e2f(ji,jj) & 725 & * ( e1e2u(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3u_0(ji,jj ,jk) ) & 726 & + e1e2u(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3u_0(ji,jj+1,jk) ) ) 727 END_3D 728 CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'F', 1._wp ) 729 pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:) 719 DO_2D_10_10 720 zc3(ji,jj) = 0.25_wp * ( e1e2t(ji ,jj ) * pssh(ji ,jj ) & 721 & + e1e2t(ji+1,jj ) * pssh(ji+1,jj ) & 722 & + e1e2t(ji ,jj+1) * pssh(ji ,jj+1) & 723 & + e1e2t(ji+1,jj+1) * pssh(ji+1,jj+1) ) * r1_hf_0(ji,jj) * r1_e1e2f(ji,jj) 724 END_2D 725 CALL lbc_lnk( 'domvvl', zc3(:,:), 'F', 1._wp ) 726 ! 727 DO jk = 1, jpkm1 ! Horizontal interpolation of e3f from ssh 728 e3f(:,:,jk) = e3f_0(:,:,jk) * ( 1._wp + zc3(:,:) ) 729 END DO 730 730 ! 731 731 CASE( 'W' ) !* from T- to W-point : vertical simple mean 732 ! 733 pe3_out(:,:,1) = e3w_0(:,:,1) + pe3_in(:,:,1) - e3t_0(:,:,1) 734 ! - ML - The use of mask in this formulea enables the special treatment of the last w-point without indirect adressing 735 !!gm BUG? use here wmask in case of ISF ? to be checked 736 DO jk = 2, jpk 737 pe3_out(:,:,jk) = e3w_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & 738 & * ( pe3_in(:,:,jk-1) - e3t_0(:,:,jk-1) ) & 739 & + 0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) & 740 & * ( pe3_in(:,:,jk ) - e3t_0(:,:,jk ) ) 741 END DO 742 ! 743 CASE( 'UW' ) !* from U- to UW-point : vertical simple mean 744 ! 745 pe3_out(:,:,1) = e3uw_0(:,:,1) + pe3_in(:,:,1) - e3u_0(:,:,1) 746 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 747 !!gm BUG? use here wumask in case of ISF ? to be checked 748 DO jk = 2, jpk 749 pe3_out(:,:,jk) = e3uw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & 750 & * ( pe3_in(:,:,jk-1) - e3u_0(:,:,jk-1) ) & 751 & + 0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) & 752 & * ( pe3_in(:,:,jk ) - e3u_0(:,:,jk ) ) 753 END DO 754 ! 755 CASE( 'VW' ) !* from V- to VW-point : vertical simple mean 756 ! 757 pe3_out(:,:,1) = e3vw_0(:,:,1) + pe3_in(:,:,1) - e3v_0(:,:,1) 758 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 759 !!gm BUG? use here wvmask in case of ISF ? to be checked 760 DO jk = 2, jpk 761 pe3_out(:,:,jk) = e3vw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & 762 & * ( pe3_in(:,:,jk-1) - e3v_0(:,:,jk-1) ) & 763 & + 0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) & 764 & * ( pe3_in(:,:,jk ) - e3v_0(:,:,jk ) ) 765 END DO 732 zc3(:,:) = pssh(:,:) * r1_ht_0(:,:) 733 ! 734 DO jk = 1, jpk 735 pe3(:,:,jk) = e3w_0(:,:,jk) * ( 1.0_wp + zc3(:,:) ) 736 END DO 737 ! 738 CASE( 'UW' ) !* from U- to UW-point 739 ! 740 DO_2D_00_00 741 zc3(ji,jj) = 0.5_wp * ( e1e2t(ji ,jj) * pssh(ji ,jj) & 742 & + e1e2t(ji+1,jj) * pssh(ji+1,jj) ) * r1_hu_0(ji,jj) * r1_e1e2u(ji,jj) 743 END_2D 744 CALL lbc_lnk( 'domvvl', zc3(:,:), 'U', 1._wp ) 745 ! 746 DO jk = 1, jpk 747 pe3(:,:,jk) = e3uw_0(:,:,jk) * ( 1.0_wp + zc3(:,:) ) 748 END DO 749 CASE( 'VW' ) !* from U- to UW-point : vertical simple mean 750 ! 751 DO_2D_00_00 752 zc3(ji,jj) = 0.5_wp * ( e1e2t(ji,jj ) * pssh(ji,jj ) & 753 & + e1e2t(ji,jj+1) * pssh(ji,jj+1) ) * r1_hv_0(ji,jj) * r1_e1e2v(ji,jj) 754 END_2D 755 CALL lbc_lnk( 'domvvl', zc3(:,:), 'V', 1._wp ) 756 ! 757 DO jk = 1, jpk 758 pe3(:,:,jk) = e3vw_0(:,:,jk) * ( 1.0_wp + zc3(:,:) ) 759 END DO 760 ! 766 761 END SELECT 767 762 ! … … 878 873 ! Wetting and drying test case 879 874 CALL usr_def_istate( gdept(:,:,:,Kbb), tmask, ts(:,:,:,:,Kbb), uu(:,:,:,Kbb), vv(:,:,:,Kbb), ssh(:,:,Kbb) ) 880 ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones875 !!an ts (:,:,:,:,Kmm) = ts (:,:,:,:,Kbb) ! set now values from to before ones 881 876 ssh (:,:,Kmm) = ssh(:,:,Kbb) 882 877 uu (:,:,:,Kmm) = uu (:,:,:,Kbb) … … 923 918 ! e3t(:,:,:,Kmm) = e3t(:,:,:,Kbb) 924 919 ssh(:,:,Kmm)=0._wp 920 ssh(:,:,Kbb)=0._wp 925 921 e3t(:,:,:,Kmm)=e3t_0(:,:,:) 926 922 e3t(:,:,:,Kbb)=e3t_0(:,:,:)
Note: See TracChangeset
for help on using the changeset viewer.
