Changeset 8998 for branches/2017
- Timestamp:
- 2017-12-13T09:34:57+01:00 (6 years ago)
- Location:
- branches/2017/dev_METO_MERCATOR_2017_agrif/NEMOGCM/NEMO/NST_SRC
- Files:
-
- 5 edited
-
agrif_oce.F90 (modified) (3 diffs)
-
agrif_opa_interp.F90 (modified) (16 diffs)
-
agrif_opa_sponge.F90 (modified) (5 diffs)
-
agrif_opa_update.F90 (modified) (16 diffs)
-
agrif_user.F90 (modified) (5 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_METO_MERCATOR_2017_agrif/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90
r8993 r8998 17 17 18 18 PUBLIC agrif_oce_alloc ! routine called by nemo_init in nemogcm.F90 19 19 #if defined key_vertical 20 PUBLIC reconstructandremap ! remapping routine 21 #endif 20 22 ! !!* Namelist namagrif: AGRIF parameters 21 23 LOGICAL , PUBLIC :: ln_spc_dyn = .FALSE. !: … … 24 26 REAL(wp), PUBLIC :: rn_sponge_dyn = 2800. !: sponge coeff. for dynamics 25 27 LOGICAL , PUBLIC :: ln_chk_bathy = .FALSE. !: check of parent bathymetry 26 LOGICAL , PUBLIC :: lk_agrif_clp = .FALSE. !: Flag to retrieve clamped open boundaries 27 28 LOGICAL , PUBLIC :: lk_agrif_clp = .TRUE. !: Force clamped bcs 28 29 ! !!! OLD namelist names 29 30 REAL(wp), PUBLIC :: visc_tra !: sponge coeff. for tracers … … 101 102 END FUNCTION agrif_oce_alloc 102 103 104 #if defined key_vertical 105 SUBROUTINE reconstructandremap(tabin,hin,tabout,hout,N,Nout) 106 !!---------------------------------------------------------------------- 107 !! *** FUNCTION reconstructandremap *** 108 !!---------------------------------------------------------------------- 109 IMPLICIT NONE 110 INTEGER N, Nout 111 REAL(wp) tabin(N), tabout(Nout) 112 REAL(wp) hin(N), hout(Nout) 113 REAL(wp) coeffremap(N,3),zwork(N,3) 114 REAL(wp) zwork2(N+1,3) 115 INTEGER jk 116 DOUBLE PRECISION, PARAMETER :: dsmll=1.0d-8 117 REAL(wp) q,q01,q02,q001,q002,q0 118 REAL(wp) z_win(1:N+1), z_wout(1:Nout+1) 119 REAL(wp),PARAMETER :: dpthin = 1.D-3 120 INTEGER :: k1, kbox, ktop, ka, kbot 121 REAL(wp) :: tsum, qbot, rpsum, zbox, ztop, zthk, zbot, offset, qtop 122 123 z_win(1)=0.; z_wout(1)= 0. 124 DO jk=1,N 125 z_win(jk+1)=z_win(jk)+hin(jk) 126 ENDDO 127 128 DO jk=1,Nout 129 z_wout(jk+1)=z_wout(jk)+hout(jk) 130 ENDDO 131 132 DO jk=2,N 133 zwork(jk,1)=1./(hin(jk-1)+hin(jk)) 134 ENDDO 135 136 DO jk=2,N-1 137 q0 = 1./(hin(jk-1)+hin(jk)+hin(jk+1)) 138 zwork(jk,2)=hin(jk-1)+2.*hin(jk)+hin(jk+1) 139 zwork(jk,3)=q0 140 ENDDO 141 142 DO jk= 2,N 143 zwork2(jk,1)=zwork(jk,1)*(tabin(jk)-tabin(jk-1)) 144 ENDDO 145 146 coeffremap(:,1) = tabin(:) 147 148 DO jk=2,N-1 149 q001 = hin(jk)*zwork2(jk+1,1) 150 q002 = hin(jk)*zwork2(jk,1) 151 IF (q001*q002 < 0) then 152 q001 = 0. 153 q002 = 0. 154 ENDIF 155 q=zwork(jk,2) 156 q01=q*zwork2(jk+1,1) 157 q02=q*zwork2(jk,1) 158 IF (abs(q001) > abs(q02)) q001 = q02 159 IF (abs(q002) > abs(q01)) q002 = q01 160 161 q=(q001-q002)*zwork(jk,3) 162 q001=q001-q*hin(jk+1) 163 q002=q002+q*hin(jk-1) 164 165 coeffremap(jk,3)=coeffremap(jk,1)+q001 166 coeffremap(jk,2)=coeffremap(jk,1)-q002 167 168 zwork2(jk,1)=(2.*q001-q002)**2 169 zwork2(jk,2)=(2.*q002-q001)**2 170 ENDDO 171 172 DO jk=1,N 173 IF(jk.EQ.1 .OR. jk.EQ.N .OR. hin(jk).LE.dpthin) THEN 174 coeffremap(jk,3) = coeffremap(jk,1) 175 coeffremap(jk,2) = coeffremap(jk,1) 176 zwork2(jk,1) = 0. 177 zwork2(jk,2) = 0. 178 ENDIF 179 ENDDO 180 181 DO jk=2,N 182 q002=max(zwork2(jk-1,2),dsmll) 183 q001=max(zwork2(jk,1),dsmll) 184 zwork2(jk,3)=(q001*coeffremap(jk-1,3)+q002*coeffremap(jk,2))/(q001+q002) 185 ENDDO 186 187 zwork2(1,3) = 2*coeffremap(1,1)-zwork2(2,3) 188 zwork2(N+1,3)=2*coeffremap(N,1)-zwork2(N,3) 189 190 DO jk=1,N 191 q01=zwork2(jk+1,3)-coeffremap(jk,1) 192 q02=coeffremap(jk,1)-zwork2(jk,3) 193 q001=2.*q01 194 q002=2.*q02 195 IF (q01*q02<0) then 196 q01=0. 197 q02=0. 198 ELSEIF (abs(q01)>abs(q002)) then 199 q01=q002 200 ELSEIF (abs(q02)>abs(q001)) then 201 q02=q001 202 ENDIF 203 coeffremap(jk,2)=coeffremap(jk,1)-q02 204 coeffremap(jk,3)=coeffremap(jk,1)+q01 205 ENDDO 206 207 zbot=0.0 208 kbot=1 209 DO jk=1,Nout 210 ztop=zbot !top is bottom of previous layer 211 ktop=kbot 212 IF (ztop.GE.z_win(ktop+1)) then 213 ktop=ktop+1 214 ENDIF 215 216 zbot=z_wout(jk+1) 217 zthk=zbot-ztop 218 219 IF(zthk.GT.dpthin .AND. ztop.LT.z_wout(Nout+1)) THEN 220 221 kbot=ktop 222 DO while (z_win(kbot+1).lt.zbot.and.kbot.lt.N) 223 kbot=kbot+1 224 ENDDO 225 zbox=zbot 226 DO k1= jk+1,Nout 227 IF (z_wout(k1+1)-z_wout(k1).GT.dpthin) THEN 228 exit !thick layer 229 ELSE 230 zbox=z_wout(k1+1) !include thin adjacent layers 231 IF(zbox.EQ.z_wout(Nout+1)) THEN 232 exit !at bottom 233 ENDIF 234 ENDIF 235 ENDDO 236 zthk=zbox-ztop 237 238 kbox=ktop 239 DO while (z_win(kbox+1).lt.zbox.and.kbox.lt.N) 240 kbox=kbox+1 241 ENDDO 242 243 IF(ktop.EQ.kbox) THEN 244 IF(z_wout(jk).NE.z_win(kbox).OR.z_wout(jk+1).NE.z_win(kbox+1)) THEN 245 IF(hin(kbox).GT.dpthin) THEN 246 q001 = (zbox-z_win(kbox))/hin(kbox) 247 q002 = (ztop-z_win(kbox))/hin(kbox) 248 q01=q001**2+q002**2+q001*q002+1.-2.*(q001+q002) 249 q02=q01-1.+(q001+q002) 250 q0=1.-q01-q02 251 ELSE 252 q0 = 1.0 253 q01 = 0. 254 q02 = 0. 255 ENDIF 256 tabout(jk)=q0*coeffremap(kbox,1)+q01*coeffremap(kbox,2)+q02*coeffremap(kbox,3) 257 ELSE 258 tabout(jk) = tabin(kbox) 259 ENDIF 260 ELSE 261 IF(ktop.LE.jk .AND. kbox.GE.jk) THEN 262 ka = jk 263 ELSEIF (kbox-ktop.GE.3) THEN 264 ka = (kbox+ktop)/2 265 ELSEIF (hin(ktop).GE.hin(kbox)) THEN 266 ka = ktop 267 ELSE 268 ka = kbox 269 ENDIF !choose ka 270 271 offset=coeffremap(ka,1) 272 273 qtop = z_win(ktop+1)-ztop !partial layer thickness 274 IF(hin(ktop).GT.dpthin) THEN 275 q=(ztop-z_win(ktop))/hin(ktop) 276 q01=q*(q-1.) 277 q02=q01+q 278 q0=1-q01-q02 279 ELSE 280 q0 = 1. 281 q01 = 0. 282 q02 = 0. 283 ENDIF 284 285 tsum =((q0*coeffremap(ktop,1)+q01*coeffremap(ktop,2)+q02*coeffremap(ktop,3))-offset)*qtop 286 287 DO k1= ktop+1,kbox-1 288 tsum =tsum +(coeffremap(k1,1)-offset)*hin(k1) 289 ENDDO !k1 290 291 qbot = zbox-z_win(kbox) !partial layer thickness 292 IF(hin(kbox).GT.dpthin) THEN 293 q=qbot/hin(kbox) 294 q01=(q-1.)**2 295 q02=q01-1.+q 296 q0=1-q01-q02 297 ELSE 298 q0 = 1.0 299 q01 = 0. 300 q02 = 0. 301 ENDIF 302 303 tsum = tsum +((q0*coeffremap(kbox,1)+q01*coeffremap(kbox,2)+q02*coeffremap(kbox,3))-offset)*qbot 304 305 rpsum=1.0d0/zthk 306 tabout(jk)=offset+tsum*rpsum 307 308 ENDIF !single or multiple layers 309 ELSE 310 IF (jk==1) THEN 311 write(*,'(a7,i4,i4,3f12.5)')'problem = ',N,Nout,zthk,z_wout(jk+1),hout(1) 312 ENDIF 313 tabout(jk) = tabout(jk-1) 314 315 ENDIF !normal:thin layer 316 ENDDO !jk 317 318 return 319 end subroutine reconstructandremap 320 #endif 321 103 322 #endif 104 323 !!====================================================================== -
branches/2017/dev_METO_MERCATOR_2017_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90
r8993 r8998 118 118 ! 119 119 IF (.NOT.lk_agrif_clp) THEN 120 DO jk=1,jpkm1 ! Smooth120 DO jk=1,jpkm1 ! Smooth 121 121 DO jj=j1,j2 122 122 ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk)) … … 124 124 END DO 125 125 END DO 126 END 126 ENDIF 127 127 ! 128 128 zub(2,:) = 0._wp ! Correct transport … … 189 189 190 190 IF (.NOT.lk_agrif_clp) THEN 191 DO jk = 1, jpkm1 ! Smooth191 DO jk = 1, jpkm1 ! Smooth 192 192 DO jj = j1, j2 193 193 ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk) & … … 196 196 END DO 197 197 ENDIF 198 199 198 zub(nlci-2,:) = 0._wp ! Correct transport 200 199 DO jk = 1, jpkm1 … … 331 330 ! 332 331 IF (.NOT.lk_agrif_clp) THEN 333 DO jk = 1, jpkm1 ! Smooth332 DO jk = 1, jpkm1 ! Smooth 334 333 DO ji = i1, i2 335 334 va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk) & … … 337 336 END DO 338 337 END DO 339 END IF338 END IF 340 339 ! 341 340 zvb(:,nlcj-2) = 0._wp ! Correct transport … … 614 613 INTEGER , INTENT(in ) :: nb , ndir 615 614 ! 616 INTEGER :: ji, jj, jk, jn ! dummy loop indices617 INTEGER :: imin, imax, jmin, jmax 615 INTEGER :: ji, jj, jk, jn, iref, jref ! dummy loop indices 616 INTEGER :: imin, imax, jmin, jmax, N_in, N_out 618 617 REAL(wp) :: zrhox , zalpha1, zalpha2, zalpha3 619 618 REAL(wp) :: zalpha4, zalpha5, zalpha6, zalpha7 620 LOGICAL :: western_side, eastern_side,northern_side,southern_side 621 !!---------------------------------------------------------------------- 622 ! 619 LOGICAL :: western_side, eastern_side,northern_side,southern_side 620 ! vertical interpolation: 621 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child 622 REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin 623 REAL(wp), DIMENSION(k1:k2) :: h_in 624 REAL(wp), DIMENSION(1:jpk) :: h_out(1:jpk) 625 REAL(wp) :: h_diff, zrhoxy 626 627 zrhoxy = Agrif_rhox()*Agrif_rhoy() 623 628 IF (before) THEN 624 ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 625 ELSE 629 DO jn = 1,jpts 630 DO jk=k1,k2 631 DO jj=j1,j2 632 DO ji=i1,i2 633 ptab(ji,jj,jk,jn) = tsn(ji,jj,jk,jn) 634 END DO 635 END DO 636 END DO 637 END DO 638 639 # if defined key_vertical 640 DO jk=k1,k2 641 DO jj=j1,j2 642 DO ji=i1,i2 643 ptab(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) 644 END DO 645 END DO 646 END DO 647 # endif 648 ELSE 649 650 western_side = (nb == 1).AND.(ndir == 1) 651 eastern_side = (nb == 1).AND.(ndir == 2) 652 southern_side = (nb == 2).AND.(ndir == 1) 653 northern_side = (nb == 2).AND.(ndir == 2) 654 655 # if defined key_vertical 656 DO jj=j1,j2 657 DO ji=i1,i2 658 iref = ji 659 jref = jj 660 if(western_side) iref=MAX(2,ji) 661 if(eastern_side) iref=MIN(nlci-1,ji) 662 if(southern_side) jref=MAX(2,jj) 663 if(northern_side) jref=MIN(nlcj-1,jj) 664 N_in = 0 665 DO jk=k1,k2 !k2 = jpk of parent grid 666 IF (ptab(ji,jj,jk,n2) == 0) EXIT 667 N_in = N_in + 1 668 tabin(jk,:) = ptab(ji,jj,jk,n1:n2-1) 669 h_in(N_in) = ptab(ji,jj,jk,n2) 670 END DO 671 N_out = 0 672 DO jk=1,jpk ! jpk of child grid 673 IF (tmask(iref,jref,jk) == 0) EXIT 674 N_out = N_out + 1 675 h_out(jk) = e3t_n(iref,jref,jk) 676 ENDDO 677 IF (N_in > 0) THEN 678 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 679 DO jn=1,jpts 680 call reconstructandremap(tabin(1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) 681 ENDDO 682 ENDIF 683 ENDDO 684 ENDDO 685 # else 686 ptab_child(i1:i2,j1:j2,1:jpk,1:jpts) = ptab(i1:i2,j1:j2,1:jpk,1:jpts) 687 # endif 688 ! 626 689 IF (lk_agrif_clp) THEN 627 690 DO jn = 1, jpts … … 629 692 DO ji = i1,i2 630 693 DO jj = j1,j2 631 tsa(ji,jj,jk,jn) = ptab (ji,jj,jk,jn)694 tsa(ji,jj,jk,jn) = ptab_child(ji,jj,jk,jn) 632 695 END DO 633 696 END DO … … 636 699 return 637 700 ENDIF 638 !639 western_side = (nb == 1).AND.(ndir == 1)640 eastern_side = (nb == 1).AND.(ndir == 2)641 southern_side = (nb == 2).AND.(ndir == 1)642 northern_side = (nb == 2).AND.(ndir == 2)643 701 ! 644 702 zrhox = Agrif_Rhox() … … 667 725 IF( eastern_side ) THEN 668 726 DO jn = 1, jpts 669 tsa(nlci,j1:j2, k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn)727 tsa(nlci,j1:j2,1:jpk,jn) = zalpha1 * ptab_child(nlci,j1:j2,1:jpk,jn) + zalpha2 * ptab_child(nlci-1,j1:j2,1:jpk,jn) 670 728 DO jk = 1, jpkm1 671 729 DO jj = jmin,jmax … … 687 745 IF( northern_side ) THEN 688 746 DO jn = 1, jpts 689 tsa(i1:i2,nlcj, k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn)747 tsa(i1:i2,nlcj,1:jpk,jn) = zalpha1 * ptab_child(i1:i2,nlcj,1:jpk,jn) + zalpha2 * ptab_child(i1:i2,nlcj-1,1:jpk,jn) 690 748 DO jk = 1, jpkm1 691 749 DO ji = imin,imax … … 707 765 IF( western_side ) THEN 708 766 DO jn = 1, jpts 709 tsa(1,j1:j2, k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn)767 tsa(1,j1:j2,1:jpk,jn) = zalpha1 * ptab_child(1,j1:j2,1:jpk,jn) + zalpha2 * ptab_child(2,j1:j2,1:jpk,jn) 710 768 DO jk = 1, jpkm1 711 769 DO jj = jmin,jmax … … 726 784 IF( southern_side ) THEN 727 785 DO jn = 1, jpts 728 tsa(i1:i2,1, k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn)786 tsa(i1:i2,1,1:jpk,jn) = zalpha1 * ptab_child(i1:i2,1,1:jpk,jn) + zalpha2 * ptab_child(i1:i2,2,1:jpk,jn) 729 787 DO jk = 1, jpk 730 788 DO ji=imin,imax … … 747 805 ! East south 748 806 IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 749 tsa(nlci-1,2,:,:) = ptab (nlci-1,2,:,:)807 tsa(nlci-1,2,:,:) = ptab_child(nlci-1,2,:,1:jpts) 750 808 ENDIF 751 809 ! East north 752 810 IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 753 tsa(nlci-1,nlcj-1,:,:) = ptab (nlci-1,nlcj-1,:,:)811 tsa(nlci-1,nlcj-1,:,:) = ptab_child(nlci-1,nlcj-1,:,1:jpts) 754 812 ENDIF 755 813 ! West south 756 814 IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 757 tsa(2,2,:,:) = ptab (2,2,:,:)815 tsa(2,2,:,:) = ptab_child(2,2,:,1:jpts) 758 816 ENDIF 759 817 ! West north 760 818 IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 761 tsa(2,nlcj-1,:,:) = ptab (2,nlcj-1,:,:)819 tsa(2,nlcj-1,:,:) = ptab_child(2,nlcj-1,:,1:jpts) 762 820 ENDIF 763 821 ! … … 765 823 ! 766 824 END SUBROUTINE interptsn 767 768 825 769 826 SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir ) … … 794 851 END SUBROUTINE interpsshn 795 852 796 797 SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, before ) 853 SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir ) 798 854 !!---------------------------------------------------------------------- 799 855 !! *** ROUTINE interpun *** 800 !!---------------------------------------------------------------------- 801 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 802 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 803 LOGICAL , INTENT(in ) :: before 804 ! 805 INTEGER :: ji, jj, jk 806 REAL(wp) :: zrhoy 807 !!---------------------------------------------------------------------- 808 ! 809 IF( before ) THEN 810 DO jk = 1, jpkm1 811 ptab(i1:i2,j1:j2,jk) = e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk) 856 !!--------------------------------------------- 857 !! 858 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2 859 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab 860 LOGICAL, INTENT(in) :: before 861 INTEGER, INTENT(in) :: nb , ndir 862 !! 863 INTEGER :: ji,jj,jk 864 REAL(wp) :: zrhoy 865 ! vertical interpolation: 866 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 867 REAL(wp), DIMENSION(1:jpk) :: h_out 868 INTEGER :: N_in, N_out, iref 869 REAL(wp) :: h_diff 870 LOGICAL :: western_side, eastern_side 871 !!--------------------------------------------- 872 ! 873 zrhoy = Agrif_rhoy() 874 IF (before) THEN 875 !We can't use zero as the special value because we need to include zeros 876 !when interpolating the scale factors 877 IF(Agrif_UseSpecialValue) THEN 878 ! Agrif_SpecialValue = -999._wp 879 Agrif_SpecialValue = 0._wp 880 ELSE 881 Agrif_SpecialValue = 0._wp 882 ENDIF 883 DO jk=1,jpk 884 DO jj=j1,j2 885 DO ji=i1,i2 886 ptab(ji,jj,jk,1) = (e2u(ji,jj) * e3u_n(ji,jj,jk) * un(ji,jj,jk)*umask(ji,jj,jk)) - & 887 & ((umask(ji,jj,jk)-1) * Agrif_SpecialValue) 888 # if defined key_vertical 889 ptab(ji,jj,jk,2) = (umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk)) 890 # endif 891 END DO 892 END DO 812 893 END DO 813 894 ELSE 814 zrhoy = Agrif_Rhoy() 895 zrhoy = Agrif_rhoy() 896 # if defined key_vertical 897 ! VERTICAL REFINEMENT BEGIN 898 western_side = (nb == 1).AND.(ndir == 1) 899 eastern_side = (nb == 1).AND.(ndir == 2) 900 901 Agrif_SpecialValue = 0._wp ! reset specialvalue to zero now interpolation completed 902 903 DO ji=i1,i2 904 iref = ji 905 IF (western_side) iref = MAX(2,ji) 906 IF (eastern_side) iref = MIN(nlci-2,ji) 907 DO jj=j1,j2 908 N_in = 0 909 DO jk=k1,k2 910 IF (ptab(ji,jj,jk,2) == 0) EXIT 911 N_in = N_in + 1 912 tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2) 913 h_in(N_in) = ptab(ji,jj,jk,2)/(e2u(ji,jj)*zrhoy) 914 ENDDO 915 916 IF (N_in == 0) THEN 917 ua(ji,jj,:) = 0._wp 918 CYCLE 919 ENDIF 920 921 N_out = 0 922 DO jk=1,jpk 923 if (umask(iref,jj,jk) == 0) EXIT 924 N_out = N_out + 1 925 h_out(N_out) = e3u_a(iref,jj,jk) 926 ENDDO 927 928 IF (N_out == 0) THEN 929 ua(ji,jj,:) = 0._wp 930 CYCLE 931 ENDIF 932 933 IF (N_in * N_out > 0) THEN 934 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 935 ! Should be able to remove the next IF/ELSEIF statement once scale factors are dealt with properly 936 if (h_diff < -1.e4) then 937 print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in)) 938 ! stop 939 endif 940 ENDIF 941 call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ua(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 942 ENDDO 943 ENDDO 944 945 # else 815 946 DO jk = 1, jpkm1 816 947 DO jj=j1,j2 817 ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk) / ( zrhoy * e2u(i1:i2,jj) * e3u_a(i1:i2,jj,jk) ) 818 END DO 819 END DO 948 ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk,1) / ( zrhoy * e2u(i1:i2,jj) * e3u_a(i1:i2,jj,jk) ) 949 END DO 950 END DO 951 # endif 952 820 953 ENDIF 821 954 ! 822 955 END SUBROUTINE interpun 823 956 824 825 SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, before ) 957 SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, m1, m2, before, nb, ndir ) 826 958 !!---------------------------------------------------------------------- 827 959 !! *** ROUTINE interpvn *** 828 960 !!---------------------------------------------------------------------- 829 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 830 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 831 LOGICAL , INTENT(in ) :: before 832 ! 833 INTEGER :: ji, jj, jk 834 REAL(wp) :: zrhox 835 !!---------------------------------------------------------------------- 961 ! 962 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2 963 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab 964 LOGICAL, INTENT(in) :: before 965 INTEGER, INTENT(in) :: nb , ndir 966 ! 967 INTEGER :: ji,jj,jk 968 REAL(wp) :: zrhox 969 ! vertical interpolation: 970 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 971 REAL(wp), DIMENSION(1:jpk) :: h_out 972 INTEGER :: N_in, N_out, jref 973 REAL(wp) :: h_diff 974 LOGICAL :: northern_side,southern_side 975 !!--------------------------------------------- 836 976 ! 837 IF( before ) THEN 977 IF (before) THEN 978 IF(Agrif_UseSpecialValue) THEN 979 ! Agrif_SpecialValue = -999._wp 980 Agrif_SpecialValue = 0._wp 981 ELSE 982 Agrif_SpecialValue = 0._wp 983 ENDIF 984 DO jk=k1,k2 985 DO jj=j1,j2 986 DO ji=i1,i2 987 ptab(ji,jj,jk,1) = (e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)*vmask(ji,jj,jk)) - & 988 & ((vmask(ji,jj,jk)-1) * Agrif_SpecialValue) 989 # if defined key_vertical 990 ptab(ji,jj,jk,2) = vmask(ji,jj,jk) * e1v(ji,jj) * e3v_n(ji,jj,jk) 991 # endif 992 END DO 993 END DO 994 END DO 995 ELSE 996 zrhox = Agrif_rhox() 997 # if defined key_vertical 998 Agrif_SpecialValue = 0._wp !Reset special value to zero now interpolation is done 999 1000 southern_side = (nb == 2).AND.(ndir == 1) 1001 northern_side = (nb == 2).AND.(ndir == 2) 1002 1003 DO jj=j1,j2 1004 jref = jj 1005 IF (southern_side) jref = MAX(2,jj) 1006 IF (northern_side) jref = MIN(nlcj-2,jj) 1007 DO ji=i1,i2 1008 N_in = 0 1009 DO jk=k1,k2 1010 if (ptab(ji,jj,jk,2) == 0) EXIT 1011 N_in = N_in + 1 1012 tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2) 1013 h_in(N_in) = ptab(ji,jj,jk,2)/(e1v(ji,jj)*zrhox) 1014 END DO 1015 IF (N_in == 0) THEN 1016 va(ji,jj,:) = 0._wp 1017 CYCLE 1018 ENDIF 1019 1020 N_out = 0 1021 DO jk=1,jpk 1022 if (vmask(ji,jref,jk) == 0) EXIT 1023 N_out = N_out + 1 1024 h_out(N_out) = e3v_a(ji,jref,jk) 1025 END DO 1026 IF (N_out == 0) THEN 1027 va(ji,jj,:) = 0._wp 1028 CYCLE 1029 ENDIF 1030 call reconstructandremap(tabin(1:N_in),h_in(1:N_in),va(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 1031 END DO 1032 END DO 1033 # else 838 1034 DO jk = 1, jpkm1 839 ptab(i1:i2,j1:j2,jk) = e1v(i1:i2,j1:j2) * e3v_n(i1:i2,j1:j2,jk) * vn(i1:i2,j1:j2,jk) 840 END DO 841 ELSE 842 zrhox= Agrif_Rhox() 843 DO jk = 1, jpkm1 844 va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_a(i1:i2,j1:j2,jk) ) 845 END DO 1035 va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk,1) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_a(i1:i2,j1:j2,jk) ) 1036 END DO 1037 # endif 846 1038 ENDIF 847 1039 ! 848 1040 END SUBROUTINE interpvn 849 850 1041 851 1042 SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir ) -
branches/2017/dev_METO_MERCATOR_2017_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90
r8993 r8998 39 39 #if defined SPONGE 40 40 !! timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 41 !! Assume persistence:41 !! Assume persistence: 42 42 timecoeff = REAL(Agrif_rhot()-1,wp)/REAL(Agrif_rhot()) 43 43 … … 195 195 END SUBROUTINE Agrif_Sponge 196 196 197 198 197 SUBROUTINE interptsn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 199 198 !!--------------------------------------------- … … 207 206 INTEGER :: iku, ikv 208 207 REAL(wp) :: ztsa, zabe1, zabe2, zbtr 209 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ztu, ztv 210 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 208 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk) :: ztu, ztv 209 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tsbdiff 210 ! vertical interpolation: 211 REAL(wp), DIMENSION(i1:i2,j1:j2,jpk,n1:n2) ::tabres_child 212 REAL(wp), DIMENSION(k1:k2,n1:n2-1) :: tabin 213 REAL(wp), DIMENSION(k1:k2) :: h_in 214 REAL(wp), DIMENSION(1:jpk) :: h_out 215 INTEGER :: N_in, N_out 216 REAL(wp) :: h_diff 211 217 ! 212 218 IF( before ) THEN 213 tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsb(i1:i2,j1:j2,k1:k2,n1:n2) 219 DO jn = 1, jpts 220 DO jk=k1,k2 221 DO jj=j1,j2 222 DO ji=i1,i2 223 tabres(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) 224 END DO 225 END DO 226 END DO 227 END DO 228 229 # if defined key_vertical 230 DO jk=k1,k2 231 DO jj=j1,j2 232 DO ji=i1,i2 233 tabres(ji,jj,jk,jpts+1) = tmask(ji,jj,jk) * e3t_n(ji,jj,jk) 234 END DO 235 END DO 236 END DO 237 # endif 238 214 239 ELSE 215 240 ! 216 tsbdiff(:,:,:,:) = tsb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:) 241 # if defined key_vertical 242 tabres_child(:,:,:,:) = 0. 243 DO jj=j1,j2 244 DO ji=i1,i2 245 N_in = 0 246 DO jk=k1,k2 !k2 = jpk of parent grid 247 IF (tabres(ji,jj,jk,n2) == 0) EXIT 248 N_in = N_in + 1 249 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1) 250 h_in(N_in) = tabres(ji,jj,jk,n2) 251 END DO 252 N_out = 0 253 DO jk=1,jpk ! jpk of child grid 254 IF (tmask(ji,jj,jk) == 0) EXIT 255 N_out = N_out + 1 256 h_out(jk) = e3t_n(ji,jj,jk) !Child grid scale factors. Could multiply by e1e2t here instead of division above 257 ENDDO 258 IF (N_in > 0) THEN 259 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 260 tabres(ji,jj,k2,:) = tabres(ji,jj,k2-1,:) !what is this line for????? 261 DO jn=1,jpts 262 call reconstructandremap(tabin(1:N_in,jn),h_in,tabres_child(ji,jj,1:N_out,jn),h_out,N_in,N_out) 263 ENDDO 264 ENDIF 265 ENDDO 266 ENDDO 267 # endif 268 269 DO jj=j1,j2 270 DO ji=i1,i2 271 DO jk=1,jpkm1 272 # if defined key_vertical 273 tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres_child(ji,jj,jk,1:jpts) 274 # else 275 tsbdiff(ji,jj,jk,1:jpts) = tsb(ji,jj,jk,1:jpts) - tabres(ji,jj,jk,1:jpts) 276 # endif 277 ENDDO 278 ENDDO 279 ENDDO 280 217 281 DO jn = 1, jpts 218 282 DO jk = 1, jpkm1 … … 261 325 END SUBROUTINE interptsn_sponge 262 326 263 264 SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2, before) 327 SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before) 265 328 !!--------------------------------------------- 266 329 !! *** ROUTINE interpun_sponge *** 267 330 !!--------------------------------------------- 268 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 269 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2 ), INTENT(inout) :: tabres331 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2 332 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres 270 333 LOGICAL, INTENT(in) :: before 271 334 272 INTEGER :: ji,jj,jk 335 INTEGER :: ji,jj,jk,jmax 273 336 274 337 ! sponge parameters 275 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 276 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ubdiff 277 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 278 INTEGER :: jmax 338 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, h_diff 339 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ubdiff 340 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff 341 ! vertical interpolation: 342 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child 343 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 344 REAL(wp), DIMENSION(1:jpk) :: h_out 345 INTEGER ::N_in,N_out 279 346 !!--------------------------------------------- 280 347 ! 281 348 IF( before ) THEN 282 tabres = ub(i1:i2,j1:j2,:) 349 DO jk=1,jpkm1 350 DO jj=j1,j2 351 DO ji=i1,i2 352 tabres(ji,jj,jk,m1) = ub(ji,jj,jk) 353 # if defined key_vertical 354 tabres(ji,jj,jk,m2) = e3u_n(ji,jj,jk)*umask(ji,jj,jk) 355 # endif 356 END DO 357 END DO 358 END DO 359 283 360 ELSE 284 ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(:,:,:))*umask(i1:i2,j1:j2,:) 361 362 # if defined key_vertical 363 tabres_child(:,:,:) = 0._wp 364 DO jj=j1,j2 365 DO ji=i1,i2 366 N_in = 0 367 DO jk=k1,k2 368 IF (tabres(ji,jj,jk,m2) == 0) EXIT 369 N_in = N_in + 1 370 tabin(jk) = tabres(ji,jj,jk,m1) 371 h_in(N_in) = tabres(ji,jj,jk,m2) 372 ENDDO 373 ! 374 IF (N_in == 0) THEN 375 tabres_child(ji,jj,:) = 0. 376 CYCLE 377 ENDIF 378 379 N_out = 0 380 DO jk=1,jpk 381 if (umask(ji,jj,jk) == 0) EXIT 382 N_out = N_out + 1 383 h_out(N_out) = e3u_n(ji,jj,jk) 384 ENDDO 385 386 IF (N_out == 0) THEN 387 tabres_child(ji,jj,:) = 0. 388 CYCLE 389 ENDIF 390 391 IF (N_in * N_out > 0) THEN 392 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 393 if (h_diff < -1.e4) then 394 print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in)) 395 endif 396 ENDIF 397 call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 398 399 ENDDO 400 ENDDO 401 402 ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*umask(i1:i2,j1:j2,:) 403 #else 404 ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*umask(i1:i2,j1:j2,:) 405 #endif 285 406 ! 286 407 DO jk = 1, jpkm1 ! Horizontal slab … … 359 480 END SUBROUTINE interpun_sponge 360 481 361 362 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2, before,nb,ndir) 482 SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2,m1,m2, before,nb,ndir) 363 483 !!--------------------------------------------- 364 484 !! *** ROUTINE interpvn_sponge *** 365 485 !!--------------------------------------------- 366 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 367 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2 ), INTENT(inout) :: tabres486 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2 487 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: tabres 368 488 LOGICAL, INTENT(in) :: before 369 489 INTEGER, INTENT(in) :: nb , ndir 370 490 ! 371 INTEGER :: ji, jj, jk 372 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 373 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff 374 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 375 INTEGER :: imax 491 INTEGER :: ji, jj, jk, imax 492 REAL(wp) :: ze2u, ze1v, zua, zva, zbtr, h_diff 493 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: vbdiff 494 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: rotdiff, hdivdiff 495 ! vertical interpolation: 496 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child 497 REAL(wp), DIMENSION(k1:k2) :: tabin, h_in 498 REAL(wp), DIMENSION(1:jpk) :: h_out 499 INTEGER :: N_in, N_out 376 500 !!--------------------------------------------- 377 501 378 502 IF( before ) THEN 379 tabres = vb(i1:i2,j1:j2,:) 503 DO jk=1,jpkm1 504 DO jj=j1,j2 505 DO ji=i1,i2 506 tabres(ji,jj,jk,m1) = vb(ji,jj,jk) 507 # if defined key_vertical 508 tabres(ji,jj,jk,m2) = vmask(ji,jj,jk) * e3v_n(ji,jj,jk) 509 # endif 510 END DO 511 END DO 512 END DO 380 513 ELSE 381 ! 382 vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(:,:,:))*vmask(i1:i2,j1:j2,:) 514 515 # if defined key_vertical 516 tabres_child(:,:,:) = 0._wp 517 DO jj=j1,j2 518 DO ji=i1,i2 519 N_in = 0 520 DO jk=k1,k2 521 IF (tabres(ji,jj,jk,m2) == 0) EXIT 522 N_in = N_in + 1 523 tabin(jk) = tabres(ji,jj,jk,m1) 524 h_in(N_in) = tabres(ji,jj,jk,m2) 525 ENDDO 526 527 IF (N_in == 0) THEN 528 tabres_child(ji,jj,:) = 0. 529 CYCLE 530 ENDIF 531 532 N_out = 0 533 DO jk=1,jpk 534 if (vmask(ji,jj,jk) == 0) EXIT 535 N_out = N_out + 1 536 h_out(N_out) = e3v_n(ji,jj,jk) 537 ENDDO 538 539 IF (N_in * N_out > 0) THEN 540 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 541 if (h_diff < -1.e4) then 542 print *,'CHECK YOUR BATHY ...', h_diff, sum(h_out(1:N_out)), sum(h_in(1:N_in)) 543 endif 544 ENDIF 545 call reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 546 ENDDO 547 ENDDO 548 549 vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres_child(i1:i2,j1:j2,:))*vmask(i1:i2,j1:j2,:) 550 # else 551 vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(i1:i2,j1:j2,:,1))*vmask(i1:i2,j1:j2,:) 552 # endif 383 553 ! 384 554 DO jk = 1, jpkm1 ! Horizontal slab -
branches/2017/dev_METO_MERCATOR_2017_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90
r8993 r8998 1 1 #define TWO_WAY /* TWO WAY NESTING */ 2 # undef DECAL_FEEDBACK/* SEPARATION of INTERFACES*/2 #define DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 3 3 #undef VOL_REFLUX /* VOLUME REFLUXING*/ 4 4 … … 97 97 ! Account for updated thicknesses at boundary edges 98 98 IF (.NOT.ln_linssh) THEN 99 ! For the time being calls below do not ensure reproducible results100 99 ! CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_u_bdy) 101 100 ! CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/0,0/),locupdate2=(/0,0/),procname = correct_v_bdy) … … 283 282 END SUBROUTINE dom_vvl_update_UVF 284 283 284 #if defined key_vertical 285 286 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 287 !!--------------------------------------------- 288 !! *** ROUTINE updateT *** 289 !!--------------------------------------------- 290 INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 291 REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 292 LOGICAL, INTENT(in) :: before 293 !! 294 INTEGER :: ji,jj,jk,jn 295 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: tabres_child 296 REAL(wp) :: h_in(k1:k2) 297 REAL(wp) :: h_out(1:jpk) 298 INTEGER :: N_in, N_out 299 REAL(wp) :: h_diff 300 REAL(wp) :: zrho_xy 301 REAL(wp) :: tabin(k1:k2,n1:n2) 302 !!--------------------------------------------- 303 ! 304 IF (before) THEN 305 AGRIF_SpecialValue = -999._wp 306 zrho_xy = Agrif_rhox() * Agrif_rhoy() 307 DO jn = n1,n2-1 308 DO jk=k1,k2 309 DO jj=j1,j2 310 DO ji=i1,i2 311 tabres(ji,jj,jk,jn) = (tsn(ji,jj,jk,jn) * e1e2t(ji,jj) * e3t_n(ji,jj,jk) ) & 312 * tmask(ji,jj,jk) * zrho_xy + (tmask(ji,jj,jk)-1)*999._wp 313 END DO 314 END DO 315 END DO 316 END DO 317 DO jk=k1,k2 318 DO jj=j1,j2 319 DO ji=i1,i2 320 tabres(ji,jj,jk,n2) = tmask(ji,jj,jk) * e1e2t(ji,jj) * e3t_n(ji,jj,jk) * zrho_xy & 321 + (tmask(ji,jj,jk)-1)*999._wp 322 END DO 323 END DO 324 END DO 325 ELSE 326 tabres_child(:,:,:,:) = 0. 327 AGRIF_SpecialValue = 0._wp 328 DO jj=j1,j2 329 DO ji=i1,i2 330 N_in = 0 331 DO jk=k1,k2 !k2 = jpk of child grid 332 IF (tabres(ji,jj,jk,n2) == 0 ) EXIT 333 N_in = N_in + 1 334 tabin(jk,:) = tabres(ji,jj,jk,n1:n2-1)/tabres(ji,jj,jk,n2) 335 h_in(N_in) = tabres(ji,jj,jk,n2)/e1e2t(ji,jj) 336 ENDDO 337 N_out = 0 338 DO jk=1,jpk ! jpk of parent grid 339 IF (tmask(ji,jj,jk) < -900) EXIT ! TODO: Will not work with ISF 340 N_out = N_out + 1 341 h_out(N_out) = e3t_n(ji,jj,jk) !Parent grid scale factors. Could multiply by e1e2t here instead of division above 342 ENDDO 343 IF (N_in > 0) THEN !Remove this? 344 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 345 IF (h_diff < -1.e-4) THEN 346 print *,'CHECK YOUR bathy T points ...',ji,jj,h_diff,sum(h_in(1:N_in)),sum(h_out(1:N_out)) 347 print *,h_in(1:N_in) 348 print *,h_out(1:N_out) 349 STOP 350 ENDIF 351 DO jn=n1,n2-1 352 CALL reconstructandremap(tabin(1:N_in,jn),h_in(1:N_in),tabres_child(ji,jj,1:N_out,jn),h_out(1:N_out),N_in,N_out) 353 ENDDO 354 ENDIF 355 ENDDO 356 ENDDO 357 358 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 359 ! Add asselin part 360 DO jn = n1,n2-1 361 DO jk=1,jpk 362 DO jj=j1,j2 363 DO ji=i1,i2 364 IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 365 tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 366 & + atfp * ( tabres_child(ji,jj,jk,jn) & 367 & - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 368 ENDIF 369 ENDDO 370 ENDDO 371 ENDDO 372 ENDDO 373 ENDIF 374 DO jn = n1,n2-1 375 DO jk=1,jpk 376 DO jj=j1,j2 377 DO ji=i1,i2 378 IF( tabres_child(ji,jj,jk,jn) .NE. 0. ) THEN 379 tsn(ji,jj,jk,jn) = tabres_child(ji,jj,jk,jn) * tmask(ji,jj,jk) 380 END IF 381 END DO 382 END DO 383 END DO 384 END DO 385 ENDIF 386 ! 387 END SUBROUTINE updateTS 388 389 # else 390 285 391 SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 286 392 !!--------------------------------------------- … … 296 402 ! 297 403 IF (before) THEN 298 DO jn = n1,n2404 DO jn = 1,jpts 299 405 DO jk=k1,k2 300 406 DO jj=j1,j2 … … 310 416 ELSE 311 417 !> jc tmp 312 DO jn = n1,n2418 DO jn = 1,jpts 313 419 tabres(i1:i2,j1:j2,k1:k2,jn) = tabres(i1:i2,j1:j2,k1:k2,jn) * e3t_0(i1:i2,j1:j2,k1:k2) & 314 420 & * tmask(i1:i2,j1:j2,k1:k2) … … 317 423 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 318 424 ! Add asselin part 319 DO jn = n1,n2425 DO jn = 1,jpts 320 426 DO jk=k1,k2 321 427 DO jj=j1,j2 … … 333 439 ENDDO 334 440 ENDIF 335 DO jn = n1,n2441 DO jn = 1,jpts 336 442 DO jk=k1,k2 337 443 DO jj=j1,j2 … … 346 452 ! 347 453 IF ((neuler==0).AND.(Agrif_Nb_Step()==0) ) THEN 348 tsb(i1:i2,j1:j2,k1:k2, n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2)454 tsb(i1:i2,j1:j2,k1:k2,1:jpts) = tsn(i1:i2,j1:j2,k1:k2,1:jpts) 349 455 ENDIF 350 456 ! … … 353 459 END SUBROUTINE updateTS 354 460 355 356 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before ) 461 # endif 462 463 # if defined key_vertical 464 465 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 357 466 !!--------------------------------------------- 358 467 !! *** ROUTINE updateu *** 359 468 !!--------------------------------------------- 360 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 361 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 362 LOGICAL , INTENT(in ) :: before 469 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 470 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 471 LOGICAL , INTENT(in ) :: before 472 ! 473 INTEGER :: ji, jj, jk 474 REAL(wp) :: zrhoy 475 ! VERTICAL REFINEMENT BEGIN 476 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child 477 REAL(wp) :: h_in(k1:k2) 478 REAL(wp) :: h_out(1:jpk) 479 INTEGER :: N_in, N_out 480 REAL(wp) :: h_diff, excess, thick 481 REAL(wp) :: tabin(k1:k2) 482 ! VERTICAL REFINEMENT END 483 !!--------------------------------------------- 484 ! 485 IF( before ) THEN 486 zrhoy = Agrif_Rhoy() 487 AGRIF_SpecialValue = -999._wp 488 DO jk=k1,k2 489 DO jj=j1,j2 490 DO ji=i1,i2 491 tabres(ji,jj,jk,1) = zrhoy * e2u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) * un(ji,jj,jk) & 492 + (umask(ji,jj,jk)-1)*999._wp 493 tabres(ji,jj,jk,2) = zrhoy * umask(ji,jj,jk) * e2u(ji,jj) * e3u_n(ji,jj,jk) & 494 + (umask(ji,jj,jk)-1)*999._wp 495 END DO 496 END DO 497 END DO 498 ELSE 499 tabres_child(:,:,:) = 0. 500 AGRIF_SpecialValue = 0._wp 501 DO jj=j1,j2 502 DO ji=i1,i2 503 N_in = 0 504 h_in(:) = 0._wp 505 tabin(:) = 0._wp 506 DO jk=k1,k2 !k2=jpk of child grid 507 IF( tabres(ji,jj,jk,2) < -900) EXIT 508 N_in = N_in + 1 509 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 510 h_in(N_in) = tabres(ji,jj,jk,2)/e2u(ji,jj) 511 ENDDO 512 N_out = 0 513 DO jk=1,jpk 514 IF (umask(ji,jj,jk) == 0) EXIT 515 N_out = N_out + 1 516 h_out(N_out) = e3u_n(ji,jj,jk) 517 ENDDO 518 IF (N_in * N_out > 0) THEN 519 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 520 IF (h_diff < -1.e-4) THEN 521 !Even if bathy at T points match it's possible for the U points to be deeper in the child grid. 522 !In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell. 523 excess = 0._wp 524 DO jk=N_in,1,-1 525 thick = MIN(-1*h_diff, h_in(jk)) 526 excess = excess + tabin(jk)*thick*e2u(ji,jj) 527 tabin(jk) = tabin(jk)*(1. - thick/h_in(jk)) 528 h_diff = h_diff + thick 529 IF ( h_diff == 0) THEN 530 N_in = jk 531 h_in(jk) = h_in(jk) - thick 532 EXIT 533 ENDIF 534 ENDDO 535 ENDIF 536 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 537 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e2u(ji,jj)*h_out(N_out)) 538 ENDIF 539 ENDDO 540 ENDDO 541 542 DO jk=1,jpk 543 DO jj=j1,j2 544 DO ji=i1,i2 545 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 546 ub(ji,jj,jk) = ub(ji,jj,jk) & 547 & + atfp * ( tabres_child(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 548 ENDIF 549 ! 550 un(ji,jj,jk) = tabres_child(ji,jj,jk) * umask(ji,jj,jk) 551 END DO 552 END DO 553 END DO 554 ENDIF 555 ! 556 END SUBROUTINE updateu 557 558 #else 559 560 SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 561 !!--------------------------------------------- 562 !! *** ROUTINE updateu *** 563 !!--------------------------------------------- 564 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 565 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 566 LOGICAL , INTENT(in ) :: before 363 567 ! 364 568 INTEGER :: ji, jj, jk … … 369 573 zrhoy = Agrif_Rhoy() 370 574 DO jk = k1, k2 371 tabres(i1:i2,j1:j2,jk ) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk)575 tabres(i1:i2,j1:j2,jk,1) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk) 372 576 END DO 373 577 ELSE … … 375 579 DO jj=j1,j2 376 580 DO ji=i1,i2 377 tabres(ji,jj,jk ) = tabres(ji,jj,jk) * r1_e2u(ji,jj)581 tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e2u(ji,jj) 378 582 ! 379 583 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 380 584 zub = ub(ji,jj,jk) * e3u_b(ji,jj,jk) ! fse3t_b prior update should be used 381 585 zuno = un(ji,jj,jk) * e3u_a(ji,jj,jk) 382 zunu = tabres(ji,jj,jk )586 zunu = tabres(ji,jj,jk,1) 383 587 ub(ji,jj,jk) = ( zub + atfp * ( zunu - zuno) ) & 384 588 & * umask(ji,jj,jk) / e3u_b(ji,jj,jk) 385 589 ENDIF 386 590 ! 387 un(ji,jj,jk) = tabres(ji,jj,jk ) * umask(ji,jj,jk) / e3u_n(ji,jj,jk)591 un(ji,jj,jk) = tabres(ji,jj,jk,1) * umask(ji,jj,jk) / e3u_n(ji,jj,jk) 388 592 END DO 389 593 END DO … … 398 602 END SUBROUTINE updateu 399 603 400 SUBROUTINE correct_u_bdy( tabres, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 604 # endif 605 606 SUBROUTINE correct_u_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 401 607 !!--------------------------------------------- 402 608 !! *** ROUTINE correct_u_bdy *** 403 609 !!--------------------------------------------- 404 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2405 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2 ), INTENT(inout) :: tabres406 LOGICAL , INTENT(in ) :: before407 INTEGER , INTENT(in) :: nb, ndir610 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 611 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 612 LOGICAL , INTENT(in ) :: before 613 INTEGER , INTENT(in) :: nb, ndir 408 614 !! 409 615 LOGICAL :: western_side, eastern_side … … 442 648 END SUBROUTINE correct_u_bdy 443 649 444 445 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before) 650 # if defined key_vertical 651 652 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 446 653 !!--------------------------------------------- 447 654 !! *** ROUTINE updatev *** 448 655 !!--------------------------------------------- 449 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2 450 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 451 LOGICAL , INTENT(in ) :: before 656 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 657 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 658 LOGICAL , INTENT(in ) :: before 659 ! 660 INTEGER :: ji, jj, jk 661 REAL(wp) :: zrhox 662 ! VERTICAL REFINEMENT BEGIN 663 REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: tabres_child 664 REAL(wp) :: h_in(k1:k2) 665 REAL(wp) :: h_out(1:jpk) 666 INTEGER :: N_in, N_out 667 REAL(wp) :: h_diff, excess, thick 668 REAL(wp) :: tabin(k1:k2) 669 ! VERTICAL REFINEMENT END 670 !!--------------------------------------------- 671 ! 672 IF (before) THEN 673 zrhox = Agrif_Rhox() 674 AGRIF_SpecialValue = -999._wp 675 DO jk=k1,k2 676 DO jj=j1,j2 677 DO ji=i1,i2 678 tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) * vn(ji,jj,jk) & 679 + (vmask(ji,jj,jk)-1)*999._wp 680 tabres(ji,jj,jk,2) = vmask(ji,jj,jk) * zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) & 681 + (vmask(ji,jj,jk)-1)*999._wp 682 END DO 683 END DO 684 END DO 685 ELSE 686 tabres_child(:,:,:) = 0. 687 AGRIF_SpecialValue = 0._wp 688 DO jj=j1,j2 689 DO ji=i1,i2 690 N_in = 0 691 DO jk=k1,k2 692 IF (tabres(ji,jj,jk,2) < -900) EXIT 693 N_in = N_in + 1 694 tabin(jk) = tabres(ji,jj,jk,1)/tabres(ji,jj,jk,2) 695 h_in(N_in) = tabres(ji,jj,jk,2)/e1v(ji,jj) 696 ENDDO 697 N_out = 0 698 DO jk=1,jpk 699 IF (vmask(ji,jj,jk) == 0) EXIT 700 N_out = N_out + 1 701 h_out(N_out) = e3v_n(ji,jj,jk) 702 ENDDO 703 IF (N_in * N_out > 0) THEN 704 h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in)) 705 IF (h_diff < -1.e-4) then 706 !Even if bathy at T points match it's possible for the U points to be deeper in the child grid. 707 !In this case we need to move transport from the child grid cells below bed of parent grid into the bottom cell. 708 excess = 0._wp 709 DO jk=N_in,1,-1 710 thick = MIN(-1*h_diff, h_in(jk)) 711 excess = excess + tabin(jk)*thick*e2u(ji,jj) 712 tabin(jk) = tabin(jk)*(1. - thick/h_in(jk)) 713 h_diff = h_diff + thick 714 IF ( h_diff == 0) THEN 715 N_in = jk 716 h_in(jk) = h_in(jk) - thick 717 EXIT 718 ENDIF 719 ENDDO 720 ENDIF 721 CALL reconstructandremap(tabin(1:N_in),h_in(1:N_in),tabres_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out) 722 tabres_child(ji,jj,N_out) = tabres_child(ji,jj,N_out) + excess/(e1v(ji,jj)*h_out(N_out)) 723 ENDIF 724 ENDDO 725 ENDDO 726 727 DO jk=1,jpk 728 DO jj=j1,j2 729 DO ji=i1,i2 730 ! 731 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 732 vb(ji,jj,jk) = vb(ji,jj,jk) & 733 & + atfp * ( tabres_child(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 734 ENDIF 735 ! 736 vn(ji,jj,jk) = tabres_child(ji,jj,jk) * vmask(ji,jj,jk) 737 END DO 738 END DO 739 END DO 740 ENDIF 741 ! 742 END SUBROUTINE updatev 743 744 # else 745 746 SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before) 747 !!--------------------------------------------- 748 !! *** ROUTINE updatev *** 749 !!--------------------------------------------- 750 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 751 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 752 LOGICAL , INTENT(in ) :: before 452 753 ! 453 754 INTEGER :: ji, jj, jk … … 460 761 DO jj=j1,j2 461 762 DO ji=i1,i2 462 tabres(ji,jj,jk ) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)763 tabres(ji,jj,jk,1) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk) 463 764 END DO 464 765 END DO … … 468 769 DO jj=j1,j2 469 770 DO ji=i1,i2 470 tabres(ji,jj,jk ) = tabres(ji,jj,jk) * r1_e1v(ji,jj)771 tabres(ji,jj,jk,1) = tabres(ji,jj,jk,1) * r1_e1v(ji,jj) 471 772 ! 472 773 IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 473 774 zvb = vb(ji,jj,jk) * e3v_b(ji,jj,jk) ! fse3t_b prior update should be used 474 775 zvno = vn(ji,jj,jk) * e3v_a(ji,jj,jk) 475 zvnu = tabres(ji,jj,jk )776 zvnu = tabres(ji,jj,jk,1) 476 777 vb(ji,jj,jk) = ( zvb + atfp * ( zvnu - zvno) ) & 477 778 & * vmask(ji,jj,jk) / e3v_b(ji,jj,jk) 478 779 ENDIF 479 780 ! 480 vn(ji,jj,jk) = tabres(ji,jj,jk ) * vmask(ji,jj,jk) / e3v_n(ji,jj,jk)781 vn(ji,jj,jk) = tabres(ji,jj,jk,1) * vmask(ji,jj,jk) / e3v_n(ji,jj,jk) 481 782 END DO 482 783 END DO … … 491 792 END SUBROUTINE updatev 492 793 493 SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, before, nb, ndir ) 794 # endif 795 796 SUBROUTINE correct_v_bdy( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir ) 494 797 !!--------------------------------------------- 495 798 !! *** ROUTINE correct_u_bdy *** 496 799 !!--------------------------------------------- 497 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2498 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2 ), INTENT(inout) :: tabres499 LOGICAL , INTENT(in ) :: before500 INTEGER , INTENT(in) :: nb, ndir800 INTEGER , INTENT(in ) :: i1, i2, j1, j2, k1, k2, n1, n2 801 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 802 LOGICAL , INTENT(in ) :: before 803 INTEGER , INTENT(in) :: nb, ndir 501 804 !! 502 805 LOGICAL :: southern_side, northern_side -
branches/2017/dev_METO_MERCATOR_2017_agrif/NEMOGCM/NEMO/NST_SRC/agrif_user.F90
r8993 r8998 1 # undefUPD_HIGH /* MIX HIGH UPDATE */1 #define UPD_HIGH /* MIX HIGH UPDATE */ 2 2 #if defined key_agrif 3 3 !!---------------------------------------------------------------------- … … 330 330 IF (Agrif_Root()) RETURN 331 331 ! 332 CALL Agrif_Update_ssh()333 332 IF (.NOT.ln_linssh) CALL Agrif_Update_vvl() 334 333 CALL Agrif_Update_tra() 335 334 #if defined key_top 336 335 CALL Agrif_Update_Trc() 337 336 #endif 338 337 CALL Agrif_Update_dyn() 339 338 # if defined key_zdftke 340 339 ! JC remove update because this precludes from perfect restartability 341 !! 340 !! CALL Agrif_Update_tke(0) 342 341 # endif 343 342 … … 364 363 ! 1. Declaration of the type of variable which have to be interpolated 365 364 !--------------------------------------------------------------------- 365 # if defined key_vertical 366 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_id) 367 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts+1/),tsn_sponge_id) 368 369 CALL agrif_declare_variable((/1,2,0,0/),(/2,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_interp_id) 370 CALL agrif_declare_variable((/2,1,0,0/),(/3,2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_interp_id) 371 CALL agrif_declare_variable((/1,2,0,0/),(/2,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_update_id) 372 CALL agrif_declare_variable((/2,1,0,0/),(/3,2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_update_id) 373 CALL agrif_declare_variable((/1,2,0,0/),(/2,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),un_sponge_id) 374 CALL agrif_declare_variable((/2,1,0,0/),(/3,2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,2/),vn_sponge_id) 375 # else 366 376 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 367 377 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 368 378 369 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 370 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 371 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 372 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 373 CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 374 CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 379 CALL agrif_declare_variable((/1,2,0,0/),(/2,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_interp_id) 380 CALL agrif_declare_variable((/2,1,0,0/),(/3,2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_interp_id) 381 CALL agrif_declare_variable((/1,2,0,0/),(/2,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_update_id) 382 CALL agrif_declare_variable((/2,1,0,0/),(/3,2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_update_id) 383 CALL agrif_declare_variable((/1,2,0,0/),(/2,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),un_sponge_id) 384 CALL agrif_declare_variable((/2,1,0,0/),(/3,2,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,1/),vn_sponge_id) 385 # endif 375 386 376 387 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) … … 392 403 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/), en_id) 393 404 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),avt_id) 405 # if defined key_vertical 406 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,2/),avm_id) 407 # else 394 408 CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),avm_id) 409 # endif 395 410 # endif 396 411 … … 777 792 ! 1. Declaration of the type of variable which have to be interpolated 778 793 !--------------------------------------------------------------------- 794 # if defined key_vertical 795 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_id) 796 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra+1/),trn_sponge_id) 797 # else 779 798 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 780 799 CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 800 # endif 781 801 782 802 ! 2. Type of interpolation
Note: See TracChangeset
for help on using the changeset viewer.
