Changeset 8803 for branches/2017
- Timestamp:
- 2017-11-23T18:29:01+01:00 (6 years ago)
- Location:
- branches/2017/dev_r8624_AGRIF3_VVL/NEMOGCM/NEMO
- Files:
-
- 2 edited
-
NST_SRC/agrif_opa_update.F90 (modified) (18 diffs)
-
OPA_SRC/step.F90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_r8624_AGRIF3_VVL/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r8762 r8803 1 1 #define TWO_WAY /* TWO WAY NESTING */ 2 #undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 2 #undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 3 #undef VOL_REFLUX /* VOLUME REFLUXING*/ 3 4 4 5 MODULE agrif_opa_update … … 17 18 PRIVATE 18 19 19 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn, Update_Scales, Agrif_Update_vvl 20 PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn, Update_Scales, Agrif_Update_vvl, Agrif_Update_ssh 20 21 21 22 # if defined key_zdftke … … 100 101 CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d) 101 102 # endif 102 103 ! 104 nbcline = nbcline + 1 105 ! 103 106 IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN 104 107 ! Update time integrated transports 105 IF (mod(nbcline,nbclineupdate) == 0) THEN106 108 # if ! defined DECAL_FEEDBACK 107 108 109 CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 110 CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 109 111 # else 110 111 112 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) 113 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) 112 114 # endif 113 ELSE114 # if ! defined DECAL_FEEDBACK115 CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b)116 CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b)117 # else118 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b)119 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b)120 # endif121 ENDIF122 115 END IF 123 ! 124 nbcline = nbcline + 1 116 #endif 117 ! 118 END SUBROUTINE Agrif_Update_Dyn 119 120 SUBROUTINE Agrif_Update_ssh( ) 121 !!--------------------------------------------- 122 !! *** ROUTINE Agrif_Update_ssh *** 123 !!--------------------------------------------- 124 ! 125 IF (Agrif_Root()) RETURN 126 ! 127 #if defined TWO_WAY 125 128 ! 126 129 Agrif_UseSpecialValueInUpdate = .TRUE. … … 131 134 CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) 132 135 # endif 136 ! 133 137 Agrif_UseSpecialValueInUpdate = .FALSE. 134 ! 138 ! 139 # if defined DECAL_FEEDBACK && defined VOL_REFLUX 140 IF ( ln_dynspg_ts.AND.ln_bt_fw ) THEN 141 ! Refluxing on ssh: 142 CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0, 0/),locupdate2=(/1, 1/),procname = reflux_sshu) 143 CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1, 1/),locupdate2=(/0, 0/),procname = reflux_sshv) 144 END IF 145 # endif 146 ! 135 147 #endif 136 148 ! 137 END SUBROUTINE Agrif_Update_ Dyn149 END SUBROUTINE Agrif_Update_ssh 138 150 139 151 # if defined key_zdftke … … 180 192 Agrif_SpecialValueFineGrid = 0. 181 193 ! 182 # if ! defined DECAL_FEEDBACK 183 CALL Agrif_Update_Variable(e3t_id, procname=updatee3t) 184 # else 185 CALL Agrif_Update_Variable(e3t_id, locupdate=(/1,0/), procname=updatee3t) 186 # endif 194 ! No interface separation here, update vertical grid at T points 195 ! everywhere over the overlapping regions (one account for refluxing in that case): 196 CALL Agrif_Update_Variable(e3t_id, procname=updatee3t) 187 197 ! 188 198 Agrif_UseSpecialValueInUpdate = .FALSE. … … 209 219 210 220 ! Save "old" scale factor (prior update) for subsequent asselin correction 211 ! of prognostic variables (needed to update initial state only)212 ! ----------------------- --------------------------------------221 ! of prognostic variables 222 ! ----------------------- 213 223 ! 214 224 e3u_a(:,:,:) = e3u_n(:,:,:) … … 246 256 ! 2) BEFORE fields: 247 257 !------------------ 248 IF ( (.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_exp)) & 249 & .OR.(.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_ts & 250 & .AND.(.NOT.ln_bt_fw)))) THEN 258 ! IF ( (.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_exp)) & 259 ! & .OR.(.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_ts & 260 ! & .AND.(.NOT.ln_bt_fw)))) THEN 261 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN 251 262 ! 252 263 ! Vertical scale factor interpolations … … 591 602 END DO 592 603 ELSE 593 IF( .NOT.ln_dynspg_ts .OR. ( ln_dynspg_ts .AND. .NOT.ln_bt_fw ) ) THEN 594 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 595 DO jj=j1,j2 596 DO ji=i1,i2 597 sshb(ji,jj) = sshb(ji,jj) & 598 & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 599 END DO 600 END DO 601 ENDIF 604 IF ( (.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_exp)) & 605 & .OR.(.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_ts & 606 & .AND.(.NOT.ln_bt_fw)))) THEN 607 ! tsplit_new 608 ! IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 609 DO jj=j1,j2 610 DO ji=i1,i2 611 sshb(ji,jj) = sshb(ji,jj) & 612 & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 613 END DO 614 END DO 602 615 ENDIF 603 616 ! … … 618 631 619 632 620 SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before , nb, ndir)633 SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before ) 621 634 !!--------------------------------------------- 622 635 !! *** ROUTINE updateub2b *** 636 !!--------------------------------------------- 637 INTEGER, INTENT(in) :: i1, i2, j1, j2 638 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 639 LOGICAL, INTENT(in) :: before 640 !! 641 INTEGER :: ji, jj 642 REAL(wp) :: zrhoy, za1, zcor 643 !!--------------------------------------------- 644 ! 645 IF (before) THEN 646 zrhoy = Agrif_Rhoy() 647 DO jj=j1,j2 648 DO ji=i1,i2 649 tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj) 650 END DO 651 END DO 652 tabres = zrhoy * tabres 653 ELSE 654 ! 655 tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2) 656 ! 657 za1 = 1._wp / REAL(Agrif_rhot(), wp) 658 DO jj=j1,j2 659 DO ji=i1,i2 660 zcor=tabres(ji,jj) - ub2_b(ji,jj) 661 ! Update time integrated fluxes also in case of multiply nested grids: 662 ub2_i_b(ji,jj) = ub2_i_b(ji,jj) + za1 * zcor 663 ! Update corrective fluxes: 664 ! tsplit_new 665 ! un_bf(ji,jj) = un_bf(ji,jj) + zcor 666 ! Update half step back fluxes: 667 ub2_b(ji,jj) = tabres(ji,jj) 668 END DO 669 END DO 670 ENDIF 671 ! 672 END SUBROUTINE updateub2b 673 674 SUBROUTINE reflux_sshu( tabres, i1, i2, j1, j2, before, nb, ndir ) 675 !!--------------------------------------------- 676 !! *** ROUTINE reflux_sshu *** 623 677 !!--------------------------------------------- 624 678 INTEGER, INTENT(in) :: i1, i2, j1, j2 … … 629 683 LOGICAL :: western_side, eastern_side 630 684 INTEGER :: ji, jj 631 REAL(wp) :: zrhoy, za1 685 REAL(wp) :: zrhoy, za1, zcor 632 686 !!--------------------------------------------- 633 687 ! … … 644 698 tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e2u(i1:i2,j1:j2) 645 699 ! 646 ! Refluxing here:647 #if defined DECAL_FEEDBACK648 700 western_side = (nb == 1).AND.(ndir == 1) 649 701 eastern_side = (nb == 1).AND.(ndir == 2) … … 651 703 IF (western_side) THEN 652 704 DO jj=j1,j2 653 sshn(i1 ,jj) = sshn(i1 ,jj) + rdt * r1_e1e2t(i1 ,jj) & 654 & * e2u(i1,jj) * (ub2_b(i1,jj)-tabres(i1,jj)) 705 zcor = rdt * r1_e1e2t(i1 ,jj) * e2u(i1,jj) * (ub2_b(i1,jj)-tabres(i1,jj)) 706 sshn(i1 ,jj) = sshn(i1 ,jj) + zcor 707 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i1 ,jj) = sshb(i1 ,jj) + atfp * zcor 655 708 END DO 656 709 ENDIF 657 710 IF (eastern_side) THEN 658 711 DO jj=j1,j2 659 sshn(i2+1,jj) = sshn(i2+1,jj) - rdt * r1_e1e2t(i2+1,jj) & 660 & * e2u(i2,jj) * (ub2_b(i2,jj)-tabres(i2,jj)) 661 END DO 662 ENDIF 712 zcor = - rdt * r1_e1e2t(i2+1,jj) * e2u(i2,jj) * (ub2_b(i2,jj)-tabres(i2,jj)) 713 sshn(i2+1,jj) = sshn(i2+1,jj) + zcor 714 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(i2+1,jj) = sshb(i2+1,jj) + atfp * zcor 715 END DO 716 ENDIF 717 ! 718 ENDIF 719 ! 720 END SUBROUTINE reflux_sshu 721 722 723 SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before ) 724 !!--------------------------------------------- 725 !! *** ROUTINE updatevb2b *** 726 !!--------------------------------------------- 727 INTEGER, INTENT(in) :: i1, i2, j1, j2 728 REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 729 LOGICAL, INTENT(in) :: before 730 !! 731 INTEGER :: ji, jj 732 REAL(wp) :: zrhox, za1, zcor 733 !!--------------------------------------------- 734 ! 735 IF (before) THEN 736 zrhox = Agrif_Rhox() 737 DO jj=j1,j2 738 DO ji=i1,i2 739 tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 740 END DO 741 END DO 742 tabres = zrhox * tabres 743 ELSE 663 744 ! 664 #endif 745 tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2) 746 ! 665 747 za1 = 1._wp / REAL(Agrif_rhot(), wp) 666 !667 DO jj=j1,j2668 DO ji=i1,i2748 DO jj=j1,j2 749 DO ji=i1,i2 750 zcor=tabres(ji,jj) - vb2_b(ji,jj) 669 751 ! Update time integrated fluxes also in case of multiply nested grids: 670 ub2_i_b(ji,jj) = ub2_i_b(ji,jj) & 671 & + za1 * (tabres(ji,jj) - ub2_b(ji,jj)) 752 vb2_i_b(ji,jj) = vb2_i_b(ji,jj) + za1 * zcor 753 ! Update corrective fluxes: 754 ! tsplit_new 755 ! vn_bf(ji,jj) = vn_bf(ji,jj) + zcor 672 756 ! Update half step back fluxes: 673 ub2_b(ji,jj) = tabres(ji,jj) 674 END DO 675 END DO 676 ENDIF 677 ! 678 END SUBROUTINE updateub2b 679 680 681 SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before, nb, ndir ) 682 !!--------------------------------------------- 683 !! *** ROUTINE updatevb2b *** 757 vb2_b(ji,jj) = tabres(ji,jj) 758 END DO 759 END DO 760 ENDIF 761 ! 762 END SUBROUTINE updatevb2b 763 764 SUBROUTINE reflux_sshv( tabres, i1, i2, j1, j2, before, nb, ndir ) 765 !!--------------------------------------------- 766 !! *** ROUTINE reflux_sshv *** 684 767 !!--------------------------------------------- 685 768 INTEGER, INTENT(in) :: i1, i2, j1, j2 … … 690 773 LOGICAL :: southern_side, northern_side 691 774 INTEGER :: ji, jj 692 REAL(wp) :: zrhox, za1 775 REAL(wp) :: zrhox, za1, zcor 693 776 !!--------------------------------------------- 694 777 ! … … 705 788 tabres(i1:i2,j1:j2) = tabres(i1:i2,j1:j2) * r1_e1v(i1:i2,j1:j2) 706 789 ! 707 ! Refluxing here:708 #if defined DECAL_FEEDBACK709 790 southern_side = (nb == 2).AND.(ndir == 1) 710 791 northern_side = (nb == 2).AND.(ndir == 2) … … 712 793 IF (southern_side) THEN 713 794 DO ji=i1,i2 714 sshn(ji,j1 ) = sshn(ji,j1 ) + rdt * r1_e1e2t(ji,j1 ) & 715 & * e1v(ji,j1 ) * (vb2_b(ji,j1)-tabres(ji,j1)) 795 zcor = rdt * r1_e1e2t(ji,j1 ) * e1v(ji,j1 ) * (vb2_b(ji,j1)-tabres(ji,j1)) 796 sshn(ji,j1 ) = sshn(ji,j1 ) + zcor 797 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j1 ) = sshb(ji,j1) + atfp * zcor 716 798 END DO 717 799 ENDIF 718 800 IF (northern_side) THEN 719 801 DO ji=i1,i2 720 sshn(ji,j2+1) = sshn(ji,j2+1) - rdt * r1_e1e2t(ji,j2+1) & 721 & * e1v(ji,j2 ) * (vb2_b(ji,j2)-tabres(ji,j2)) 802 zcor = - rdt * r1_e1e2t(ji,j2+1) * e1v(ji,j2 ) * (vb2_b(ji,j2)-tabres(ji,j2)) 803 sshn(ji,j2+1) = sshn(ji,j2+1) + zcor 804 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) sshb(ji,j2+1) = sshb(ji,j2+1) + atfp * zcor 722 805 END DO 723 806 ENDIF 724 807 ! 725 #endif 726 za1 = 1._wp / REAL(Agrif_rhot(), wp) 727 DO jj=j1,j2 728 DO ji=i1,i2 729 ! Update time integrated fluxes also in case of multiply nested grids: 730 vb2_i_b(ji,jj) = vb2_i_b(ji,jj) & 731 & + za1 * (tabres(ji,jj) - vb2_b(ji,jj)) 732 ! Update half step back fluxes: 733 vb2_b(ji,jj) = tabres(ji,jj) 734 END DO 735 END DO 736 ENDIF 737 ! 738 END SUBROUTINE updatevb2b 739 808 ENDIF 809 ! 810 END SUBROUTINE reflux_sshv 740 811 741 812 SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) … … 844 915 # endif /* key_zdftke */ 845 916 846 SUBROUTINE updatee3t( ptab, i1, i2, j1, j2, k1, k2, before )917 SUBROUTINE updatee3t(ptab_dum, i1, i2, j1, j2, k1, k2, before ) 847 918 !!--------------------------------------------- 848 919 !! *** ROUTINE updatee3t *** 849 920 !!--------------------------------------------- 921 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ptab_dum 850 922 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 851 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 852 LOGICAL, INTENT(in) :: before 923 LOGICAL, INTENT(in) :: before 924 ! 925 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ptab 853 926 INTEGER :: ji,jj,jk 854 927 REAL(wp) :: zcoef 855 928 !!--------------------------------------------- 856 929 ! 857 IF (before) THEN 858 !> jc tmp: 859 ! ptab(i1:i2,j1:j2,k1:k2) = e3t_n(i1:i2,j1:j2,k1:k2) 860 ptab(i1:i2,j1:j2,k1:k2) = e3t_n(i1:i2,j1:j2,k1:k2) / e3t_0(i1:i2,j1:j2,k1:k2) * tmask(i1:i2,j1:j2,k1:k2) 861 !< jc tmp: 862 ELSE 863 ! 864 ! 1) Updates at BEFORE time step: 865 ! ------------------------------- 866 ! 867 !> jc tmp: 930 IF (.NOT.before) THEN 931 ! 932 ALLOCATE(ptab(i1:i2,j1:j2,1:jpk)) 933 ! 934 ! Update e3t from ssh (z* case only) 868 935 DO jk = 1, jpkm1 869 936 DO jj=j1,j2 870 937 DO ji=i1,i2 871 IF (tmask(ji,jj,jk)==1) THEN 872 ptab(ji,jj,jk) = ptab(ji,jj,jk) * e3t_0(ji,jj,jk) 873 ELSE 874 ptab(ji,jj,jk) = e3t_0(ji,jj,jk) 875 ENDIF 876 END DO 877 END DO 878 END DO 879 ! ptab(i1:i2,j1:j2,k1:k2) = ptab(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2) 880 !< jc tmp: 881 938 ptab(ji,jj,jk) = e3t_0(ji,jj,jk) * (1._wp + sshn(ji,jj) & 939 & *ssmask(ji,jj)/(ht_0(ji,jj)-1._wp + ssmask(ji,jj))) 940 END DO 941 END DO 942 END DO 943 ! 944 ! 1) Updates at BEFORE time step: 945 ! ------------------------------- 946 ! 882 947 ! Save "old" scale factor (prior update) for subsequent asselin correction 883 ! of prognostic variables (needed to update initial state only) 884 e3t_a(i1:i2,j1:j2,k1:k2) = e3t_n(i1:i2,j1:j2,k1:k2) 885 ! hdivn(i1:i2,j1:j2,k1:k2) = e3t_b(i1:i2,j1:j2,k1:k2) 948 ! of prognostic variables 949 e3t_a(i1:i2,j1:j2,1:jpkm1) = e3t_n(i1:i2,j1:j2,1:jpkm1) 950 951 ! One should also save e3t_b, but lacking of workspace... 952 ! hdivn(i1:i2,j1:j2,1:jpkm1) = e3t_b(i1:i2,j1:j2,1:jpkm1) 886 953 887 954 IF ( (.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_exp)) & 888 955 & .OR.(.NOT.(lk_agrif_fstep.AND.(neuler==0)).AND.(ln_dynspg_ts & 889 956 & .AND.(.NOT.ln_bt_fw)))) THEN 957 ! tsplit_new 958 ! IF (.NOT.(lk_agrif_fstep.AND.(neuler==0) )) THEN 890 959 891 960 DO jk = 1, jpkm1 … … 923 992 ! 924 993 ! Update vertical scale factor at T-points: 925 e3t_n(i1:i2,j1:j2, k1:k2) = ptab(i1:i2,j1:j2,k1:k2)994 e3t_n(i1:i2,j1:j2,1:jpkm1) = ptab(i1:i2,j1:j2,1:jpkm1) 926 995 ! 927 996 ! Update total depth: … … 958 1027 ENDIF 959 1028 ! 1029 DEALLOCATE(ptab) 960 1030 ENDIF 961 1031 ! -
branches/2017/dev_r8624_AGRIF3_VVL/NEMOGCM/NEMO/OPA_SRC/step.F90
r8741 r8803 315 315 IF( Agrif_NbStepint() == 0 ) THEN ! AGRIF Update 316 316 !!jc in fact update is useless at last time step, but do it for global diagnostics 317 CALL Agrif_Update_ssh() ! Update ssh 317 318 IF(.NOT.ln_linssh) CALL Agrif_Update_vvl() ! Update vertical scale factors 318 319 CALL Agrif_Update_Tra() ! Update active tracers
Note: See TracChangeset
for help on using the changeset viewer.
