!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! ELFE: ! ! A Three-Dimensional Baroclinic Model for Unstructured Grids ! ! Version 1.5e (July 2006) ! ! ! ! Center for Coastal and Land-Margin Research ! ! Department of Environmental Science and Engineering ! ! OGI School of Science and Engineering, ! ! Oregon Health & Science University ! ! Beaverton, Oregon 97006, USA ! ! ! ! Scientific direction: Antonio Baptista ! ! Code development: Joseph Zhang ! ! ! ! Copyright 2003-2004 Oregon Health and Science University ! ! All Rights Reserved ! ! ! ! The heat exchange module makes use of the bulk aerodynamic surface flux ! ! algorithm introduced by Zeng et al (1998), and the polynomial fits to ! ! saturation vapor pressure of Flatau et al (1992): ! ! Zeng, X., M. Zhao, and R. E. Dickinson, 1998: Intercomparison of bulk ! ! aerodynamic algorithms for the computation of sea surface fluxes using ! ! TOGA COARE and TAO data. J. Clim., 11, 2628-2644. ! ! Flatau, P. J., R. L. Walko and W. R. Cotton, 1992: Polynomial fits to ! ! saturation vapor pressure. J. Appl. Meteor., 31, 1507-1513. ! ! ! ! Attenuation of solar radiation (and solar heating) within the water column ! ! is based upon the expression given by Paulson and Simpson (1977), for the ! ! water types defined by Jerlov (1968): ! ! Jerlov, N. G., Optical Oceanography, Elsevier, 1968. ! ! Paulson, C. A., and J. J. Simpson, Irradiance measurements in the upper ! ! ocean, J. Phys. Oceanogr., 7, 952-956, 1977. ! ! ! ! In addition, the module must be linked with netcdf library. ! ! The GOTM option was taken from gotm.net. ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! !... Data type consts module kind_par implicit none integer, parameter :: sng_kind1=4 integer, parameter :: dbl_kind1=8 real(kind=dbl_kind1), parameter :: small1=1.e-6 !small non-negative number; must be identical to that in global end module kind_par !... definition of variables !... ! !************************************************************************ ! mnp < mne < mns * !************************************************************************ ! module global implicit none integer, parameter :: sng_kind=4 integer, parameter :: dbl_kind=8 !... Dimensioning parameters integer, parameter :: mnp=20000 integer, parameter :: mne=40000 integer, parameter :: mns=60000 integer, parameter :: mnv=40 ! user-defined tracer part integer, parameter :: ntracers=0 ! end user-defined tracer part integer, parameter :: mntr=max(2,ntracers) integer, parameter :: mnei=20 !neighbor integer, parameter :: mne_kr=20000 !max. # of elements used in Kriging integer, parameter :: mnei_kr=45 !max. # of pts used in Kriging integer, parameter :: mnope=9 !# of open bnd segements integer, parameter :: mnond=1000 !max. # of open-bnd nodes on each segment integer, parameter :: mnland=220 !# of land bnd segements integer, parameter :: mnlnd=10000 !max. # of land nodes on each segment integer, parameter :: mnbfr=15 !# of forcing freqs. integer, parameter :: itmax=5000 !# of iteration for itpack solvers used for dimensioning integer, parameter :: nwksp=6*mnp+4*itmax !available work space for itpack solvers integer, parameter :: nbyte=4 integer, parameter :: mnout=100 !max. # of output files integer, parameter :: mirec=1109000000 !max. record # to prevent output ~> 4GB real(kind=dbl_kind), parameter :: small1=1.e-6 !small non-negative number; must be identical to that in kind_par !... Important variables integer :: np,ne,ns,nvrt,ivcor,itheta_1,itheta_2,kz,nsig,imm,kr_co,indvel,ihconsv,isconsv real(kind=dbl_kind) :: h0,q2min,rho0,dt,pi,theta_b,theta_f,h_c,tempmin,tempmax,saltmin,saltmax,vis_coe1,vis_coe2 real(kind=dbl_kind) :: h_s,s_con1 !hyperbolic functions used in ivcor=2 ! Consts. used in GLS closure character(len=2) :: mid,stab real(kind=dbl_kind) :: ubd0,ubd1,ubd2,ubd3,ubd4,ubd5,ubs0,ubs1,ubs2,ubs4,ubs5,ubs6, & &a2_cm03,schk,schpsi !... Output handles character(len=48) :: start_time,version,data_format='DataFormat v5.0' ! ' (ylz: for appearance) character(len=12) :: ifile_char character(len=48), dimension(mnout) :: outfile,variable_nm,variable_dim integer :: nrec,nspool,igmp,noutgm,ifile,noutput,ifort12(100) integer, dimension(mnout) :: ichan,irec,iof ! real(kind=dbl_kind), dimension(mnout) :: vpos ! evm character buffers for binary type conversions integer :: iwrite character(len=48) :: a_48 character(len=16) :: a_16 character(len=8) :: a_8 character(len=4) :: a_4 !... 1D arrays integer :: kfp(mnp) !only for sflux routines integer :: kbp(mnp),kbs(mns),kbe(mne),kbp00(mnp) integer :: nne(mnp),nnp(mnp),idry(mnp),idry_s(mns),idry_e(mne),idry_e0(mne), & &isbnd(mnp),isbs(mns),iback(mnp),interpol(mne),ie_kr(mne),lqk(mne),krvel(mne) real(kind=dbl_kind), dimension(mnp) :: x,y,dp,hmod,eta1,eta2,xlmin2,xlon,ylat,bdef,bdef1,bdef2,dp00 real(kind=dbl_kind), dimension(mne) :: area,radiel,xctr,yctr,dpe real(kind=dbl_kind), dimension(mns) :: snx,sny,distj,xcj,ycj,dps real(kind=dbl_kind), dimension(mnv) :: sigma,cs,dcs,ztot real(kind=dbl_kind) :: decorrel(mne_kr) !... 2D and higher arrays integer :: nm(mne,3),nx(3,2),ic3(mne,3),ine(mnp,mnei),js(mne,3),is(mns,2), & &isidenode(mns,2),inp(mnp,mnei),iself(mnp,mnei),isidenei(mns,2),isidenei2(mns,4), & &itier_nd(mne_kr,0:mnei_kr) real(kind=dbl_kind) :: ssign(mne,3),z(mnv,mnp),zs(mnv,mns),ze(mnv,mne),su2(mnv,mns),sv2(mnv,mns), & &tem0(mnv,mnp),sal0(mnv,mnp),tnd(mnv,mnp),snd(mnv,mnp),tsd(mnv,mns),ssd(mnv,mns), & &prho(mnp,mnv),q2(mnp,mnv),xl(mnp,mnv),we(mnv,mne),sig_t(mnp,mnv),side_ac(mns,2,2),side_x(mns,2),dfh(mnp,mnv) ! Note: q2 is TKE as in GLS model (=u_i*u_i/2) real(kind=dbl_kind), dimension(mnv,mnp) :: uu2,vv2,ww2 real(kind=dbl_kind), dimension(mnv,mne,3) :: ufg,vfg real(kind=dbl_kind) :: dl(mne,3,2),akrmat_nd(mne_kr,mnei_kr+3,mnei_kr+3) ! Arrays used in transport routine real(kind=dbl_kind) :: tsel(mnv,mne,2) !S,T at elements and half levels for upwind scheme real(kind=dbl_kind) :: tr_el(mnv,mne,mntr) !tracer converntration @ prism center; used as temp. storage real(kind=dbl_kind) :: bdy_frc(mnv,mne,mntr) !body force at prism center Q_{i,k} real(kind=dbl_kind) :: flx_sf(mne,mntr) !surface b.c. \kappa*dC/dz = flx_sf (at element center) real(kind=dbl_kind) :: flx_bt(mne,mntr) !bottom b.c. end module global !... Main program program elfe use global #ifdef USE_GOTM use turbulence, only: init_turbulence, do_turbulence, cde, tke1d => tke, eps1d => eps, L1d => L, num1d => num, nuh1d => nuh use mtridiagonal, only: init_tridiagonal #endif implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) !... Output handles real(kind=sng_kind) :: floatout,floatout2,st,en character(len=12) :: it_char character(len=40) :: date,timestamp character(len=2) :: tvd_mid,flimiter,tvd_mid2,flimiter2 logical :: up_tvd !... Geometry dimension xlon_e(mne),ylat_e(mne),cwidth(mnope) dimension sigmap(mnv,10),sigma_prod(mnv,mnv,-4:4) dimension icolor1(mnp),icolor2(mns),ifront(mnei_kr),ifront2(mnei_kr) dimension akr(mnei_kr+3,mnei_kr+3) !,bkr(mnei_kr+3,1) dimension akrp((mnei_kr+3)*(mnei_kr+4)/2),ipiv(mnei_kr+3),work4(mnei_kr+3) ! dimension akrmat_nd(mne_kr,mnei_kr+3,mnei_kr+3),akrmat_sd(mne_kr,mnei_kr+3,mnei_kr+3) !... Boundary forcings dimension nond(mnope),iond(mnope,mnond),nlnd(mnland),ilnd(mnland,mnlnd) dimension iettype(mnope),ifltype(mnope),itetype(mnope),isatype(mnope),tobc(mnope),sobc(mnope),itrtype(mnope) dimension tamp(mnbfr),tnf(mnbfr),tfreq(mnbfr),jspc(mnbfr),tear(mnbfr) dimension amig(mnbfr),ff(mnbfr),face(mnbfr) dimension emo(mnope,mnond,mnbfr),efa(mnope,mnond,mnbfr) dimension vmo(mnope,mnbfr),vfa(mnope,mnbfr) dimension eth(mnope,mnond),tth(mnope,mnond,mnv),sth(mnope,mnond,mnv),qthcon(mnope),ath(mnope),trth(mnope,ntracers) dimension uth(mns,mnv),vth(mns,mnv),uthnd(mnope,mnond,mnv),vthnd(mnope,mnond,mnv) dimension eta_mean(mnp),atd(mnope),z_r(mnv),tem1(mnv),sal1(mnv) !... Flow arrays dimension ptbt(mns,mnv,4),sdbt(mns,mnv,4),bubt(mne,2) !ptbt dimension enlarged for flux limiters ! dimension x3bt(mnp,mnv,3),nelvbt(mnp,mnv,2),x3bt2(3,mnv,3),nelvbt2(3,mnv,2) dimension out3(mnv,3),out2(12) dimension windx1(mnp),windy1(mnp),windx2(mnp),windy2(mnp) dimension windx(mnp),windy(mnp),tau(mnp,2),iadv(mnp),nsubd(mnp),windfactor(mnp) dimension pr1(mnp),airt1(mnp),shum1(mnp),pr2(mnp),airt2(mnp),shum2(mnp),pr(mnp) dimension sflux(mnp),srad(mnp),tauxz(mnp),tauyz(mnp) dimension fluxsu(mnp),fluxlu(mnp),hradu(mnp),hradd(mnp) dimension chi(mns),cori(mns),Cd(mns),Cdp(mnp),rough(mns),rough_p(mnp) dimension dfv(mnp,mnv),dfz(2:mnv),dzz(2:mnv) !,dz2(mnv) dimension hvis(mnv,mns),d2u(mnv,mns),d2v(mnv,mns),horcon(mns) dimension icoef(mnp+1),jcoef(mnp*(mnei+1)),e2coef(mnp*(mnei+1)),qel(mnp) dimension sparsem(mnp,0:mnei),elbc(mnp),imap(mnp),qel2(mnp),eta3(mnp) dimension hhat(mns),bigu(mns,2),ghat1(mne,2),sne(mnv,3),area_e(mnv) dimension bcc(mns,mnv,2),hp_int(mnv,mne,2),ctmp(0:mnv) !hp_int indices reversed dimension ibt_p(mnp),ibt_s(mns),t_nudge(mnp),s_nudge(mnp),dr_ds(mnp,mnv) dimension fun_lat(mnp,0:2),etp(mnp) !fun_lat_e(mne,0:2) dimension dav(mnp,2) dimension elevmax(mnp) !max. elev. at nodes for all steps for tsunami dimension fluxprc(mnp),fluxevp(mnp) real(kind=dbl_kind),dimension(0:mnv) :: h1d,SS1d,NN1d !,num1d,nuh1d real(kind=sng_kind), dimension(mnp,mnv) :: tnd_nu1,snd_nu1,tnd_nu2,snd_nu2,tnd_nu,snd_nu dimension trel0(mnv,mne,ntracers),trel(mnv,mne,ntracers),tr_nd(mnv,mnp,ntracers) !... Wild-card arrays dimension nwild(mne+12),nwild2(mne),swild(mnp+mnv+12+ntracers),swild2(mnv,10) !swild2 dimension must match that in vinter() dimension swild5(3,2),swild6(4,2),swild4(mns,mnv,2),swild7(2,2,2) !... Solver arrays for TRIDAG dimension alow(mnv),bdia(mnv),cupp(mnv),rrhs(mnv,100),soln(mnv,100),gam(mnv) !"100" in rrhs & soln must match tridag() ! MY-G turbulence closure arrays dimension diffmax(mnp),diffmin(mnp),dfq1(mnp,mnv),dfq2(mnp,mnv),q2tmp(mnv),xltmp(mnv) dimension rzbt(mnv),shearbt(2:mnv),xlmax(mnv),cpsi3(2:mnv),cpsi2p(2:mnv),q2ha(2:mnv),xlha(2:mnv) dimension xlsc0(mnp) !... variables used by the itpack solvers dimension iwksp(3*mnp),wksp(nwksp),iparm(12),rparm(12) !... !... First executible statement of Elfe !... if(mnp>=mne.or.mne>=mns) then write(*,*)'Make sure mnp < mne < mns' stop endif !... Tracer transport if(ntracers<0) then write(11,*)'Illegal ntracers:',ntracers stop endif !... Initialize arrays and variables isbnd=0 isbs=0 iback=0 !back-up flags for abnormal cases in S-coord. pr1=0; pr2=0; pr=0 !uniform pressure (the const. is unimportant) uth=-99; vth=-99; uthnd=-99; vthnd=-99; eta_mean=-99 !flags fluxsu00=0; srad00=0 !for nws/=3 elevmax=-1.e34 ! tsel and trel for passing on to routine; use allocatable arrays later tsel=0; trel=0 ! for output airt1=0; shum1=0; airt2=0; shum2=0; srad=0; fluxsu=0; fluxlu=0 hradu=0; hradd=0; sflux=0; windx=0; windy=0 q2=0; xl=0 !for hotstart with itur/=3 only ! Fort.12 flags ifort12=0 !... define some constants and initial values !... omega=7.29d-5 !angular freq. of earth rotation rearth=6378206.4 !earth radius g=9.81 rho0=1000. !ref. density for S=33 and T=10C pi=dacos(-1.0d0) shw=4184 !specific heat of pure water do i=1,3 do j=1,2 nx(i,j)=i+j if(nx(i,j)>3) nx(i,j)=nx(i,j)-3 if(nx(i,j)<1.or.nx(i,j)>3) then write(*,*)'nx wrong',i,j,nx(i,j) stop endif enddo !j enddo !i ! * !****************************************************************************** ! * ! open input files * ! * !****************************************************************************** ! * open(14,file='hgrid.gr3',status='old') open(15,file='param.in',status='old') open(19,file='vgrid.in',status='old') open(11,file='fort.11') !fatal error message output open(12,file='fort.12') !non-fatal error message output open(16,file='mirror.out') open(10,file='total.dat') !output total mass etc. call date_and_time(date,timestamp) write(16,*)'Run begins at ',date,timestamp !... read the vertical layers information from vgrid.in !... ivcor=2 !S only read(19,*) nvrt,kz,h_s !kz>=1 if(nvrt>mnv.or.nvrt<3) then write(11,*)'nvrt > mnv or nvrt<4' stop endif if(kz<1.or.kz>nvrt-2) then write(11,*)'Wrong kz:',kz stop endif if(h_s<10) then write(11,*)'h_s needs to be larger:',h_s stop endif ! # of z-levels excluding "bottom" at h_s read(19,*) !for adding comment "Z levels" do k=1,kz-1 read(19,*)j,ztot(k) if(k>1.and.ztot(k)<=ztot(k-1).or.ztot(k)>=-h_s) then write(11,*)'z-level inverted:',k stop endif enddo !k read(19,*) !level kz ! In case kz=1, there is only 1 ztot(1)=-h_s ztot(kz)=-h_s nsig=nvrt-kz+1 !# of S levels (including "bottom" & f.s.) read(19,*) !for adding comment "S levels" read(19,*)h_c,theta_b,theta_f if(h_c<5) then !large h_c to avoid 2nd type abnormaty write(11,*)'h_c needs to be larger:',h_c stop endif if(theta_b<0.or.theta_b>1) then write(11,*)'Wrong theta_b:',theta_b stop endif if(theta_f<=0) then write(11,*)'Wrong theta_f:',theta_f stop endif ! Pre-compute constants s_con1=dsinh(theta_f) sigma(1)=-1 !bottom sigma(nsig)=0 !surface read(19,*) !level kz do k=kz+1,nvrt-1 kin=k-kz+1 read(19,*) j,sigma(kin) if(sigma(kin)<=sigma(kin-1).or.sigma(kin)>=0) then write(11,*)'Check sigma levels at:',k,sigma(kin),sigma(kin-1) stop endif enddo read(19,*) !level nvrt close(19) ! Compute C(s) and C'(s) do k=1,nsig cs(k)=(1-theta_b)*dsinh(theta_f*sigma(k))/dsinh(theta_f)+ & &theta_b*(dtanh(theta_f*(sigma(k)+0.5))-dtanh(theta_f*0.5))/2/dtanh(theta_f*0.5) dcs(k)=(1-theta_b)*theta_f*dcosh(theta_f*sigma(k))/dsinh(theta_f)+ & &theta_b*theta_f/2/dtanh(theta_f*0.5)/dcosh(theta_f*(sigma(k)+0.5))**2 enddo !k=1,nvrt !... Output some sample z-coordinates write(16,*)'---------------------------------------------' swild(1)=20; swild(2)=h_s/2; swild(3)=h_s; swild(4)=4000 write(16,*)'h_c= ',h_c,' h_s=',h_s do i=1,4 write(16,*)'Depth= ',swild(i) do k=kz,nvrt kin=k-kz+1 hmod2=dmin1(swild(i),h_s) if(hmod2<=h_c) then zz=sigma(kin)*hmod2 else zz=h_c*sigma(kin)+(hmod2-h_c)*cs(kin) endif write(16,*)k,zz enddo !k enddo !i write(16,*)'---------------------------------------------' !... read unit 15 file !... read(15,'(a48)') version read(15,'(a48)') start_time read(15,*) ipre !pre-processing flag (to output obs.out) read(15,*) nscreen read(15,*) iwrite !write mode read(15,*) imm !0: without bed deformation; 1: with bed deformation (e.g., tsunami) ! For moving bed, the output is from original bottom to nvrt if(imm<0.or.imm>1) then write(11,*)'Unknown imm',imm stop endif ! Initialize variables used in tsunami model (but bdef[1,2] and ibdef are available for all models) bdef=0 !total deformation ibdef=1 !# of time steps for deformation (deformation rate=0 when it>ibdef) if(imm==1) then !read in deformation at all nodes read(15,*) ibdef open(32,file='bdef.gr3',status='old') !connectivity part not used read(32,*) read(32,*)ntmp,np do i=1,np read(32,*)j,xtmp,ytmp,bdef(i) !total deformation enddo !i close(32) endif read(15,*) ihot if(ihot<0.or.ihot>2) then write(11,*)'Unknown ihot',ihot stop endif read(15,*) ics if(ics/=1.and.ics/=2) then write(11,*)'Unknown ics',ics stop endif !... Center of projection in degrees read(15,*) slam0,sfea0 slam0=slam0*pi/180 sfea0=sfea0*pi/180 !... Horizontal viscosity option read(15,*) ihorcon !=0 means all horcon=0 and no horcon.gr3 is needed !... Enough info to read unit 14 grid file !... read(14,*) read(14,*) ne,np if(ne>mne.or.np>mnp) then write(11,*)'Increase mne/mnp',mne,mnp,ne,np stop endif dpmax=0 !max. depth do i=1,np if(ics==1) then read(14,*) j,x(i),y(i),dp(i) else !=2 read(14,*) j,xlon(i),ylat(i),dp(i) ylat(i)=ylat(i)*pi/180 xlon(i)=xlon(i)*pi/180 call cpp(x(i),y(i),xlon(i),ylat(i),slam0,sfea0) endif hmod(i)=dmin1(dp(i),h_s) if(dp(i)>dpmax) dpmax=dp(i) enddo !i=1,np ! Save intial depth for bed deformation case dp00=dp if(ztot(1)>=-dpmax) then write(11,*)'1st z-level must be below max. depth:',dpmax stop endif do i=1,ne read(14,*) j,l,(nm(i,k),k=1,l) if(l/=3) then write(11,*)'SELFE cannot handle quads:',i stop endif n1=nm(i,1) n2=nm(i,2) n3=nm(i,3) area(i)=signa(x(n1),x(n2),x(n3),y(n1),y(n2),y(n3)) if(area(i)<=0) then write(11,*)'Negative area at',i stop endif radiel(i)=dsqrt(area(i)/pi) !equivalent radius !... Derivatives of shape functions dl(i,1,1)=(y(n2)-y(n3))/2/area(i) !dL_1/dx dl(i,2,1)=(y(n3)-y(n1))/2/area(i) !dL_2/dx dl(i,3,1)=(y(n1)-y(n2))/2/area(i) dl(i,1,2)=(x(n3)-x(n2))/2/area(i) !dL_1/dy dl(i,2,2)=(x(n1)-x(n3))/2/area(i) dl(i,3,2)=(x(n2)-x(n1))/2/area(i) enddo !i=1,ne ! Open bnds read(14,*) nope if(nope>mnope) then write(11,*) 'nope > mnope' stop endif read(14,*) neta ntot=0 do k=1,nope read(14,*) nond(k) if(nond(k)>mnond) then write(11,*) 'nond(k) > mnond' stop endif do i=1,nond(k) read(14,*) iond(k,i) isbnd(iond(k,i))=k enddo if(iond(k,1)==iond(k,nond(k))) then write(11,*)'Looped open bnd:',k stop endif ntot=ntot+nond(k) enddo if(neta/=ntot) then write(11,*)'neta /= total # of open bnd nodes',neta,ntot stop endif ! Land bnds read(14,*) nland if(nland>mnland) then write(11,*) 'nland > mnland' stop endif read(14,*) nvel do k=1,nland read(14,*) nlnd(k) if(nlnd(k)>mnlnd) then write(11,*)'nlnd(k) > mnlnd',k,nlnd(k),mnlnd stop endif do i=1,nlnd(k) read(14,*) ilnd(k,i) if(isbnd(ilnd(k,i))==0) isbnd(ilnd(k,i))=-1 !overlap of open bnd enddo enddo !k=1,nland close(14) !... End fort.14 ! * ! * !****************************************************************************** ! * ! Compute geometry * ! * !****************************************************************************** ! * ! * !... compute the ball of elements and arrange in counter-clockwise fashion do i=1,np nne(i)=0 nnp(i)=0 enddo do i=1,ne do j=1,3 nd=nm(i,j) nne(nd)=nne(nd)+1 if(nne(nd)>mnei) then write(11,*)'Too many neighbors',nd stop endif ine(nd,nne(nd))=i iself(nd,nne(nd))=j !to be updated later enddo enddo ! Compute ball info; this won't be affected by re-arrangement below do i=1,ne do j=1,3 ic3(i,j)=0 !index for bnd sides nd1=nm(i,nx(j,1)) nd2=nm(i,nx(j,2)) do k=1,nne(nd1) ie=ine(nd1,k) if(ie/=i.and.(nm(ie,1)==nd2.or.nm(ie,2)==nd2.or.nm(ie,3)==nd2)) ic3(i,j)=ie enddo !k enddo !j enddo !i ! Re-arrange in counter-clockwise fashion do i=1,np if(isbnd(i)/=0) then !bnd ball ! Look for starting bnd element icount=0 do j=1,nne(i) ie=ine(i,j) id=iself(i,j) if(ic3(ie,nx(id,2))==0) then icount=icount+1 ine(i,1)=ie iself(i,1)=id endif enddo !j=1,nne(i) if(icount/=1) then write(11,*)'Illegal bnd node',i stop endif endif !bnd ball ! Sequential search for the rest of elements nnp(i)=2 inp(i,1)=nm(ine(i,1),nx(iself(i,1),1)) inp(i,2)=nm(ine(i,1),nx(iself(i,1),2)) do j=2,nne(i) new=ic3(ine(i,j-1),nx(iself(i,j-1),1)) if(new==0) then write(11,*)'Incomplete ball',i stop endif ine(i,j)=new id=0 do l=1,3 if(nm(new,l)==i) id=l enddo !l if(id==0) then write(11,*)'Failed to find local index:',i,new stop endif iself(i,j)=id if(isbnd(i)==0.and.j==nne(i)) then !complete internal ball ! Check completeness if(nm(new,nx(id,2))/=inp(i,1)) then write(11,*)'Broken ball:',i stop endif else !one more node nnp(i)=nnp(i)+1 if(nnp(i)>mnei) then write(11,*)'Too many neighbor nodes',i stop endif inp(i,nnp(i))=nm(new,nx(id,2)) endif enddo !j=2,nne(i) enddo !i=1,np !... Check hanging nodes !... ihang=0 do i=1,np if(nne(i)==0) then ihang=1 write(11,*)'Hanging node',i endif enddo if(ihang==1) then write(11,*)'Check fort.11 for hanging nodes' stop endif !... compute the sides information !... ns=0 !# of sides do i=1,ne do j=1,3 nd1=nm(i,nx(j,1)) nd2=nm(i,nx(j,2)) if(ic3(i,j)==0.or.imns) then write(11,*)'Too many sides' stop endif js(i,j)=ns is(ns,1)=i isidenode(ns,1)=nd1 isidenode(ns,2)=nd2 xcj(ns)=(x(nd1)+x(nd2))/2 ycj(ns)=(y(nd1)+y(nd2))/2 dps(ns)=(dp(nd1)+dp(nd2))/2 distj(ns)=dsqrt((x(nd2)-x(nd1))**2+(y(nd2)-y(nd1))**2) if(distj(ns)==0) then write(11,*)'Zero side',ns stop endif thetan=datan2(x(nd1)-x(nd2),y(nd2)-y(nd1)) snx(ns)=dcos(thetan) sny(ns)=dsin(thetan) is(ns,2)=ic3(i,j) !bnd element => bnd side ! Corresponding side in element ic3(i,j) if(ic3(i,j)/=0) then !old internal side iel=ic3(i,j) index=0 do k=1,3 if(ic3(iel,k)==i) then index=k exit endif enddo !k if(index==0) then write(*,*)'Wrong ball info',i,j stop endif js(iel,index)=ns endif !ic3(i,j).ne.0 endif !ic3(i,j)==0.or.idp(nm(i,j))) dpe(i)=dp(nm(i,j)) enddo !j enddo !i=1,ne !... Compute open bnd sides and total lengths of each open bnd segments (for imposing discharge) if(ipre==1) open(32,file='obs.out') do i=1,nope cwidth(i)=0 do j=1,nond(i)-1 n1=iond(i,j) n2=iond(i,j+1) cwidth(i)=cwidth(i)+dsqrt((x(n2)-x(n1))**2+(y(n2)-y(n1))**2) if(inp(n1,1)==n2) then ie=ine(n1,1) id=iself(n1,1) isd=js(ie,nx(id,2)) else if(inp(n1,nnp(n1))==n2) then ie=ine(n1,nne(n1)) id=iself(n1,nne(n1)) isd=js(ie,nx(id,1)) else write(11,*)'Wrong bnd ball orientation:',n1,n2 stop endif if(is(isd,2)/=0) then write(11,*)'Wrong bnd side:',n1,n2 stop endif isbs(isd)=i ! Output obs.out if(ipre==1) write(32,*)i,isd,isidenode(isd,1),isidenode(isd,2) enddo !j enddo !i !... Compute neighborhood for internal sides for horizontal derivatives (viscosity) !... isidenei(ns,2): 2 neighboring elements of a side !... isidenei2(ns,4): 4 neighboring sides of a side dxy_min=1.e34 !min. local x-coord. iabort=0 !abort flag loop18: do i=1,ns if(is(i,2)==0) cycle loop18 ! Internal sides node1=isidenode(i,1) node2=isidenode(i,2) do j=1,2 ie=is(i,j) l0=lindex_s(i,ie) if(l0==0) then write(11,*)'Cannot find a side' stop endif nwild(2*j-1)=js(ie,nx(l0,1)) nwild(2*j)=js(ie,nx(l0,2)) enddo !j=1,2 isidenei2(i,1:4)=nwild(1:4) !may be modified later ! First part for hvis only if(ihorcon/=0) then !need to compute hvis later ! Compute intersections 1 and 2 x0=xcj(i); y0=ycj(i) x1=xcj(nwild(1)); y1=ycj(nwild(1)) x2=xcj(nwild(2)); y2=ycj(nwild(2)) x3=xcj(nwild(3)); y3=ycj(nwild(3)) x4=xcj(nwild(4)); y4=ycj(nwild(4)) call intersect4(x0,snx(i),x1,x2,y0,sny(i),y1,y2,iflag1,xin1,yin1,tt11,tt21) !pt 1 call intersect4(x0,-snx(i),x3,x4,y0,-sny(i),y3,y4,iflag2,xin2,yin2,tt12,tt22) !pt 2 if(iflag1/=1.or.iflag2/=1.or.tt11==0.or.tt12==0) then write(11,*)'Failed to find 1 or 2:',iflag1,iflag2 stop endif if(tt21<0) then isidenei(i,1)=is(nwild(1),1)+is(nwild(1),2)-is(i,1) else if(tt21>1) then isidenei(i,1)=is(nwild(2),1)+is(nwild(2),2)-is(i,1) else !inside isidenei(i,1)=is(i,1) endif if(tt22<0) then isidenei(i,2)=is(nwild(3),1)+is(nwild(3),2)-is(i,2) else if(tt22>1) then isidenei(i,2)=is(nwild(4),1)+is(nwild(4),2)-is(i,2) else !inside isidenei(i,2)=is(i,2) endif if(isidenei(i,1)==0.or.isidenei(i,2)==0) then iabort=1 write(11,*)'Bnd side reached:',node1,node2,isidenei(i,1:2) cycle loop18 endif call area_coord2(isidenei(i,1),xin1,yin1,swild,ifl1) side_ac(i,1,1:2)=swild(1:2) call area_coord2(isidenei(i,2),xin2,yin2,swild,ifl2) side_ac(i,2,1:2)=swild(1:2) if(ifl1==1.or.ifl2==1) then iabort=1 write(11,*)'Failed to extend stencil:',node1,node2,ifl1,ifl2,isidenei(i,1:2) write(11,*)xin1,yin1,xin2,yin2 write(11,*)side_ac(i,1,1:2) write(11,*)'-----------------------------------------------' cycle loop18 endif ! local x-coord. side_x(i,1)=(xin1-x0)*snx(i)+(yin1-y0)*sny(i) side_x(i,2)=(xin2-x0)*snx(i)+(yin2-y0)*sny(i) if(side_x(i,1)>=0.or.side_x(i,2)<=0) then write(11,*)'x-coord. out of order:',side_x(i,1:2),node1,node2 stop endif if(abs(side_x(i,1))40.or.saltmin<0.or.saltmax>42) then ! write(11,*)'Specified ST range invalid' ! stop ! endif tempmin=0; tempmax=40; saltmin=0; saltmax=42 read(15,*) rnday !... dramp not used if nramp=0 read(15,*) nramp,dramp if(nramp/=0.and.nramp/=1) then write(11,*)'Unknown nramp',nramp stop endif read(15,*) dt !... compute total number of time steps ntime=rnday*86400/dt+0.5 write(10,*)ntime write(10,'(a200)')'Time (hours), volume, mass, potential E, kinetic E, total E, friction loss (Joule), energy leak (Joule)' !' !... input info on backtracking !... read(15,*) !nsubfl !flag !... Advection flag for momentum eq. read(15,*) nadv !flag: 1-Euler; 2: R-K if(nadv<0.or.nadv>2) then write(11,*)'Unknown advection flag',nadv stop endif if(nadv==0) then open(42,file='adv.gr3',status='old') read(42,*) read(42,*) !ne,np do i=1,np read(42,*)j,xtmp,ytmp,tmp iadv(i)=tmp if(iadv(i)<0.or.iadv(i)>2) then write(11,*)'Unknown iadv',i stop endif enddo close(42) else !nadv/=0 iadv=nadv endif !... Tracking step read(15,*) dtb_max1,dtb_max2 !min. or max. sub-step for Euler and R-K if nadv=0; otherwise only dtb_max1 is used !... Minimum depth allowed read(15,*) h0 if(h0<=0) then write(11,*)'h0 must be positive' stop endif !... Bottom friction read(15,*) nchi if(nchi==0) then !read in drag coefficients open(32,file='drag.gr3',status='old') read(32,*) read(32,*) do i=1,np read(32,*)j,xtmp,ytmp,Cdp(i) if(Cdp(i)<0) then write(11,*)'Negative bottom drag',Cdp(i) stop endif enddo do i=1,ns n1=isidenode(i,1) n2=isidenode(i,2) Cd(i)=(Cdp(n1)+Cdp(n2))/2 enddo close(32) else if(nchi==1) then !read in roughness in meters read(15,*) Cdmax !max. Cd open(32,file='rough.gr3',status='old') read(32,*) read(32,*) do i=1,np read(32,*)j,xtmp,ytmp,rough_p(i) ! if(rough_p(i)<0) then ! write(11,*)'Negative bottom roughness',rough_p(i) ! stop ! endif enddo !i do i=1,ns n1=isidenode(i,1) n2=isidenode(i,2) sm=dmin1(rough_p(n1),rough_p(n2)) if(sm<0) then rough(i)=sm !<0 else !both non-negative rough(i)=(rough_p(n1)+rough_p(n2))/2 !>=0 endif enddo !i close(32) else write(11,*)'Unknown nchi', nchi stop endif ! Coriolis read(15,*) ncor if(abs(ncor)>1) then write(11,*)'Unknown ncor',ncor stop endif if(ncor==-1) then !lattitude read(15,*) tmp coricoef=2*omega*dsin(tmp/180*pi) cori=coricoef else if(ncor==0) then read(15,*) coricoef cori=coricoef else !ncor=1 write(*,*)'Check slam0 and sfea0 as variable Coriolis is used' write(16,*)'Check slam0 and sfea0 as variable Coriolis is used' open(32,file='hgrid.ll',status='old') read(32,*) read(32,*) !ne,np do i=1,np read(32,*)j,xlon(i),ylat(i) xlon(i)=xlon(i)*pi/180 ylat(i)=ylat(i)*pi/180 enddo !i close(32) open(31,file='coriolis.out') fc=2*omega*dsin(sfea0) beta=2*omega*dcos(sfea0) do i=1,ns id1=isidenode(i,1) id2=isidenode(i,2) sphi=(ylat(id1)+ylat(id2))/2 cori(i)=fc+beta*(sphi-sfea0) if(iwrite==0) then write(31,*)i,xcj(i),ycj(i),cori(i) else !evm write(31,"(a,i6,a,f16.9,a,f16.9,a,es22.14e3,a)",advance="no") & & " ",i," ",xcj(i)," ",ycj(i)," ",cori(i),"\n" endif enddo !i=1,ns close(31) endif ! Wind (nws=3: for conservation check; otherwise same as nws=2) read(15,*) nws,wtiminc if(nws<0.or.nws>3) then write(11,*)'Unknown nws',nws stop endif if(nws>0.and.dt>wtiminc) then write(11,*)'wtiminc < dt' stop endif if(nws>=2) then !CORIE mode; read in hgrid.ll #ifndef USE_SFLUX write(11,*)'COIRE mode needs sflux routines' stop #endif open(32,file='hgrid.ll',status='old') read(32,*) read(32,*) !ne,np do i=1,np read(32,*)j,xlon(i),ylat(i) xlon(i)=xlon(i)*pi/180 ylat(i)=ylat(i)*pi/180 enddo !i close(32) endif windfactor=1 !intialize for default if(nws>0) then read(15,*) nrampwind,drampwind read(15,*) iwindoff if(iwindoff/=0) then open(32,file='windfactor.gr3',status='old') read(32,*) read(32,*)ntmp,np do i=1,np read(32,*)j,xtmp,ytmp,windfactor(i) if(windfactor(i)<0) then write(11,*)'Wind scaling factor must be positive:',i,windfactor(i) stop endif enddo !i close(32) endif endif ! Heat and salt conservation flags read(15,*) ihconsv,isconsv if(ihconsv<0.or.ihconsv>1.or.isconsv<0.or.isconsv>1) then write(11,*)'Unknown ihconsv or isconsv',ihconsv,isconsv stop endif if(isconsv/=0.and.ihconsv==0) then write(11,*)'Evap/precip model must be used with heat exchnage model' !' stop endif if(ihconsv/=0.and.nws<2) then write(11,*)'Heat budge model must have nws>=2' stop endif if(ihconsv/=0) then write(16,*)'Warning: you have chosen a heat conservation model' write(16,*)'which assumes start time at 0:00 PST!' #ifndef USE_SFLUX write(11,*)'Pls enable USE_SFLUX to use heat budget model' stop #endif #ifndef USE_NETCDF write(11,*)'Pls enable USE_NETCDF to use heat budget model' stop #endif endif if(isconsv/=0) then #ifndef PREC_EVAP write(11,*)'Pls enable PREC_EVAP:',isconsv stop ! USE_SFLUX and USE_NETCDF are definitely enabled in Makefile when isconsv=1 #endif endif !... Turbulence closure options read(15,*) itur if(itur<-2.or.itur>4) then write(11,*)'Unknown turbulence closure model',itur stop endif if(itur==0) then read(15,*) dfv0,dfh0 dfv=dfv0; dfh=dfh0 else if(itur==-1) then !VVD open(43,file='vvd.dat',status='old') read(43,*) !nvrt do j=1,nvrt read(43,*)k,dfv0,dfh0 do i=1,np dfv(i,j)=dfv0 dfh(i,j)=dfh0 enddo enddo !j close(43) else if(itur==-2) then !HVD open(43,file='hvd.mom',status='old') open(44,file='hvd.tran',status='old') read(43,*) read(43,*) !np read(44,*) read(44,*) !np do i=1,np read(43,*)k,xtmp,ytmp,dfv0 read(44,*)k,xtmp,ytmp,dfh0 do j=1,nvrt dfv(i,j)=dfv0 dfh(i,j)=dfh0 enddo enddo !i=1,np close(43) close(44) else if(itur==2) then !read in P&P coefficients read(15,*) h1_pp,vdmax_pp1,vdmin_pp1,tdmin_pp1,h2_pp,vdmax_pp2,vdmin_pp2,tdmin_pp2 if(h1_pp>=h2_pp) then write(11,*)'h1_pp >= h2_pp in P&P' stop endif if(vdmax_pp1 diffmax:',i stop endif enddo !i close(31) close(32) if(itur==3) then read(15,*) mid,stab ! Constants used in GLS; cpsi3 later a2_cm03=2/cmiu0**3 eps_min=1.e-12 select case(mid) case('MY') rpub=0; rmub=1; rnub=1; cpsi1=0.9; cpsi2=0.5 q2min=5.e-6; psimin=1.e-8 if(stab.ne.'GA') then write(11,*)'MY must use Galperins ASM:',stab stop endif case('KL') rpub=0; rmub=1; rnub=1; schk=2.44; schpsi=2.44; cpsi1=0.9; cpsi2=0.5 q2min=5.e-6; psimin=1.e-8 case('KE') rpub=3; rmub=1.5; rnub=-1; schk=1; schpsi=1.3; cpsi1=1.44; cpsi2=1.92 q2min=1.0e-9; psimin=1.e-8 case('KW') rpub=-1; rmub=0.5; rnub=-1; schk=2; schpsi=2; cpsi1=0.555; cpsi2=0.833 q2min=1.0e-9; psimin=1.e-8 case('UB') rpub=2; rmub=1; rnub=-0.67; schk=0.8; schpsi=1.07; cpsi1=1; cpsi2=1.22 q2min=1.0e-9; psimin=1.e-8 case default write(11,*)'Unknown closure:',mid stop end select if(rnub==0) then write(11,*)'Wrong input for rnub:',rnub stop endif if(stab.ne.'GA'.and.stab.ne.'KC') then write(11,*)'Unknown ASM:',stab stop endif ! Consts. used in Canuto's ASM (Model A) ubl1=0.1070 ubl2=0.0032 ubl3=0.0864 ubl4=0.12 ubl5=11.9 ubl6=0.4 ubl7=0 ubl8=0.48 ubs0=1.5*ubl1*ubl5**2 ubs1=-ubl4*(ubl6+ubl7)+2*ubl4*ubl5*(ubl1-ubl2/3-ubl3)+1.5*ubl1*ubl5*ubl8 ubs2=-0.375*ubl1*(ubl6**2-ubl7**2) ubs4=2*ubl5 ubs5=2*ubl4 ubs6=2*ubl5/3*(3*ubl3**2-ubl2**2)-0.5*ubl5*ubl1*(3*ubl3-ubl2)+0.75*ubl1*(ubl6-ubl7) ubd0=3*ubl5**2 ubd1=ubl5*(7*ubl4+3*ubl8) ubd2=ubl5**2*(3*ubl3**2-ubl2**2)-0.75*(ubl6**2-ubl7**2) ubd3=ubl4*(4*ubl4+3*ubl8) ubd4=ubl4*(ubl2*ubl6-3*ubl3*ubl7-ubl5*(ubl2**2-ubl3**2))+ubl5*ubl8*(3*ubl3**2-ubl2**2) ubd5=0.25*(ubl2**2-3*ubl3**2)*(ubl6**2-ubl7**2) ! print*, 'ubd2=',ubd2,',ubd4=',ubd4,',ubd2/ubd4=',ubd2/ubd4 ! Initialize k and l do i=1,np xlmin2(i)=2*q2min*0.1*dmax1(h0,dp(i)) !floor for non-surface layers do k=1,nvrt q2(i,k)=q2min xl(i,k)=xlmin2(i) enddo !k enddo !i dfv=0; dfh=0; dfq1=0; dfq2=0 !initialize for closure eqs. else !itur=4 #ifndef USE_GOTM write(11,*)'Compile with GOTM:',itur stop #endif endif !itur=3 or 4 endif !itur ! i.c. read(15,*)icst if(icst/=1.and.icst/=2) then write(11,*)'Unknown i.c. flag',icst stop endif !... Earth tidal potential read(15,*) ntip,tip_dp !cut-off depth for applying tidal potential if(ntip>mnbfr) then write(11,*)'ntip > mnbfr',ntip,mnbfr stop endif if(ntip>0) then open(32,file='hgrid.ll',status='old') read(32,*) read(32,*) !ne,np do i=1,np read(32,*)j,xlon(i),ylat(i) xlon(i)=xlon(i)*pi/180 ylat(i)=ylat(i)*pi/180 !... Pre-compute species function to save time fun_lat(i,0)=3*dsin(ylat(i))**2-1 fun_lat(i,1)=dsin(2*ylat(i)) fun_lat(i,2)=dcos(ylat(i))**2 enddo !i close(32) endif !ntip>0 do i=1,ntip read(15,*) !tag read(15,*) jspc(i),tamp(i),tfreq(i),tnf(i),tear(i) if(jspc(i).lt.0.or.jspc(i).gt.2) then write(11,*)'Illegal tidal species #',jspc(i) stop endif tear(i)=tear(i)*pi/180 enddo !i !... Boundary forcing freqs. read(15,*) nbfr if(nbfr>mnbfr) then write(11,*)'nbfr > mnbfr',nbfr,mnbfr stop endif do i=1,nbfr read(15,*) !tag read(15,*) amig(i),ff(i),face(i) !freq., nodal factor and earth equil. face(i)=face(i)*pi/180 enddo read(15,*) nope1 if(nope1/=nope) then write(11,*)'Inconsistent # of open bnds',nope1,nope stop endif nettype=0 !total # of type I bnds nfltype=0 ntetype=0 nsatype=0 nettype2=0 !total # of type IV bnds (3D input) nfltype2=0 ntetype2=0 nsatype2=0 do k=1,nope read(15,*) ntmp,iettype(k),ifltype(k),itetype(k),isatype(k) if(ntmp/=nond(k)) then write(11,*)'Inconsistent # of nodes at open boundary',k write(11,*)ntmp,nond(k) stop endif if(iettype(k)==1) then nettype=nettype+1 ! Mock reading open(50,file='elev.th',status='old') do j=1,ntime read(50,*) ttt,et enddo !j rewind(50) else if(iettype(k)==2) then read(15,*) eth(k,1) else if(iettype(k)==3) then do i=1,nbfr read(15,*) !freq. name do j=1,nond(k) read(15,*) emo(k,j,i),efa(k,j,i) !amp. and phase efa(k,j,i)=efa(k,j,i)*pi/180 enddo enddo else if(iettype(k)==4) then nettype2=nettype2+1 open(54,file='elev3D.th',status='old') else if(iettype(k)/=0) then write(11,*)'Invalid iettype' stop endif if(ifltype(k)==1) then nfltype=nfltype+1 open(51,file='flux.th',status='old') do j=1,ntime read(51,*) ttt,qq enddo rewind(51) else if(ifltype(k)==2) then read(15,*) qthcon(k) else if(ifltype(k)==3) then do i=1,nbfr read(15,*) read(15,*) vmo(k,i),vfa(k,i) !uniform amp. and phase along each segment vfa(k,i)=vfa(k,i)*pi/180 enddo else if(ifltype(k)==4) then nfltype2=nfltype2+1 open(55,file='uv3D.th',status='old') else if(ifltype(k)==-1) then !Flather 1 if(iettype(k)/=0) then write(11,*)'Flather obc requires iettype=0:',k stop endif read(15,*) eta_m0,qthcon(k) do j=1,nond(k) eta_mean(iond(k,j))=eta_m0 enddo !j else if(ifltype(k)/=0) then write(11,*) 'Invalid ifltype:',ifltype(k) stop endif if(itetype(k)==1) then ntetype=ntetype+1 open(52,file='temp.th',status='old') do j=1,ntime read(52,*) ttt,temp enddo rewind(52) else if(itetype(k)==2) then read(15,*) tth(k,1,1) else if(iabs(itetype(k))==4) then ntetype2=ntetype2+1 open(56,file='temp3D.th',status='old') if(itetype(k)==-4) read(15,*) tobc(k) !nudging factor else if(itetype(k)==-1) then read(15,*) tobc(k) !nudging factor if(tobc(k)<0.or.tobc(k)>1) then write(11,*)'Temp. obc nudging factor wrong:',tobc(k),k stop endif else if(itetype(k)/=0.and.itetype(k)/=3) then write(11,*) 'INVALID VALUE FOR ITETYPE' stop endif if(isatype(k)==1) then nsatype=nsatype+1 open(53,file='salt.th',status='old') do j=1,ntime read(53,*) ttt,sal enddo rewind(53) else if(isatype(k)==2) then read(15,*) sth(k,1,1) else if(iabs(isatype(k))==4) then nsatype2=nsatype2+1 open(57,file='salt3D.th',status='old') if(isatype(k)==-4) read(15,*) sobc(k) !nudging factor else if(isatype(k)==-1) then read(15,*) sobc(k) !nudging factor if(sobc(k)<0.or.sobc(k)>1) then write(11,*)'Salt. obc nudging factor wrong:',sobc(k),k stop endif else if(isatype(k)/=0.and.isatype(k)/=3) then write(11,*) 'INVALID VALUE FOR ISATYPE' stop endif enddo !k=1,nope ! Global output parameters noutput=25+ntracers if(noutput>mnout) then write(11,*)'Increase mnout in the header to',noutput stop endif outfile(1)='elev.61' outfile(2)='pres.61' outfile(3)='airt.61' outfile(4)='shum.61' outfile(5)='srad.61' outfile(6)='flsu.61' outfile(7)='fllu.61' outfile(8)='radu.61' outfile(9)='radd.61' outfile(10)='flux.61' outfile(11)='evap.61' outfile(12)='prcp.61' outfile(13)='wind.62' outfile(14)='wist.62' outfile(15)='dahv.62' outfile(16)='vert.63' outfile(17)='temp.63' outfile(18)='salt.63' outfile(19)='conc.63' outfile(20)='tdff.63' outfile(21)='vdff.63' outfile(22)='kine.63' outfile(23)='mixl.63' outfile(24)='zcor.63' outfile(25)='hvel.64' variable_nm(1)='surface elevation' variable_nm(2)='atmopheric pressure' variable_nm(3)='air temperature' variable_nm(4)='specific humidity' variable_nm(5)='solar radiation' variable_nm(6)='fluxsu' variable_nm(7)='fluxlu' variable_nm(8)='hradu' variable_nm(9)='hradd' variable_nm(10)='total flux' variable_nm(11)='Evaporation rate (kg/m^2/s)' variable_nm(12)='Precipitation rate (kg/m^2/s)' variable_nm(13)='wind speed' variable_nm(14)='wind stress (m^2/s^2)' variable_nm(15)='Depth averaged horizontal velocity' variable_nm(16)='vertical velocity' variable_nm(17)='temperature in C' variable_nm(18)='salinity in psu' variable_nm(19)='density in kg/m^3' variable_nm(20)='eddy diffusivity in m^2/s' variable_nm(21)='eddy viscosity in m^2/s' variable_nm(22)='turbulent kinetic energy' variable_nm(23)='turbulent mixing length' variable_nm(24)='z coordinates' variable_nm(25)='horizontal velocity' variable_dim(1:12)='2D scalar' variable_dim(13:15)='2D vector' variable_dim(16:24)='3D scalar' variable_dim(25)='3D vector' do i=1,ntracers write(ifile_char,'(i03)')i outfile(25+i)='tracer_'//trim(ifile_char)//'.63' variable_nm(25+i)='Tracer #'//trim(ifile_char) variable_dim(25+i)='3D scalar' enddo !i read(15,*) nspool,ihfskip !output and file spools if(nspool==0.or.ihfskip==0) then write(11,*)'Zero nspool' stop endif if(mod(ihfskip,nspool)/=0) then write(11,*)'ihfskip/nspool != integer' stop endif nrec=min(ntime,ihfskip)/nspool do i=1,noutput read(15,*) iof(i) if(iof(i)/=0.and.iof(i)/=1) then write(11,*)'Unknown output option',i,iof(i) stop endif enddo !i=1,noutput if(iof(24)==0) then write(16,*)'Reset zcor output flag' iof(24)=1 endif !... Test output parameters read(15,*) noutgm if(noutgm/=1.and.noutgm/=0) then write(11,*)'Unknown noutgm',noutgm stop endif !... input information about hot start output !... read(15,*) nhot if(nhot/=0.and.nhot/=1) then write(11,*)'Unknown nhot',nhot stop endif !... Itpack solver info read(15,*) isolver,itmax1,iremove,zeta,tol if(itmax1>itmax) then write(11,*)'Increase itmax in header file' stop endif if(isolver<1.or.isolver>4) then write(11,*)'Unknown solver',isolver stop endif !... Compute flux flag read(15,*) iflux !,ihcheck !... Interpolation flag for S,T and vel. in ELM ! Kriging in vel: no bnd nodes/sides vel. will use Kriging as the filter is not applied there read(15,*) lq,inter_mom if(lq<0.or.lq>2.or.inter_mom<-1.or.inter_mom>1) then write(11,*)'Unknown interpolation flag:',lq,inter_mom stop endif if(lq/=0) then lqk(1:mne)=lq else !lq==0 open(32,file='lqk.gr3',status='old') read(32,*) read(32,*) do i=1,np read(32,*)j,xtmp,ytmp,swild(i) if(swild(i)<1.or.swild(i)>2) then write(11,*)'Unknown interpolation flag in lqk.gr3' stop endif enddo !i close(32) do i=1,ne n1=nm(i,1); n2=nm(i,2); n3=nm(i,3) lqk(i)=min(swild(n1),swild(n2),swild(n3)) enddo !i endif if(inter_mom/=-1) then krvel=inter_mom else !-1 open(32,file='krvel.gr3',status='old') read(32,*) read(32,*) do i=1,np read(32,*)j,xtmp,ytmp,swild(i) if(swild(i)<0.or.swild(i)>1) then write(11,*)'Unknown interpolation flag in krvel.gr3' stop endif enddo !i close(32) do i=1,ne n1=nm(i,1); n2=nm(i,2); n3=nm(i,3) krvel(i)=min(swild(n1),swild(n2),swild(n3)) enddo !i endif !... Interpolation mode (1: along Z; 2: along S) open(32,file='interpol.gr3',status='old') read(32,*) read(32,*) do i=1,np read(32,*)j,xtmp,ytmp,swild(i) if(swild(i)/=1.and.swild(i)/=2) then write(11,*)'Unknown interpolation flag in interpol.gr3' stop endif enddo !i close(32) do i=1,ne n1=nm(i,1); n2=nm(i,2); n3=nm(i,3) interpol(i)=min(swild(n1),swild(n2),swild(n3)) enddo !i ! Make sure lqk=2 & interpol=2 are in pure S region do i=1,ne if(lqk(i)==2.or.interpol(i)==2) then if(dp(nm(i,1))>h_s.or.dp(nm(i,2))>h_s.or.dp(nm(i,3))>h_s) then write(11,*)'lqk or interpol=2 must be inside pure S region:',i,interpol(i) stop endif endif enddo !i !... Cut-off depth for BCC read(15,*) h_bcc1 !z- or sigma- !... Land b.c. option read(15,*) islip !0: free slip; otherwise no slip if(islip/=0.and.islip/=1) then write(11,*)'Unknow islip:',islip stop endif if(islip==1) read(15,*) hdrag0 !... Nudging options read(15,*) inu_st,step_nu,vnh1,vnf1,vnh2,vnf2 if(inu_st<0.or.inu_st>2.or.step_nu=vnh2.or.vnf1<0.or.vnf1>1.or.vnf2<0.or.vnf2>1) then write(11,*)'Check vertical nudging limits:',vnh1,vnf1,vnh2,vnf2 stop endif open(96,file='t_nudge.gr3',status='old') open(97,file='s_nudge.gr3',status='old') read(96,*) read(96,*) !ne,np read(97,*) read(97,*) !ne,np do i=1,np read(96,*)j,xtmp,ytmp,t_nudge(i) read(97,*)j,xtmp,ytmp,s_nudge(i) if(t_nudge(i)<0.or.t_nudge(i)>1.or.s_nudge(i)<0.or.s_nudge(i)>1) then write(11,*)'Wrong nudging factor at node:',i,t_nudge(i),s_nudge(i) stop endif enddo !i close(96) close(97) if(inu_st==2) then nrec_nu=nbyte*(1+np*nvrt) !single precision open(37,file='temp_nu.in',access='direct',recl=nrec_nu) open(35,file='salt_nu.in',access='direct',recl=nrec_nu) endif endif !... Surface min. mixing length for f.s. and max. for all; inactive read(15,*) !xlmax00 if(itur==3) then open(32,file='xlsc.gr3',status='old') read(32,*) read(32,*) do i=1,np read(32,*)j,xtmp,ytmp,xlsc0(i) if(xlsc0(i)<0.or.xlsc0(i)>1) then write(11,*)'Wroing xlsc0:',i,xlsc0(i) stop endif enddo !i close(32) endif !... Order of integration read(15,*) mmm if(mmm<0) then write(11,*)'mmm<0' stop endif ! Pre-compute sigmap & sigma_prod for rint_lag() if(mmm>0) then do k=1,nsig do j=1,2*mmm+1 if(j==1) then sigmap(k,j)=sigma(k) else sigmap(k,j)=sigmap(k,j-1)*sigma(k) endif enddo !j if(k=j2) then write(11,*)'Weird indices:',j1,j2,k,l stop endif do i=j1,j2 if(abs(i-k)>4) then write(11,*)'sigma_prod index out of bound' stop endif sigma_prod(l,k,i-k)=1 do j=j1,j2 if(j/=i) sigma_prod(l,k,i-k)=sigma_prod(l,k,i-k)*(sigma(i)-sigma(j)) enddo !j if(sigma_prod(l,k,i-k)==0) then write(11,*)'Impossible in sigma_prod' stop endif enddo !i enddo !l endif !k0 !... Drag formulation read(15,*) idrag if(idrag/=1.and.idrag/=2) then write(11,*)'Unknown idrag' stop endif if(idrag==1.and.itur>0) then write(11,*)'Linear drag requires itur<=0' stop endif if(idrag==1.and.nchi/=0) then write(11,*)'Linear drag requires nchi=0' stop endif !... ELAD correction option for heat exchange (inactive) read(15,*) !ielad ! if(ielad/=0.and.ielad/=1) then ! write(11,*)'Unknown ielad:',ielad ! stop ! endif !... Option to limit \hat{H} to enhance stability for large friction in shallow area read(15,*) ihhat if(ihhat/=0.and.ihhat/=1) then write(11,*)'Unknown ihhat:',ihhat stop endif !... Transport options: ELM or upwind read(15,*) iupwind_t,iupwind_s !0: ELM; 1: upwind; 2: TVD if(iupwind_t<0.or.iupwind_t>2.or.iupwind_s<0.or.iupwind_s>2) then write(11,*)'Unknown iupwind:',iupwind_t,iupwind_s stop endif if(iupwind_t+iupwind_s==3) then write(11,*)'TVD cannot be combined with upwind:',iupwind_t,iupwind_s stop endif ! tvd_mid: model AA (my own formulation); CC (Casulli's definition of upwind ratio) if(iupwind_t==2.or.iupwind_s==2) read(15,*) tvd_mid,flimiter !.... Blending factor for vel. in btrack (1 for internal sides; 2 for bnd sides or nodes) read(15,*) vis_coe1,vis_coe2 if(vis_coe1<0.or.vis_coe1>1.or.vis_coe2<0.or.vis_coe2>1) then write(11,*)'Illegal vis_coe:',vis_coe1,vis_coe2 stop endif read(15,*) shapiro if(shapiro<0.or.shapiro>0.5) then write(11,*)'Illegal shapiro:',shapiro stop endif ! Kriging option ! Desired # of pts used in Kriging (smaller in reality), and choice of generalized covariance fucntion ! For Gaussian, also a scale for decorrelation (decorrelation length=decorrel0*(local element size) read(15,*) nkrige,kr_co,decorrel0 if(nkrige>mnei_kr) then write(11,*)'Increase mnei_kr:',nkrige stop endif if(kr_co<0.or.kr_co>5) then write(11,*)'Wrong kr_co:',kr_co stop endif ie_kr=0 !no Kriging; non-zero value points to local index in all Kriging elements ne_kr=0 !total # of elements in Kriging zone do i=1,ne if(krvel(i)==1) then ne_kr=ne_kr+1 ie_kr(i)=ne_kr endif enddo !i if(ne_kr>mne_kr) then write(11,*)'Too many elements in Kriging zone:',ne_kr stop endif !... Max. for vel. magnitude read(15,*) rmaxvel if(rmaxvel<5) then write(11,*)'Illegal rmaxvel:',rmaxvel stop endif !... Inundation algorithm flag (1: better algorithm for fine resolution) read(15,*) inunfl if(inunfl/=0.and.inunfl/=1) then write(11,*)'Illegal inunfl:',inunfl stop endif !... Option for calculating nodal vel. (0: discontinous with Shapiro filter; 1: averaging !... w/o Shapiro filter: more diffusion) read(15,*) indvel if(indvel/=0.and.indvel/=1) then write(11,*)'Illegal indvel:',indvel stop endif !... Tracer transport read(15,*) itmp if(itmp/=ntracers) then write(11,*)'Mismatch in # of tracers:',itmp,ntracers stop endif if(ntracers>0) then ! read(15,*) itr_ic !1: horizontal i.c.; 2: vertical ! if(itr_ic/=1.and.itr_ic/=2) then ! write(11,*)'Unknown tracer i.c. flag',itr_ic ! stop ! endif read(15,*) itr_met !=1: upwind; 2: TVD if(itr_met/=1.and.itr_met/=2) then write(11,*)'Unknown tracer method',itr_met stop endif if(itr_met==2) read(15,*) tvd_mid2,flimiter2 ! b.c. read(15,*) !nope do k=1,nope read(15,*) itrtype(k) if(itrtype(k)==2) then read(15,*) trth(k,1:ntracers) else if(itrtype(k)/=0.and.itrtype(k)/=3) then write(11,*)'Wrong itrtype:',k,itrtype(k) stop endif enddo !k endif !ntracers !... Check last parameter read in from fort.15 write(*,*)'Last parameter in param.in is flimiter=',flimiter close(15) ! End reading fort.15 !... Compute neighborhood for Kriging ! Construct itier_nd and itier_sd do i=1,ne if(ie_kr(i)==0) cycle ie=ie_kr(i) !local index itier_nd(ie,0)=3 !use 0 to store actual # of pts used in Kriging itier_nd(ie,1:3)=nm(i,1:3) ! icolor[1,2]: for nodes or sides. 0: outside current ball; 1: inside the ball icolor1=0; icolor2=0 icolor1(nm(i,1:3))=1 nfront=3 ifront(1:nfront)=nm(i,1:3) !new frontier nodes itr=0 !iteration # loop14: do itr=itr+1 if(itr>1000000) stop 'Too many iterations in Kriging' nfront0=nfront ifront2(1:nfront)=ifront(1:nfront) nfront=0 do j=1,nfront0 nd=ifront2(j) do l=1,nnp(nd) nd2=inp(nd,l) if(icolor1(nd2)==0) then !new frontier node nfront=nfront+1 if(nfront>mnei_kr) exit loop14 !itier_nd(ie,0) has not been updated; abort ifront(nfront)=nd2 icolor1(nd2)=1 endif enddo !l enddo !j=1,nfront0 if(nfront==0) then !all nodes have been included exit loop14 else nold=itier_nd(ie,0) if(nold+nfront>nkrige) exit loop14 !itier_nd(ie,0) has not been updated; abort do j=1,nfront itier_nd(ie,nold+j)=ifront(j) enddo !j itier_nd(ie,0)=itier_nd(ie,0)+nfront endif ! Debug ! if(i==14216) then ! write(97,*)i,itr,nfront,(ifront(j),j=1,nfront) ! endif end do loop14 ! if(i==14216) then ! nwild=0 !color ! do j=1,itier_nd(ie,0) ! nd=itier_nd(ie,j) ! nwild(nd)=1 ! enddo !j ! write(98,*)itier_nd(ie,0) ! write(98,*)np ! do k=1,np ! write(98,*)k,real(x(k)),real(y(k)),nwild(k) ! enddo !k ! endif ! Check redundancy ! Comment out after debugging do j1=1,itier_nd(ie,0) nd1=itier_nd(ie,j1) do j2=1,itier_nd(ie,0) nd2=itier_nd(ie,j2) if(j1/=j2.and.nd1==nd2) then write(11,*)'Redundant ball in node:',nd1 stop endif enddo !j2 enddo !j1 enddo !i=1,ne !... Invert Kriging matrices akrmat_nd=-1.e34 !initialization for debugging err_max=0 !max. error in computing the inverse matices do k=1,ne if(ie_kr(k)==0) cycle ie=ie_kr(k) !local index decorrel(ie)=decorrel0*radiel(k) !used in Gaussian covar fucntion npp=itier_nd(ie,0) do i=1,npp n1=itier_nd(ie,i) do j=1,npp n2=itier_nd(ie,j) rr=dsqrt((x(n1)-x(n2))**2+(y(n1)-y(n2))**2) akr(i,j)=covar(kr_co,decorrel(ie),rr) enddo !j akr(i,npp+1)=1 akr(i,npp+2)=x(n1) akr(i,npp+3)=y(n1) enddo !i=1,npp akr(npp+1,1:npp)=1 akr(npp+2,1:npp)=x(itier_nd(ie,1:npp)) akr(npp+3,1:npp)=y(itier_nd(ie,1:npp)) akr((npp+1):(npp+3),(npp+1):(npp+3))=0 ! bkr(1:(npp+3),1)=0 !does not matter ! Debug akrmat_nd(ie,1:(npp+3),1:(npp+3))=akr(1:(npp+3),1:(npp+3)) ! call gaussj(akr,npp+3,mnei_kr+3,bkr,1,1) ! LAPACK routines for positive definite symmetric matrix below did not work ! Note: in LAPACK, the matrix dimension is (LDA,*) so the dimensions will match ! call dpotrf('U',npp+3,akr,mnei_kr+3,info) ! if(info/=0) then ! write(11,*)'Failed dpotrf:',info ! stop ! endif ! call dpotri('U',npp+3,akr,mnei_kr+3,info) ! if(info/=0) then ! write(11,*)'Failed dpotri:',info ! stop ! endif ! do i=1,npp+3 ! do j=i+1,npp+3 ! akr(j,i)=akr(i,j) ! enddo !j ! enddo !i ! Pack symmetric matrix do j=1,npp+3 do i=1,j akrp(i+j*(j-1)/2)=akr(i,j) enddo !i enddo !j call dsptrf('U',npp+3,akrp,ipiv,info) if(info/=0) then write(11,*)'Failed dsptrf:',info,k,decorrel(ie) write(11,*)(i,(j,akr(i,j),j=1,npp+3),i=1,npp+3) stop endif call dsptri('U',npp+3,akrp,ipiv,work4,info) if(info/=0) then write(11,*)'Failed dsptri:',info,k stop endif ! Unpack do j=1,npp+3 do i=1,j akr(i,j)=akrp(i+j*(j-1)/2) enddo !i enddo !j do i=1,npp+3 do j=i+1,npp+3 akr(j,i)=akr(i,j) enddo !j enddo !i ! Check do i=1,npp+3 do j=1,npp+3 suma=0 do l=1,npp+3 suma=suma+akrmat_nd(ie,i,l)*akr(l,j) enddo !l if(i==j) suma=suma-1 if(k==22910) then write(96,*)i,j,akrmat_nd(ie,i,j),akr(i,j),suma endif if(dabs(suma)>1.e-8) write(98,*)k,i,j,suma if(dabs(suma)>err_max) err_max=dabs(suma) enddo !j enddo !i akrmat_nd(ie,1:(npp+3),1:(npp+3))=akr(1:(npp+3),1:(npp+3)) enddo !k=1,ne write(16,*)'Max. error in inverting Kriging maxtrice= ',err_max !... Read in horizontal viscosity if(ihorcon/=0) then open(32,file='horcon.gr3',status='old') read(32,*) read(32,*) !ntmp,np do i=1,np read(32,*)j,xtmp,ytmp,swild(i) enddo !i close(32) do i=1,ns horcon(i)=(swild(isidenode(i,1))+swild(isidenode(i,2)))/2 if(horcon(i)<0.or.horcon(i)>1) then write(11,*)'horcon out of bound:',horcon(i),i stop endif enddo !i endif !ihorcon/=0 if(nscreen.eq.1) write(*,*)'done reading inputs...' write(16,*)'done reading inputs...' !... Initialize bottom index (may be updated for wet/dry or bed deformation) for icst=2 !... These indices will be used for output only do i=1,np if(dp(i)<=h0) then kbp(i)=0 !dry else if(dp(i)<=h_s) then kbp(i)=kz else kbp(i)=0 !flag do k=1,kz-1 if(-dp(i)>=ztot(k).and.-dp(i)tempmax) then write(11,*)'Initial invalid T at',i,te stop endif do k=1,nvrt tem0(k,i)=te enddo !k enddo !i read(25,*) read(25,*) !np do i=1,np read(25,*) num,xtmp,ytmp,sa if(sasaltmax) then write(11,*)'Initial invalid S at',i,sa stop endif do k=1,nvrt sal0(k,i)=sa enddo !k enddo close(24) close(25) else !icst=2 ! Read in intial mean S,T open(24,file='ts.ic',status='old') read(24,*)nz_r if(nz_r>mnv.or.nz_r<2) then write(11,*)'Change nz_r:',nz_r stop endif do k=1,nz_r read(24,*)j,z_r(k),tem1(k),sal1(k) if(tem1(k)tempmax.or.sal1(k)saltmax) then write(11,*)'Initial invalid S,T at',k,tem1(k),sal1(k) stop endif if(k>=2.and.z_r(k)=kz) then !S levels kin=k-kz+1 if(hmod(i)>h_c) then zz=h_c*sigma(kin)+(hmod(i)-h_c)*cs(kin) else zz=hmod(i)*sigma(kin) endif else if(k==kbp(i)) then !z-levels zz=-dp(i) else zz=ztot(k) endif if(zz<=z_r(1)) then zrat=0; l0=1 else if(zz>=z_r(nz_r)) then zrat=1; l0=nz_r-1 else l0=0 !flag do l=1,nz_r-1 if(zz>z_r(l).and.zz<=z_r(l+1)) then l0=l exit endif enddo !l if(l0==0) then write(11,*)'Cannot find a level for S,T:',i,k,zz stop endif zrat=(zz-z_r(l0))/(z_r(l0+1)-z_r(l0)) endif tem0(k,i)=tem1(l0)+(tem1(l0+1)-tem1(l0))*zrat sal0(k,i)=sal1(l0)+(sal1(l0+1)-sal1(l0))*zrat enddo !k ! Extend do k=1,kbp(i)-1 tem0(k,i)=tem0(kbp(i),i) sal0(k,i)=sal0(kbp(i),i) enddo !k enddo !i endif endif !ibc.eq.1.and.ibtp.eq.0 !... initialize S,T tnd=tem0; snd=sal0 do i=1,ns n1=isidenode(i,1) n2=isidenode(i,2) do k=1,nvrt tsd(k,i)=(tem0(k,n1)+tem0(k,n2))/2 ssd(k,i)=(sal0(k,n1)+sal0(k,n2))/2 enddo !k enddo !i do i=1,ne n1=nm(i,1) n2=nm(i,2) n3=nm(i,3) do k=2,nvrt tsel(k,i,1)=(tem0(k,n1)+tem0(k,n2)+tem0(k,n3)+tem0(k-1,n1)+tem0(k-1,n2)+tem0(k-1,n3))/6 tsel(k,i,2)=(sal0(k,n1)+sal0(k,n2)+sal0(k,n3)+sal0(k-1,n1)+sal0(k-1,n2)+sal0(k-1,n3))/6 enddo !k tsel(1,i,1)=tsel(2,i,1) !mainly for hotstart format tsel(1,i,2)=tsel(2,i,2) enddo !i !... Tracers; user-defined tracer part if(ntracers>0) then trel0(1:nvrt,1:ne,1)=1 trel0(1:nvrt,1:ne,2)=0 trel=trel0 endif ! end user-defined tracer part !... initialize wind for nws=1,2 (first two lines) !... ! if(nws==1) then ! open(22,file='wind.th',status='old') ! read(22,*) wx1,wy1 ! read(22,*) wx2,wy2 ! do i=1,np ! windx1(i)=wx1 ! windy1(i)=wy1 ! windx2(i)=wx2 ! windy2(i)=wy2 ! enddo ! wtime1=0 ! wtime2=wtiminc ! endif ! CORIE mode if(nws>=2) then wtime1=0 wtime2=wtiminc #ifdef USE_SFLUX call get_wind(wtime1,windx1,windy1,pr1,airt1,shum1) call get_wind(wtime2,windx2,windy2,pr2,airt2,shum2) #endif if(nws==3) then ! Open sflux.th (time interval is dt, not wtiminc!) open(23,file='sflux.th',status='old') read(23,*) !t=0 ! To heat up water, fluxsu00<0, srad00>0 read(23,*) tmp,fluxsu00,srad00 !time, total surface flux, solar radiation endif !nws==3 endif !nws>=2 !... Read initial nudging S,T if(inu_st==2) then read(37,rec=1)floatout,((tnd_nu1(i,j),j=1,nvrt),i=1,np) read(35,rec=1)floatout,((snd_nu1(i,j),j=1,nvrt),i=1,np) read(37,rec=2)floatout,((tnd_nu2(i,j),j=1,nvrt),i=1,np) read(35,rec=2)floatout,((snd_nu2(i,j),j=1,nvrt),i=1,np) irec_nu=2 time_nu=step_nu endif !------------------------------------------------------------------ endif !ihot=0 !... Initialize GOTM for both cold and hot starts (for cde etc). !... For real hot start, q2, xl, dfv and dfh will use the values in hotstart.in; !... otherwise they will be assigned values below. if(itur==4) then #ifdef USE_GOTM call init_turbulence(8,'gotmturb.inp',nvrt-1) !GOTM starts from level 0 call init_tridiagonal(nvrt-1) #endif endif if(nscreen.eq.1) write(*,*)'done initializing cold start' write(16,*)'done initializing cold start' ! !****************************************************************************** ! * ! hot start setup of the program * ! * !****************************************************************************** ! ! Record length for hot start files (double precision for all reals) ihot_len=nbyte*(3+(6*nvrt+1+4*nvrt*ntracers)*ne+(8*nvrt+1)*ns+3*np+20*np*nvrt+1)+12 if(ihot/=0) then open(36,file='hotstart.in',access='direct',recl=ihot_len) read(36,rec=1)iths,time,(idry_e(i),(we(j,i),tsel(j,i,1),tsel(j,i,2), & &(trel0(j,i,l),trel(j,i,l),l=1,ntracers),j=1,nvrt),i=1,ne), & &(idry_s(i),(su2(j,i),sv2(j,i),tsd(j,i),ssd(j,i),j=1,nvrt),i=1,ns), & &(eta2(i),idry(i),(tnd(j,i),snd(j,i),tem0(j,i),sal0(j,i),q2(i,j),xl(i,j), & &dfv(i,j),dfh(i,j),dfq1(i,j),dfq2(i,j),j=1,nvrt),i=1,np),ifile,ifile_char ! Output hotstart.out for debugging open(32,file='hotstart.out') write(32,*)iths,time,ifile write(32,'(a12)')ifile_char write(32,*)'element,idry_e,level,we' do i=1,ne,100 write(32,*)i,idry_e(i),(j,we(j,i),j=1,nvrt) enddo !i write(32,*)'side,idry_s,level,su2,sv2,tsd,ssd' do i=1,ns,100 write(32,*)i,idry_s(i),(j,real(su2(j,i)),real(sv2(j,i)),real(tsd(j,i)),real(ssd(j,i)),j=1,nvrt) enddo !i write(32,*)'node,eta2,idry,level,tnd,snd,tem0,sal0,q2,xl' do i=1,np,100 write(32,*)i,eta2(i),idry(i), & &(j,real(tnd(j,i)),real(snd(j,i)),real(tem0(j,i)),real(sal0(j,i)),real(q2(i,j)),real(xl(i,j)),dfv(i,j),j=1,nvrt) enddo !i close(32) if(itur==3) then do i=1,np do j=1,nvrt q2(i,j)=dmax1(q2min,q2(i,j)) xl(i,j)=dmax1(xlmin2(i),xl(i,j)) enddo enddo endif close(36) !... change time and iteration for forecast mode !... Causion: this affects all t.h. files (fort.5[0-3]) and wind files if(ihot==1) then time=0 iths=0 endif write(*,*)'hot start at time=',time,iths write(16,*)'hot start at time=',time,iths !... find position in the wind input file for nws=1,2, and read in wind[x,y][1,2] !... ! if(nws==1) then ! open(22,file='wind.th',status='old') ! rewind(22) ! ninv=time/wtiminc ! wtime1=ninv*wtiminc ! wtime2=(ninv+1)*wtiminc ! do it=0,ninv ! read(22,*)wx1,wy1 ! enddo ! read(22,*)wx2,wy2 ! do i=1,np ! windx1(i)=wx1 ! windy1(i)=wy1 ! windx2(i)=wx2 ! windy2(i)=wy2 ! enddo ! endif if(nws>=2) then ninv=time/wtiminc wtime1=ninv*wtiminc wtime2=(ninv+1)*wtiminc #ifdef USE_SFLUX call get_wind(wtime1,windx1,windy1,pr1,airt1,shum1) call get_wind(wtime2,windx2,windy2,pr2,airt2,shum2) #endif if(nws==3) then ! Read sflux.th open(23,file='sflux.th',status='old') rewind(23) do it=0,iths read(23,*) enddo read(23,*)tmp,fluxsu00,srad00 endif !nws==3 endif !nws !... Nudging if(inu_st==2) then irec_nu=time/step_nu+1 time_nu=irec_nu*step_nu read(37,rec=irec_nu)floatout,((tnd_nu1(i,j),j=1,nvrt),i=1,np) read(35,rec=irec_nu)floatout,((snd_nu1(i,j),j=1,nvrt),i=1,np) read(37,rec=irec_nu+1)floatout,((tnd_nu2(i,j),j=1,nvrt),i=1,np) read(35,rec=irec_nu+1)floatout,((snd_nu2(i,j),j=1,nvrt),i=1,np) irec_nu=irec_nu+1 endif !... Find positions in t.h. files if(nettype>0) then do it=1,iths read(50,*) ttt,et enddo !it endif if(nfltype>0) then do it=1,iths read(51,*) ttt,qq enddo !it endif if(ntetype>0) then do it=1,iths read(52,*) ttt,te enddo !it endif if(nsatype>0) then do it=1,iths read(53,*) ttt,sal enddo !it endif if(nettype2>0) then do it=1,iths read(54,*) ttt do i=1,nope if(iettype(i)==4) then do j=1,nond(i) read(54,*)nd2,eth(i,j) enddo !j endif enddo !i enddo !it endif if(nfltype2>0) then do it=1,iths read(55,*) ttt do i=1,nope if(ifltype(i)==4) then do j=1,nond(i) read(55,*)nd2,(uthnd(i,j,k),vthnd(i,j,k),k=1,nvrt) enddo !j endif enddo !i enddo !it endif if(ntetype2>0) then do it=1,iths read(56,*) ttt do i=1,nope if(iabs(itetype(i))==4) then do j=1,nond(i) read(56,*)nd2,(tth(i,j,k),k=1,nvrt) enddo !j endif enddo !i enddo !it endif if(nsatype2>0) then do it=1,iths read(57,*) ttt do i=1,nope if(iabs(isatype(i))==4) then do j=1,nond(i) read(57,*)nd2,(sth(i,j,k),k=1,nvrt) enddo !j endif enddo !i enddo !it endif !... end hot start section !... endif !ihot.ne.0 if(nscreen.eq.1) write(*,*)'done initializing variables...' write(16,*)'done initializing variables...' ! * !****************************************************************************** ! * ! open output files * ! * !****************************************************************************** ! * !... write global output headers !... if(ihot<=1) then ifile=1 !output file # ! Convert it to a string write(ifile_char,'(i12)') ifile endif call header if(nscreen.eq.1) write(*,*)'done initializing outputs' write(16,*)'done initializing outputs' ! * !****************************************************************************** ! * ! Time stepping * ! * !****************************************************************************** ! * if(ihot==0) iths=0 if(nscreen.eq.1) write(*,*)'time stepping begins...',iths+1,ntime write(16,*)'time stepping begins...',iths+1,ntime !... Compute initial bed deformation and update depths info do i=1,np bdef1(i)=bdef(i)/ibdef*min0(iths,ibdef) dp(i)=dp00(i)-bdef1(i) hmod(i)=dmin1(dp(i),h_s) enddo !i do i=1,ns n1=isidenode(i,1) n2=isidenode(i,2) dps(i)=(dp(n1)+dp(n2))/2 enddo !i do i=1,ne dpe(i)=1.e10 do j=1,3 if(dpe(i)>dp(nm(i,j))) dpe(i)=dp(nm(i,j)) enddo !j enddo !i=1,ne !... Compute initial vgrid if(inunfl==0) then call levels0(iths,iths) else call levels1(iths,iths) endif if(nscreen.eq.1) write(*,*)'done computing initial vgrid...' write(16,*)'done computing initial vgrid...' !... Compute nodal vel. call nodalvel(ifltype) if(nscreen.eq.1) write(*,*)'done computing initial nodal vel...' write(16,*)'done computing initial nodal vel...' !... Debug: test btrack alone ! eta1=0; eta2=0; we=0 ! do i=1,ns ! do k=1,nvrt ! su2(k,i)=-ycj(i)*2*pi/3.0e3 ! sv2(k,i)=xcj(i)*2*pi/3.0e3 ! enddo !k ! enddo !i ! do i=1,ne ! do k=1,nvrt ! do j=1,3 ! nd=nm(i,j) ! ufg(k,i,j)=-y(nd)*2*pi/3.0e3 ! vfg(k,i,j)=x(nd)*2*pi/3.0e3 ! enddo !j ! enddo !k ! enddo !i ! do i=1,np ! do k=1,nvrt ! uu2(k,i)=-y(i)*2*pi/3.0e3 !5.e-16/81*x(i)**4 ! vv2(k,i)=x(i)*2*pi/3.0e3 ! ww2(k,i)=0 !-1.e-4*z(k,i)*(50+z(k,i)) ! enddo !k ! enddo !i !... End test btrack !... Compute initial density call eqstate if(nscreen.eq.1) write(*,*)'done computing initial density...' write(16,*)'done computing initial density...' !... Initialize heat budget model if(nws>=2.and.ihconsv/=0) then #ifdef USE_SFLUX call surf_fluxes(wtime1,windx1,windy1,pr1,airt1,shum1,srad,fluxsu,fluxlu,hradu,hradd,tauxz,tauyz, & #ifdef PREC_EVAP & fluxprc,fluxevp, & #endif & nws,fluxsu00,srad00) #endif do i=1,np sflux(i)=-fluxsu(i)-fluxlu(i)-(hradu(i)-hradd(i)) enddo if(nscreen.eq.1) write(*,*)'heat budge model completes...' write(16,*)'heat budge model completes...' endif !... Assign variables in GOTM for cold starts if(itur==4.and.(ihot==0.or.ihot==1.and.nramp==1)) then #ifdef USE_GOTM ! call init_turbulence(8,'gotmturb.inp',nvrt-1) !GOTM starts from level 0 ! call init_tridiagonal(nvrt-1) ! Debug ! do k=0,nvrt-1 ! write(99,*)k,tke1d(k),L1d(k),num1d(k),nuh1d(k) ! enddo !i ! stop do j=1,np q2(j,1:nvrt) = tke1d(0:(nvrt-1)) xl(j,1:nvrt) = L1d(0:(nvrt-1)) dfv(j,1:nvrt) = dmin1(diffmax(j),dmax1(diffmin(j),num1d(0:(nvrt-1)))) dfh(j,1:nvrt) = dmin1(diffmax(j),dmax1(diffmin(j),nuh1d(0:(nvrt-1)))) enddo !j #endif endif !itur==4 etc ! Read in spacially varying but temporally uniform wind if(nws==1) then open(21,file='wind_u.hgrid',status='old') open(22,file='wind_v.hgrid',status='old') read(21,*) read(21,*) read(22,*) read(22,*) do i=1,np read(21,*)j,xtmp,ytmp,windx(i) read(22,*)j,xtmp,ytmp,windy(i) enddo !i close(21) close(22) endif !... !... Begin time stepping !... do it=iths+1,ntime time=it*dt !... define ramp function for boundary elevation forcing, wind and pressure !... forcing and tidal potential forcing !... if(ibc==0) then if(nrampbc/=0) then rampbc=tanh(2*time/86400/drampbc) else rampbc=1 endif endif if(nws>0.and.nrampwind/=0) then rampwind=tanh(2*time/86400/drampwind) else rampwind=1 endif if(nramp==1) then ramp=tanh(2*time/86400/dramp) else ramp=1 endif !... Compute new bed deformation do i=1,np bdef2(i)=bdef(i)/ibdef*min0(it,ibdef) enddo !i !... Bottom drag coefficients for nchi=1; Cd and Cdp for nchi=0 already read in if(nchi==1) then !idrag=2 Cdp=0; Cd=0 !for dry pts do i=1,ns if(idry_s(i)==1) cycle ! Wet side htot=dps(i)+(eta2(isidenode(i,1))+eta2(isidenode(i,2)))/2 if(rough(i)<=0) then !time-independent Cd Cd(i)=dabs(rough(i)) else !roughness >0 bthick=zs(kbs(i)+1,i)-zs(kbs(i),i) !thickness of bottom bnd layer if(bthick<=rough(i)) then if(ifort12(17)==0) then ifort12(17)=1 write(12,*)'BL too fine:',i,bthick,rough(i),htot endif Cd(i)=Cdmax else Cd(i)=1/(2.5*dlog(bthick/rough(i)))**2 Cd(i)=dmin1(Cd(i),Cdmax) endif endif enddo !i=1,ns ! Drag at nodes do i=1,np if(idry(i)==1) cycle ! Wet node htot=dp(i)+eta2(i) if(rough_p(i)<=0) then !time-independent Cd Cdp(i)=dabs(rough_p(i)) else !roughness >0 bthick=z(kbp(i)+1,i)-z(kbp(i),i) !thickness of bottom bnd layer if(bthick<=rough_p(i)) then if(ifort12(5)==0) then ifort12(5)=1 write(12,*)'BL too fine (2):',i,bthick,rough_p(i),htot endif Cdp(i)=Cdmax else Cdp(i)=1/(2.5*dlog(bthick/rough_p(i)))**2 Cdp(i)=dmin1(Cdp(i),Cdmax) endif endif enddo !i=1,np ! Output Cd for first step if(it==iths+1) then open(32,file='Cd.out') write(32,*)'Drag coefficents for nchi=1' write(32,*)ns do i=1,ns write(32,'(i6,2e14.6,1x,e9.3)')i,xcj(i),ycj(i),Cd(i) enddo !i=1,ns close(32) endif endif !nchi==1 ! Check viscosity in linear drag formulation ! if(idrag==1.and.it==iths+1) then ! open(32,file='viscosity_linear.out') ! write(32,*)'Compare viscosity for idrag=1' ! write(32,*)ns,dfv0 ! do i=1,ns ! if(idry_s(i)==0) then ! bthick=zs(2,i)-zs(1,i) ! write(32,'(i6,3e14.6)')i,xcj(i),ycj(i),bthick*Cd(i) ! endif ! enddo !i=1,ns ! close(32) ! endif !... Horizontal diffusion; compute d2u, d2v (incorporated hvis inside) ! Bypss this section if ihorcon=0 (all horcon=0) and then isidenei() ! side_ac, and side_x are not used in the code call system_clock(ist,icount_rate) d2u=0; d2v=0 !for dry sides if(ihorcon/=0) then !not all horcon(i)=0 ! Compute d[u,v]/dx (x being local normal) first (saved in sdbt) (incorporated hvis inside) sdbt=0 !for dry side etc do i=1,ns if(idry_s(i)==1) cycle ! Wet side if(is(i,2)==0) then !bnd sides if(isbs(i)<=0.and.islip==1) then !no-slip land bnd do k=kbs(i),nvrt ie=is(i,1) icount=0 av_u=0 av_v=0 do j=1,3 id=js(ie,j) if(is(id,2)==0) cycle icount=icount+1 av_u=av_u+su2(k,id) !no vertical interpolation av_v=av_v+sv2(k,id) enddo !j if(icount==0) then write(11,*)'Isolated element' stop endif av_u=av_u/icount av_v=av_v/icount av_mag=dsqrt(av_u**2+av_v**2) sdbt(i,k,1)=-hdrag0*av_mag*av_u sdbt(i,k,2)=-hdrag0*av_mag*av_v enddo !k endif cycle endif if(horcon(i)==0) cycle ! Internal wet sides x_1=side_x(i,1) x_2=side_x(i,2) node1=isidenode(i,1) node2=isidenode(i,2) in11=lindex(node1,is(i,1)) in12=lindex(node1,is(i,2)) in21=lindex(node2,is(i,1)) in22=lindex(node2,is(i,2)) if(in11==0.or.in12==0.or.in21==0.or.in22==0) then write(11,*)'Wrong sides (9):',in11,in12,in21,in22,node1,node2,is(i,1:2) stop endif do k=kbs(i),nvrt ! Do vertical interpolation swild7=-1.e34 !flag do l=1,4 !2 intersections + 2 adjacent elements of side i if(l<=2) then ie=isidenei(i,l) !parent element for 2 intersections else ie=is(i,l-2) !adjacent element if(ie==isidenei(i,l-2)) cycle endif do j=1,3 !sides id=js(ie,j) if(idry_s(id)==1) then swild(1:2)=0 else kbb=kbs(id) alow(kbb:nvrt)=zs(kbb:nvrt,id) swild2(kbb:nvrt,1)=su2(kbb:nvrt,id) swild2(kbb:nvrt,2)=sv2(kbb:nvrt,id) call vinter(mnv,2,zs(k,i),kbb,nvrt,k,alow,swild2,swild,ibelow) endif swild6(j,1:2)=swild(1:2) ! Debug ! if(it==150) then ! write(99,*)i,l,j,swild(1),k,su2(kbb:nvrt,id) ! write(99,*)i,l,j,swild(2),k,sv2(kbb:nvrt,id) ! endif enddo !j=1,3 swild5(1,1:2)=swild6(2,1:2)+swild6(3,1:2)-swild6(1,1:2) !@ node 1 swild5(2,1:2)=swild6(1,1:2)+swild6(3,1:2)-swild6(2,1:2) swild5(3,1:2)=swild6(1,1:2)+swild6(2,1:2)-swild6(3,1:2) ! Save (u,v) at node[12] for y-derivatives if(ie==is(i,1)) then swild7(1,1,1:2)=swild5(in11,1:2) swild7(2,1,1:2)=swild5(in21,1:2) endif if(ie==is(i,2)) then swild7(1,2,1:2)=swild5(in12,1:2) swild7(2,2,1:2)=swild5(in22,1:2) endif if(l<=2) then swild(1:2)=side_ac(i,l,1:2) swild(3)=1-swild(1)-swild(2) soln(l,1:2)=0 !u[12], v[12] do j=1,3 soln(l,1)=soln(l,1)+swild(j)*swild5(j,1) soln(l,2)=soln(l,2)+swild(j)*swild5(j,2) enddo !j ! Debug ! if(it==150) then ! write(98,*)i,k,l,soln(l,1),swild5(1:3,1) ! write(98,*)i,k,l,soln(l,2),swild5(1:3,2) ! endif endif !l<=2 enddo !l=1,4 do i1=1,2 do i2=1,2 do i3=1,2 if(swild7(i1,i2,i3)<-1.e33) then write(11,*)'swild7 not assigned:',i1,i2,i3 stop endif enddo !i3 enddo !i2 enddo !i1 u_1=soln(1,1); u_2=soln(2,1) v_1=soln(1,2); v_2=soln(2,2) dudx=(x_2**2*(u_1-su2(k,i))-x_1**2*(u_2-su2(k,i)))/x_1/x_2/(x_2-x_1) dvdx=(x_2**2*(v_1-sv2(k,i))-x_1**2*(v_2-sv2(k,i)))/x_1/x_2/(x_2-x_1) dudy=(swild7(2,1,1)+swild7(2,2,1)-swild7(1,1,1)-swild7(1,2,1))/2/distj(i) dvdy=(swild7(2,1,2)+swild7(2,2,2)-swild7(1,1,2)-swild7(1,2,2))/2/distj(i) ! Transform to global coordinates dudx_g=dudx*snx(i)-dudy*sny(i) dudy_g=dudx*sny(i)+dudy*snx(i) dvdx_g=dvdx*snx(i)-dvdy*sny(i) dvdy_g=dvdx*sny(i)+dvdy*snx(i) hvis(k,i)=horcon(i)*(area(is(i,1))+area(is(i,2)))*dsqrt(dudx_g**2+dvdy_g**2+(dvdx_g+dudy_g)**2/2) sdbt(i,k,1)=hvis(k,i)*dudx sdbt(i,k,2)=hvis(k,i)*dvdx ! Debug ! if(it==500) then ! write(98,*)node1,node2,k,hvis(k,i) ! endif enddo !k=kbs(i),nvrt enddo !i=1,ns ! Debug ! if(it==500) stop do i=1,ns if(idry_s(i)==1) cycle ! Wet sides do k=kbs(i),nvrt ta=0 sumu=0 !integral sumv=0 !integral do j=1,2 !elements ie=is(i,j) if(ie==0) cycle ta=ta+area(ie) do l=1,3 !sides id=js(ie,l) if(is(i,2)/=0.and.id==i) cycle ! Do vertical interpolation if(idry_s(id)==1) then swild(1:2)=0 else kbb=kbs(id) alow(kbb:nvrt)=zs(kbb:nvrt,id) swild2(kbb:nvrt,1)=sdbt(id,kbb:nvrt,1) swild2(kbb:nvrt,2)=sdbt(id,kbb:nvrt,2) call vinter(mnv,2,zs(k,i),kbb,nvrt,k,alow,swild2,swild,ibelow) endif sumu=sumu+swild(1)*ssign(ie,l)*distj(id) sumv=sumv+swild(2)*ssign(ie,l)*distj(id) enddo !l=1,3 enddo !j; 2 adjacent elements if(ta==0) then write(11,*)'Impossible 127' stop endif d2u(k,i)=sumu/ta d2v(k,i)=sumv/ta enddo !k=kbs(i),nvrt enddo !i=1,ns endif !ihorcon/=0 call system_clock(ien,icount_rate) btimer=real(ien-ist)/icount_rate if(nscreen.eq.1) write(*,*)'done hvis and bottom fric: ',btimer,'seconds' !' write(16,*)'done hvis and bottom fric: ',btimer,' seconds..' !... Earth tidal potential at nodes: pre-compute to save time !... do i=1,np etp(i)=0 do jf=1,ntip ncyc=int(tfreq(jf)*time/2/pi) arg=tfreq(jf)*time-ncyc*2*pi+jspc(jf)*xlon(i)+tear(jf) etp(i)=etp(i)+ramp*tamp(jf)*tnf(jf)*fun_lat(i,jspc(jf))*dcos(arg) enddo !jf enddo !i !... process new wind info !... ! if(nws==1) then ! if(time>=wtime2) then ! wtime1=wtime2 ! wtime2=wtime2+wtiminc ! read(22,*) wx2,wy2 ! do i=1,np ! windx1(i)=windx2(i) ! windy1(i)=windy2(i) ! windx2(i)=wx2 ! windy2(i)=wy2 ! enddo ! endif ! wtratio=(time-wtime1)/wtiminc ! do i=1,np ! windx(i)=windx1(i)+wtratio*(windx2(i)-windx1(i)) ! windy(i)=windy1(i)+wtratio*(windy2(i)-windy1(i)) ! enddo !i ! endif !nws=1 ! CORIE mode if(nws>=2) then if(time>=wtime2) then !... Heat budget & wind stresses if(ihconsv/=0) then #ifdef USE_SFLUX call surf_fluxes(wtime2,windx2,windy2,pr2,airt2,shum2,srad,fluxsu,fluxlu,hradu,hradd,tauxz,tauyz, & #ifdef PREC_EVAP & fluxprc,fluxevp, & #endif & nws,fluxsu00,srad00) #endif do i=1,np sflux(i)=-fluxsu(i)-fluxlu(i)-(hradu(i)-hradd(i)) enddo if(nscreen.eq.1) write(*,*)'heat budge model completes...' write(16,*)'heat budge model completes...' endif !ihconsv.ne.0 wtime1=wtime2 wtime2=wtime2+wtiminc do i=1,np windx1(i)=windx2(i) windy1(i)=windy2(i) pr1(i)=pr2(i) airt1(i)=airt2(i) shum1(i)=shum2(i) enddo #ifdef USE_SFLUX call get_wind(wtime2,windx2,windy2,pr2,airt2,shum2) #endif endif !time>=wtime2 wtratio=(time-wtime1)/wtiminc do i=1,np windx(i)=windx1(i)+wtratio*(windx2(i)-windx1(i)) windy(i)=windy1(i)+wtratio*(windy2(i)-windy1(i)) pr(i)=pr1(i)+wtratio*(pr2(i)-pr1(i)) enddo !i ! Read in new flux values for next step if(nws==3) read(23,*) tmp,fluxsu00,srad00 endif !nws>=2 !... Re-scale wind if(nws>0) then do i=1,np windx(i)=windx(i)*windfactor(i) windy(i)=windy(i)*windfactor(i) enddo !i endif !... compute wind stress components dragcmin=1.0d-3*(0.61+0.063*6) dragcmax=1.0d-3*(0.61+0.063*50) do i=1,np if(nws==0) then tau(i,1)=0 tau(i,2)=0 else if(nws==1.or.nws>=2.and.ihconsv==0) then wmag=dsqrt(windx(i)**2+windy(i)**2) dragcoef=1.0d-3*(0.61+0.063*wmag) dragcoef=dmin1(dmax1(dragcoef,dragcmin),dragcmax) tau(i,1)=dragcoef*0.001293*wmag*windx(i)*rampwind tau(i,2)=dragcoef*0.001293*wmag*windy(i)*rampwind else !nws>=2 and ihconsv !=0; tauxz and tauyz defined if(idry(i)==1) then tau(i,1)=0 tau(i,2)=0 else !rescale as well tau(i,1)=-tauxz(i)/rho0*rampwind*windfactor(i)**2 !sign and scale difference between stresses tauxz and tau tau(i,2)=-tauyz(i)/rho0*rampwind*windfactor(i)**2 endif endif !nws enddo !i=1,np if(nscreen.eq.1) write(*,*)'done adjusting wind stress ...' write(16,*)'done adjusting wind stress ...' !... Read in temp. and salt for nudging if(inu_st==2) then if(time>time_nu) then irec_nu=irec_nu+1 time_nu=time_nu+step_nu tnd_nu1=tnd_nu2 snd_nu1=snd_nu2 read(37,rec=irec_nu)floatout,((tnd_nu2(i,j),j=1,nvrt),i=1,np) read(35,rec=irec_nu)floatout,((snd_nu2(i,j),j=1,nvrt),i=1,np) if(floatout/=time_nu) then write(11,*)'Wrong nudging time:',floatout,time_nu stop endif endif !time>time_nu ! Compute S,T rat=(time_nu-time)/step_nu if(rat<0.or.rat>1) then write(11,*)'Impossible 81:',rat stop endif tnd_nu=tnd_nu1+(1-rat)*(tnd_nu2-tnd_nu1) snd_nu=snd_nu1+(1-rat)*(snd_nu2-snd_nu1) endif !nudging !... Get new t.h. values *.th !... if(nettype>0) then read(50,*) ttt,(ath(i),i=1,nettype) if(it==iths+1.and.abs(ttt-time)>1.e-4) then write(11,*)'Starting time wrong for eta',it,ttt stop endif icount=0 do k=1,nope if(iettype(k)==1) then icount=icount+1 if(icount>nettype) then write(11,*)'Wrong counting 1' stop endif eth(k,1)=ath(icount) endif enddo endif if(nfltype>0) then read(51,*) ttt,(ath(i),i=1,nfltype) if(it==iths+1.and.abs(ttt-time)>1.e-4) then write(11,*)'Starting time wrong for flux',it,ttt,time stop endif icount=0 do k=1,nope if(ifltype(k)==1) then icount=icount+1 if(icount>nfltype) then write(11,*)'Wrong counting 2' stop endif qthcon(k)=ath(icount) endif enddo !k endif if(ntetype>0) then read(52,*) ttt,(ath(i),i=1,ntetype) if(it==iths+1.and.abs(ttt-time)>1.e-4) then write(11,*)'Starting time wrong for temp',it,ttt stop endif icount=0 do k=1,nope if(itetype(k)==1) then icount=icount+1 if(icount>ntetype) then write(11,*)'Wrong counting 3' stop endif tth(k,1,1)=ath(icount) endif enddo !k endif if(nsatype>0) then read(53,*) ttt,(ath(i),i=1,nsatype) if(it==iths+1.and.abs(ttt-time)>1.e-4) then write(11,*)'Starting time wrong for salt',it,ttt stop endif icount=0 do k=1,nope if(isatype(k)==1) then icount=icount+1 if(icount>nsatype) then write(11,*)'Wrong counting 4' stop endif sth(k,1,1)=ath(icount) endif enddo !k endif if(nettype2>0) then read(54,*) ttt if(it==iths+1.and.abs(ttt-time)>1.e-4) then write(11,*)'Starting time wrong for eta 2',it,ttt stop endif icount=0 do k=1,nope if(iettype(k)==4) then icount=icount+1 if(icount>nettype2) then write(11,*)'Wrong counting 7' stop endif do j=1,nond(k) nd=iond(k,j) read(54,*)nd2,eth(k,j) ! if(nd/=nd2) then ! write(11,*)'Wrong node # in elev3D.th',nd,nd2 ! stop ! endif enddo !j endif enddo !k endif if(nfltype2>0) then read(55,*) ttt if(it==iths+1.and.abs(ttt-time)>1.e-4) then write(11,*)'Starting time wrong for flux 2',it,ttt stop endif icount=0 do k=1,nope if(ifltype(k)==4) then icount=icount+1 if(icount>nfltype2) then write(11,*)'Wrong counting 6' stop endif do j=1,nond(k) nd=iond(k,j) read(55,*)nd2,(uthnd(k,j,l),vthnd(k,j,l),l=1,nvrt) ! if(nd/=nd2) then ! write(11,*)'Wrong node # in uv.th',nd,nd2 ! stop ! endif enddo !j endif enddo !k endif if(ntetype2>0) then read(56,*) ttt if(it==iths+1.and.abs(ttt-time)>1.e-4) then write(11,*)'Starting time wrong for temp. 2',it,ttt stop endif icount=0 do k=1,nope if(iabs(itetype(k))==4) then icount=icount+1 if(icount>ntetype2) then write(11,*)'Wrong counting 8' stop endif do j=1,nond(k) nd=iond(k,j) read(56,*)nd2,(tth(k,j,l),l=1,nvrt) ! if(nd/=nd2) then ! write(11,*)'Wrong node # in temp3D.th',nd,nd2 ! stop ! endif enddo !j endif enddo !k endif if(nsatype2>0) then read(57,*) ttt if(it==iths+1.and.abs(ttt-time)>1.e-4) then write(11,*)'Starting time wrong for salt 2',it,ttt stop endif icount=0 do k=1,nope if(iabs(isatype(k))==4) then icount=icount+1 if(icount>nsatype2) then write(11,*)'Wrong counting 9' stop endif do j=1,nond(k) nd=iond(k,j) read(57,*)nd2,(sth(k,j,l),l=1,nvrt) ! if(nd/=nd2) then ! write(11,*)'Wrong node # in salt3D.th',nd,nd2 ! stop ! endif enddo !j endif enddo !k endif !... Compute new vel. for flow b.c. ! Average total depth for calcualtion of cross-section areas do k=1,nope if(ifltype(k)/=0) then atd(k)=0 do i=1,nond(k) nd=iond(k,i) H2=dp(nd)+eta2(nd) if(H2<=h0) then write(11,*)'Dry bnd side:',H2,k,i stop endif atd(k)=atd(k)+H2/nond(k) enddo !i endif enddo !k do i=1,ns n1=isidenode(i,1) n2=isidenode(i,2) ibnd=isbs(i) if(ibnd<=0) cycle ! Open bnds if(iabs(ifltype(ibnd))==1.or.ifltype(ibnd)==2) then !including Flather 1 if(atd(ibnd)3.and.l<=6.and.ibt_s(js(i,l-3))==1) cycle if(l<=3) then jmin=kbp(nm(i,l)) else jmin=kbs(js(i,l-3)) endif do j=jmin,nvrt ! Initialize (x0,y0,z0),nnel and vel. ! Caution! nnel must be initialized inside this loop as it is updated inside. if(l<=3) then !nodes nd0=nm(i,l) iadvf=iadv(nd0) x0=x(nd0) y0=y(nd0) z0=z(j,nd0) uuint=uu2(j,nd0) vvint=vv2(j,nd0) wwint=ww2(j,nd0) else !sides isd0=js(i,l-3) n1=isidenode(isd0,1) n2=isidenode(isd0,2) iadvf=min(iadv(n1),iadv(n2)) x0=xcj(isd0) y0=ycj(isd0) z0=zs(j,isd0) uuint=su2(j,isd0) vvint=sv2(j,isd0) wwint=(ww2(j,n1)+ww2(j,n2))/2 endif vmag=dsqrt(uuint**2+vvint**2+wwint**2) nnel=ie0 jlev=j ! jlev=min(j+1,nvrt) !make sure j>=2 for division() if(vmag<=1.e-4) then !No activity if(l<=3) then ptbt(nd0,j,3)=tnd(j,nd0) ptbt(nd0,j,4)=snd(j,nd0) ptbt(nd0,j,1)=uu2(j,nd0) ptbt(nd0,j,2)=vv2(j,nd0) ! x3bt(nd0,j,1)=x0 ! x3bt(nd0,j,2)=y0 ! x3bt(nd0,j,3)=z0 ! nelvbt(nd0,j,1)=nnel ! nelvbt(nd0,j,2)=jlev else !sides sdbt(isd0,j,3)=tsd(j,isd0) sdbt(isd0,j,4)=ssd(j,isd0) sdbt(isd0,j,1)=su2(j,isd0) sdbt(isd0,j,2)=sv2(j,isd0) endif else !do btrack if(nadv>0) then dtb_max=dtb_max1 else if(iadvf<=1) then !nadv=0 dtb_max=dtb_max1 else dtb_max=dtb_max2 endif call btrack(i,l,j,iadvf,dtb_max,uuint,vvint,wwint,x0,y0,z0,nnel,jlev,xt,yt,zt,ndiv,swild) if(l<=3) then ptbt(nd0,j,3)=swild(1) ptbt(nd0,j,4)=swild(2) if(iadvf==0) then ptbt(nd0,j,1)=uu2(j,nd0) ptbt(nd0,j,2)=vv2(j,nd0) else ptbt(nd0,j,1)=uuint ptbt(nd0,j,2)=vvint endif ! x3bt(nd0,j,1)=xt ! x3bt(nd0,j,2)=yt ! x3bt(nd0,j,3)=zt ! nelvbt(nd0,j,1)=nnel ! nelvbt(nd0,j,2)=jlev else !sides sdbt(isd0,j,3)=swild(1) sdbt(isd0,j,4)=swild(2) if(iadvf==0) then sdbt(isd0,j,1)=su2(j,isd0) sdbt(isd0,j,2)=sv2(j,isd0) else sdbt(isd0,j,1)=uuint sdbt(isd0,j,2)=vvint endif endif !sides endif !do backtrack enddo !j=1,nvrt if(l<=3) then ibt_p(nd0)=1 else if(l<=6) then ibt_s(isd0)=1 endif enddo !l=1,6 enddo !i=1,ne ! Debug ! do i=1,np ! th=pi/2+2*pi/3000*time ! x0=1.8e3*cos(th) ! y0=1.8e3*sin(th) ! do k=1,nvrt ! prho(i,k)=dexp(-((x(i)-x0)**2+(y(i)-y0)**2)/2/600/600) !exact soln ! enddo !k ! enddo !i !... Compute division pts !... bubt: total integrated value do i=1,ne bubt(i,1)=0; bubt(i,2)=0 do j=1,3 !sides isd=js(i,j) if(idry_s(isd)==0) then do k=kbs(isd)+1,nvrt !layer bubt(i,1)=bubt(i,1)+(sdbt(isd,k,1)+sdbt(isd,k-1,1))/2*(zs(k,isd)-zs(k-1,isd))*area(i)/3 bubt(i,2)=bubt(i,2)+(sdbt(isd,k,2)+sdbt(isd,k-1,2))/2*(zs(k,isd)-zs(k-1,isd))*area(i)/3 enddo !k endif enddo !j enddo !i=1,ne call system_clock(ien,icount_rate) btimer=real(ien-ist)/icount_rate if(nscreen.eq.1) write(*,*)'btrack took',btimer,'seconds...' write(16,*)'backtracking took',btimer,'seconds...' ! Density gradient at nodes and whole levels using cubic spline dr_ds=0 !for sigma_t if(ibc==0) then do i=1,np if(idry(i)==1) cycle if(prho(i,1)<-98) then write(11,*)'Impossible 4' stop endif if(kbp(i)==kz) then drds_b=0 else !kbp < kz drds_b=(sig_t(i,kz+1)-sig_t(i,kz))/(sigma(2)-sigma(1)) endif do k=1,nsig klev=k-1+kz !kz<= klev <=nvrt if(k==1) then bdia(k)=(sigma(k+1)-sigma(k))/3 cupp(k)=bdia(k)/2 rrhs(k,1)=(sig_t(i,klev+1)-sig_t(i,klev))/(sigma(k+1)-sigma(k))-drds_b else if(k==nsig) then bdia(k)=(sigma(k)-sigma(k-1))/3 alow(k)=bdia(k)/2 rrhs(k,1)=-(sig_t(i,klev)-sig_t(i,klev-1))/(sigma(k)-sigma(k-1)) else bdia(k)=(sigma(k+1)-sigma(k-1))/3 alow(k)=(sigma(k)-sigma(k-1))/6 cupp(k)=(sigma(k+1)-sigma(k))/6 rrhs(k,1)=(sig_t(i,klev+1)-sig_t(i,klev))/(sigma(k+1)-sigma(k))- & &(sig_t(i,klev)-sig_t(i,klev-1))/(sigma(k)-sigma(k-1)) endif enddo !k call tridag(mnv,nsig,1,alow,bdia,cupp,rrhs,soln,gam) do k=1,nsig klev=k-1+kz !kz<= klev <=nvrt if(k==1) then dr_ds(i,klev)=drds_b else if(k==nsig) then dr_ds(i,klev)=0 else dr_ds(i,klev)=(sig_t(i,klev+1)-sig_t(i,klev))/(sigma(k+1)-sigma(k))- & &(sigma(k+1)-sigma(k))/6*(2*soln(k,1)+soln(k+1,1)) endif enddo !k enddo !i=1,np endif !ibc if(nscreen.eq.1) write(*,*)'done density gradient...' write(16,*)'done density gradient...' ! !************************************************************************ ! * ! Turbulence closure schemes * ! Compute turbulence diffusivities dfv, dfh, * ! and in MY-G, also dfq[1,2]. * ! * !************************************************************************ ! !... Scheme 2: Pacanowski and Philander (1981) if(itur==2) then dfv=0; dfh=0 !for dry nodes do i=1,np if(idry(i)==1) cycle if(prho(i,1)<-98) then write(11,*)'Impossible dry 1' stop endif ! wet nodes if(dp(i)<=h1_pp) then vmax=vdmax_pp1 vmin=vdmin_pp1 tmin=tdmin_pp1 else if(dp(i)= h2 vmax=vdmax_pp2 vmin=vdmin_pp2 tmin=tdmin_pp2 endif do k=kbp(i),nvrt if(k==kbp(i).or.k==nvrt) then drhodz=0 else drhodz=(prho(i,k+1)-prho(i,k-1))/(z(k+1,i)-z(k-1,i)) endif bvf=-g*(drhodz/rho0+g/1.5e3**2) k2=min(k+1,nvrt) k1=max(k-1,kbp(i)) dudz=(su2(k2,i)-su2(k1,i))/(z(k2,i)-z(k1,i)) dvdz=(sv2(k2,i)-sv2(k1,i))/(z(k2,i)-z(k1,i)) shear2=dmax1(dudz**2+dvdz**2,1.0d-10) rich=dmax1(bvf/shear2,0.0d0) ! vmax >= vmin dfv(i,k)=vmax/(1+5*rich)**2+vmin dfh(i,k)=dfv(i,k)/(1+5*rich)+tmin enddo !k enddo !i=1,np if(nscreen==1) write(*,*) 'done turbulence closure (PP)...' write(16,*) 'done turbulence closure (PP)...' endif !itur=2 !... Scheme 4: GOTM ! In GOTM, all turbulence variables are defined at whole levels from bottom to F.S. ! and mean flow variables at half levels. So the bottom is at level 0 (our kbp), ! F.S. is at level nlev (out nvrt). if(itur==4) then #ifdef USE_GOTM ! if(abs(cde-cmiu0**3)>1.e-4) then ! write(11,*)'Mismatch in GOTM call:',cde,cmiu0**3 ! stop ! endif write(16,*)'cde, cmiu0**3 = ',cde,cmiu0**3 do j=1,np ! Dry nodes will have initial values if(idry(j)==1) cycle ! Friction velocity: [\niu*|du/dz|]^0.5 (m/s) u_taus=sqrt(tau(j,1)**2+tau(j,2)**2) u_taub=sqrt(Cdp(j)*(uu2(kbp(j)+1,j)**2+vv2(kbp(j)+1,j)**2)) nlev=nvrt-kbp(j) do k=0,nlev klev=k+kbp(j) !kbp <= klev <= nvrt if(k/=0) h1d(k)=z(klev,j)-z(klev-1,j) ! Shear frequency squared (1/s^2): (du/dz)^2+(dv/dz)^2 ! Buoyancy frequency squared (1/s^2): -g/\rho0*(d\rho/dz)) if(k==0.or.k==nlev) then if(dfv(j,klev)<=0) then write(11,*)'Negative viscosity:',dfv(j,klev),j,klev stop endif if(k==0) then SS1d(k)=u_taub**2/dfv(j,klev) else SS1d(k)=u_taus**2/dfv(j,klev) endif NN1d(k)=0 else ztmp=z(klev+1,j)-z(klev-1,j) if(ztmp==0) then write(11,*)'Zero layer:',j,klev stop endif SS1d(k)=((uu2(klev+1,j)-uu2(klev-1,j))**2+(vv2(klev+1,j)-vv2(klev-1,j))**2)/ztmp**2 NN1d(k)=-g/rho0*(prho(j,klev+1)-prho(j,klev-1))/ztmp endif tke1d(k)=q2(j,klev) L1d(k)=xl(j,klev) if(tke1d(k)<=0.or.L1d(k)<=0) then write(11,*)'Negative tke,mixl:',tke1d(k),L1d(k),j,klev stop endif eps1d(k)=cde*tke1d(k)**1.5/L1d(k) num1d(k)=dfv(j,klev) nuh1d(k)=dfh(j,klev) ! Debug ! write(98,*)k,h1d(k),NN1d(k),SS1d(k) enddo !k=0,nlev ! h1d(0)=h1d(1) toth=eta2(j)+dp(j) ! surface and bottom roughness length (m) z0s=min(0.1d0,toth/10) if(Cdp(j)==0) then z0b=0 else z0b=(z(kbp(j)+1,j)-z(kbp(j),j))*exp(-0.4/sqrt(Cdp(j))) endif ! Debug ! write(99,*)j,'WOW1' ! write(98,*)nlev,dt,toth,u_taus,u_taub,z0s,z0b,h1d(0) call do_turbulence(nlev,dt,toth,u_taus,u_taub,z0s,z0b,h1d,NN1d,SS1d) ! Debug ! write(99,*)j,'WOW2' q2(j,kbp(j):nvrt) = tke1d(0:nlev) xl(j,kbp(j):nvrt) = L1d(0:nlev) ! eps(i,j,:) = eps1d do k=0,nlev klev=k+kbp(j) dfv(j,klev)=dmin1(diffmax(j),num1d(k)+diffmin(j)) dfh(j,klev)=dmin1(diffmax(j),nuh1d(k)+diffmin(j)) enddo !k enddo !j=1,np #endif endif !itur==4 !... Scheme 3: Mellor-Yamada-Galperin & Umlauf-Burchard scheme if(itur==3) then !------------------------------------------------------------ call system_clock(ist,icount_rate) do j=1,np if(idry(j)==1) then do k=1,nvrt q2(j,k)=q2min; xl(j,k)=xlmin2(j) dfv(j,k)=0; dfh(j,k)=0; dfq1(j,k)=0; dfq2(j,k)=0 enddo cycle endif if(prho(j,1)<-98) then write(11,*)'Impossible dry 2' stop endif ! Wet node; compute layer thickness etc. ! Error: use ufg? do k=kbp(j)+1,nvrt dzz(k)=z(k,j)-z(k-1,j) dudz=(uu2(k,j)-uu2(k-1,j))/dzz(k) dvdz=(vv2(k,j)-vv2(k-1,j))/dzz(k) shearbt(k)=dudz**2+dvdz**2 !@ half levels rzbt(k)=g/rho0*(prho(j,k)-prho(j,k-1))/dzz(k) q2ha(k)=(q2(j,k)+q2(j,k-1))/2 xlha(k)=(xl(j,k)+xl(j,k-1))/2 ! Compute c_psi_3 if(mid.eq.'MY') then cpsi3(k)=0.9 else !GLS models if(rzbt(k)>0) then !unstable cpsi3(k)=1 else !stable select case(mid) case('KL') cpsi3(k)=2.53 case('KE') cpsi3(k)=-0.52 case('KW') cpsi3(k)=-0.58 case('UB') cpsi3(k)=0.1 case default write(11,*)'Unknown closure model:',mid stop end select endif endif ! Wall proximity function if(mid.eq.'MY'.or.mid.eq.'KL') then zctr=(z(k,j)+z(k-1,j))/2 dists=eta2(j)-zctr distb=zctr+dp(j) if(dists==0.or.distb==0) then write(11,*)'Zero in proximity function:',j,k stop endif fwall=1+1.33*(xlha(k)/0.4/distb)**2+0.25*(xlha(k)/0.4/dists)**2 cpsi2p(k)=fwall*cpsi2 !F_wall*cpsi2 else !other GLS cpsi2p(k)=cpsi2 endif enddo !k=kbp(j)+1,nvrt rzbt(kbp(j))=0 !for Galperin's clipping ! write(90,*)'WOW1',it,j ! Compute upper bound for xl do k=kbp(j),nvrt dists=eta2(j)-z(k,j) distb=z(k,j)+dp(j) if(k==kbp(j)) then xlmax(k)=dmax1(xlmin2(j),dzz(j+1)*0.4) else if(k==nvrt) then xlmax(k)=dmax1(xlmin2(j),dzz(j)*0.4) else !internal layers xlmax(k)=0.4*dmin1(dists,distb) endif ! xlmax(k)=dmax1(0.4*dmin1(dists,distb),xlmin2(j)) !can be very small ! xlmax(k)=0.4*dists*distb/(dps(j)+etam) ! xlmax(k)=0.4*dmin1(dp(j)+eta2(j),xlmax00) if(xlmax(k)<=0) then write(11,*)'Dist<0 in MY-G',j,k,eta2(j)+dp(j),dists,distb stop endif enddo !k ! b.c. (computed using values from previous time except wind) q2fs=16.6**(2.0/3)*dsqrt(tau(j,1)**2+tau(j,2)**2)/2 q2fs=dmax1(q2fs,q2min) q2bot=16.6**(2.0/3)*Cdp(j)*(uu2(kbp(j)+1,j)**2+vv2(kbp(j)+1,j)**2)/2 q2bot=dmax1(q2bot,q2min) xlfs=dmax1(xlmin2(j),xlsc0(j)*dzz(nvrt)*0.4) xlbot=dmax1(xlmin2(j),dmin1(2.5d0,xlsc0(j)*dzz(kbp(j)+1))*0.4) !"5" to prevent over-mixing ! write(90,*)'WOW2',it,j ! Matrix Q nqdim=nvrt-kbp(j)+1 do k=kbp(j),nvrt kin=k-kbp(j)+1 !row # alow(kin)=0 bdia(kin)=0 cupp(kin)=0 rrhs(kin,1)=0 if(k=0) then rrhs(kin,1)=rrhs(kin,1)+dt*dzz(k+1)/2*(prod+buoy) else tmp=dt*dzz(k+1)/6*(prod+buoy)/q2ha(k+1) bdia(kin)=bdia(kin)-2*tmp cupp(kin)=cupp(kin)-tmp endif diss=cmiu0**3*dsqrt(q2ha(k+1))/xlha(k+1)*dzz(k+1)/6 !diss/k bdia(kin)=bdia(kin)+dt*diss*2 cupp(kin)=cupp(kin)+dt*diss endif if(k>kbp(j)) then tmp=(dfq1(j,k)+dfq1(j,k-1))/2*dt/dzz(k) bdia(kin)=bdia(kin)+dzz(k)/3+tmp alow(kin)=alow(kin)+dzz(k)/6-tmp rrhs(kin,1)=rrhs(kin,1)+dzz(k)/6*(2*q2(j,k)+q2(j,k-1)) prod=(dfv(j,k)+dfv(j,k-1))/2*shearbt(k) buoy=(dfh(j,k)+dfh(j,k-1))/2*rzbt(k) if(prod+buoy>=0) then rrhs(kin,1)=rrhs(kin,1)+dt*dzz(k)/2*(prod+buoy) else tmp=dt*dzz(k)/6*(prod+buoy)/q2ha(k) bdia(kin)=bdia(kin)-2*tmp alow(kin)=alow(kin)-tmp endif diss=cmiu0**3*dsqrt(q2ha(k))/xlha(k)*dzz(k)/6 !diss/k bdia(kin)=bdia(kin)+dt*diss*2 alow(kin)=alow(kin)+dt*diss endif enddo !k=1,nvrt ! Soln for q2 at new level call tridag(mnv,nqdim,1,alow,bdia,cupp,rrhs,soln,gam) do k=kbp(j),nvrt kin=k-kbp(j)+1 if(k==nvrt) then q2tmp(k)=q2fs else if(k==kbp(j)) then q2tmp(k)=q2bot else q2tmp(k)=dmax1(soln(kin,1),q2min) endif enddo !k ! write(90,*)'WOW4',it,j,(q2tmp(k),k=1,nvrt) ! do k=1,nvrt ! write(90,*)'Level ',k,alow(k),bdia(k),cupp(k) ! enddo ! Matrix QL do k=kbp(j),nvrt kin=k-kbp(j)+1 alow(kin)=0 bdia(kin)=0 cupp(kin)=0 rrhs(kin,1)=0 if(k=0) then rrhs(kin,1)=rrhs(kin,1)+dt*dzz(k+1)/2*(prod+buoy)*(psi_n+psi_n1)/2/q2ha(k+1) else tmp=dt*dzz(k+1)/6*(prod+buoy)/q2ha(k+1) bdia(kin)=bdia(kin)-2*tmp cupp(kin)=cupp(kin)-tmp endif diss=cpsi2p(k+1)*cmiu0**3*dsqrt(q2ha(k+1))/xlha(k+1)*dzz(k+1)/6 !diss/k bdia(kin)=bdia(kin)+dt*diss*2 cupp(kin)=cupp(kin)+dt*diss else !k=nvrt bdia(kin)=bdia(kin)+0.4*rnub*dt*dfq2(j,k)/xl(j,k) endif if(k>kbp(j)) then tmp=(dfq2(j,k)+dfq2(j,k-1))/2*dt/dzz(k) bdia(kin)=bdia(kin)+dzz(k)/3+tmp alow(kin)=alow(kin)+dzz(k)/6-tmp psi_n=cmiu0**rpub*q2(j,k)**rmub*xl(j,k)**rnub !psi^n_{j,k} psi_n1=cmiu0**rpub*q2(j,k-1)**rmub*xl(j,k-1)**rnub !psi^n_{j,k-1} rrhs(kin,1)=rrhs(kin,1)+dzz(k)/6*(2*psi_n+psi_n1) prod=cpsi1*(dfv(j,k)+dfv(j,k-1))/2*shearbt(k) buoy=cpsi3(k)*(dfh(j,k)+dfh(j,k-1))/2*rzbt(k) if(prod+buoy>=0) then rrhs(kin,1)=rrhs(kin,1)+dt*dzz(k)/2*(prod+buoy)*(psi_n+psi_n1)/2/q2ha(k) else tmp=dt*dzz(k)/6*(prod+buoy)/q2ha(k) bdia(kin)=bdia(kin)-2*tmp alow(kin)=alow(kin)-tmp endif diss=cpsi2p(k)*cmiu0**3*dsqrt(q2ha(k))/xlha(k)*dzz(k)/6 !diss/k bdia(kin)=bdia(kin)+dt*diss*2 alow(kin)=alow(kin)+dt*diss else !k=kbp(j) bdia(kin)=bdia(kin)+0.4*rnub*dt*dfq2(j,k)/xl(j,k) endif enddo !k=kbp(j),nvrt ! write(90,*)'WOW5',it,j ! do k=1,nvrt ! write(90,*)'Level ',k,alow(k),bdia(k),cupp(k) ! enddo ! Soln for q2l and xl at new level call tridag(mnv,nqdim,1,alow,bdia,cupp,rrhs,soln,gam) ! write(90,*)'WOW6',it,j do k=kbp(j),nvrt kin=k-kbp(j)+1 q2l=dmax1(soln(kin,1),psimin) if(k==nvrt) then xltmp(k)=xlfs else if(k==kbp(j)) then xltmp(k)=xlbot else xltmp(k)=(q2l*cmiu0**(-rpub)*q2tmp(k)**(-rmub))**(1/rnub) endif ! Galperin's clipping if(rzbt(k)<0) then upper=dsqrt(-0.56*q2tmp(k)/rzbt(k)) xltmp(k)=dmin1(xltmp(k),upper) endif ! Max. length based on dissipation; xlmin2 prevails xl_max=(cmiu0*dsqrt(q2tmp(k)))**3/eps_min xltmp(k)=dmax1(xlmin2(j),dmin1(xl_max,xltmp(k))) ! Impose max. depth limit xltmp(k)=dmax1(xlmin2(j),dmin1(xltmp(k),xlmax(k))) q2(j,k)=q2tmp(k) xl(j,k)=xltmp(k) if(q2(j,k)<0) then write(11,*)'Negative q2',q2(j,k),xl(j,k) stop endif ! Compute vertical diffusivities at new time call asm(g,j,k,vd,td,qd1,qd2) dfv(j,k)=dmin1(diffmax(j),dmax1(diffmin(j),vd)) dfh(j,k)=dmin1(diffmax(j),dmax1(diffmin(j),td)) dfq1(j,k)=dmin1(diffmax(j),dmax1(diffmin(j),qd1)) dfq2(j,k)=dmin1(diffmax(j),dmax1(diffmin(j),qd2)) ! Debug ! write(90,*)'No. ',k,xl(j,k),dfh(j,k),dfv(j,k),dfq1(j,k),dfq2(j,k) enddo !k ! Extend do k=1,kbp(j)-1 q2(j,k)=q2(j,kbp(j)) xl(j,k)=xl(j,kbp(j)) dfv(j,k)=dfv(j,kbp(j)) dfh(j,k)=dfh(j,kbp(j)) dfq1(j,k)=dfq1(j,kbp(j)) dfq2(j,k)=dfq2(j,kbp(j)) enddo !k enddo !j=1,np ! if(it.eq.1739) write(90,*)'WOW7',it call system_clock(ien,icount_rate) btimer=real(ien-ist)/icount_rate if(nscreen.eq.1) write(*,*)'MYG-UB took',btimer,'seconds' write(16,*)'MYG-UB took',btimer,'seconds' !------------------------------------------------------------ endif !itur=3 ! !************************************************************************ ! * ! Wave-continuity equations * ! * !************************************************************************ ! call system_clock(ist,icount_rate) !... compute elevation essential boundary conditions !... elbc=-9999 !flags do i=1,nope do j=1,nond(i) nd=iond(i,j) if(iettype(i)==1.or.iettype(i)==2) then elbc(nd)=ramp*eth(i,1) else if(iettype(i)==3) then elbc(nd)=0 !initialize do jfr=1,nbfr ncyc=int(amig(jfr)*time/2/pi) arg=amig(jfr)*time-ncyc*2*pi+face(jfr)-efa(i,j,jfr) elbc(nd)=elbc(nd)+ramp*ff(jfr)*emo(i,j,jfr)*dcos(arg) enddo !jfr=1,nbfr else if(iettype(i)==4) then elbc(nd)=ramp*eth(i,j) endif enddo !j=1,noe(i) enddo !i=1,nope !... Pre-compute some arrays: chi,hhat,bigu,ghat1 !... do i=1,ns if(idry_s(i)==1) then chi(i)=0 hhat(i)=0 bigu(i,1)=0 bigu(i,2)=0 cycle endif ! Wet side n1=isidenode(i,1) n2=isidenode(i,2) if(idrag==1) then chi(i)=Cd(i) else chi(i)=Cd(i)*dsqrt(sdbt(i,kbs(i)+1,1)**2+sdbt(i,kbs(i)+1,2)**2) endif hhat(i)=(eta2(n1)+eta2(n2))/2+dps(i)-chi(i)*dt ! Enforce positivity if(ihhat==1) hhat(i)=dmax1(0.d0,hhat(i)) ! bigu1,2 bigu(i,1)=0 !U^n_x bigu(i,2)=0 !U^n_y do k=kbs(i),nvrt-1 bigu(i,1)=bigu(i,1)+(zs(k+1,i)-zs(k,i))*(su2(k,i)+su2(k+1,i))/2 bigu(i,2)=bigu(i,2)+(zs(k+1,i)-zs(k,i))*(sv2(k,i)+sv2(k+1,i))/2 enddo !k enddo !i=1,ns call system_clock(ien,icount_rate) btimer=real(ien-ist)/icount_rate if(nscreen==1) write(*,*)'1st preparation took ',btimer,'seconds' write(16,*)'1st preparation took ',btimer,'seconds' call system_clock(ist,icount_rate) ! ghat1 do i=1,ne if(idry_e(i)==1) then ghat1(i,1)=0 ghat1(i,2)=0 cycle endif ! Wet elements ! Excluding hvis, baroclinc force first ! Warning: \hat{G}_1 must include all: Coriolis, atmo. pressure, tidal potential, horizontal difusion, and baroclinic ! Remember to update both f (botf) and F (bigf) tau_x=0 tau_y=0 detadx=0 detady=0 dprdx=0 dprdy=0 detpdx=0 detpdy=0 chigamma=0 ubstar=0 !bottom advection * \chi vbstar=0 hhat_bar=0 h_bar=0 bigf1=0 !all in F except baroclinic and hvis bigf2=0 botf1=0 !all in \chi*f_b except baroclinic and hvis botf2=0 do j=1,3 !node or side nd=nm(i,j) tau_x=tau_x+tau(nd,1)/3 tau_y=tau_y+tau(nd,2)/3 ! idry_e(i) checked already detadx=detadx+eta2(nd)*dl(i,j,1) detady=detady+eta2(nd)*dl(i,j,2) dprdx=dprdx+pr(nd)*dl(i,j,1) dprdy=dprdy+pr(nd)*dl(i,j,2) if(dpe(i)>=tip_dp) then detpdx=detpdx+etp(nd)*dl(i,j,1) detpdy=detpdy+etp(nd)*dl(i,j,2) endif h_bar=h_bar+(dp(nd)+eta2(nd))/3 isd=js(i,j) chigamma=chigamma+chi(isd)/3 hhat_bar=hhat_bar+hhat(isd)/3 ubstar=ubstar+chi(isd)*sdbt(isd,kbs(isd)+1,1)/3 vbstar=vbstar+chi(isd)*sdbt(isd,kbs(isd)+1,2)/3 bigf1=bigf1+cori(isd)*bigu(isd,2)/3 bigf2=bigf2-cori(isd)*bigu(isd,1)/3 botf1=botf1+chi(isd)*cori(isd)*sv2(kbs(isd)+1,isd)/3 botf2=botf2-chi(isd)*cori(isd)*su2(kbs(isd)+1,isd)/3 enddo !j=1,3 bigf1=bigf1+h_bar*(0.69*g*detpdx-dprdx/rho0) bigf2=bigf2+h_bar*(0.69*g*detpdy-dprdy/rho0) botf1=botf1+chigamma*(0.69*g*detpdx-dprdx/rho0) botf2=botf2+chigamma*(0.69*g*detpdy-dprdy/rho0) ghat1(i,1)=bubt(i,1)+area(i)*dt*(bigf1+tau_x-ubstar-dt*botf1-g*(1-thetai)*hhat_bar*detadx) ghat1(i,2)=bubt(i,2)+area(i)*dt*(bigf2+tau_y-vbstar-dt*botf2-g*(1-thetai)*hhat_bar*detady) ! Horizontal diffusion horx=0 hory=0 do j=1,3 !side isd=js(i,j) do k=kbs(isd)+1,nvrt horx=horx+area(i)/3*(zs(k,isd)-zs(k-1,isd))*(d2u(k,isd)+d2u(k-1,isd))/2 hory=hory+area(i)/3*(zs(k,isd)-zs(k-1,isd))*(d2v(k,isd)+d2v(k-1,isd))/2 enddo !k horx=horx-dt*chigamma*area(i)/3*d2u(kbs(isd)+1,isd) hory=hory-dt*chigamma*area(i)/3*d2v(kbs(isd)+1,isd) enddo !j=1,3 ghat1(i,1)=ghat1(i,1)+dt*horx ghat1(i,2)=ghat1(i,2)+dt*hory ! Baroclinic force if(ibc==0) then if(prho(nm(i,1),1)<-98.or.prho(nm(i,2),1)<-98.or.prho(nm(i,3),1)<-98) then write(11,*)'Impossible dry 5' stop endif ! Density is defined at 3 nodes ! Area integrals evaluated using z- or sigma- node1=nm(i,1); node2=nm(i,2); node3=nm(i,3) hmax=dmax1(hmod(node1),hmod(node2),hmod(node3)) ! Initialize starting searching level for z- method do j=1,3 nwild(2*j-1)=1 !starting level for j @ j+1 nwild(2*j)=1 !j @ j+2 enddo !j do k=kz,nvrt !S-levels first kin=k-kz+1 !S-index hbar=0 !average of dz_ds do j=1,3 nd=nm(i,j) if(iback(nd)/=0) then !use traditional sigma dzds=eta2(nd)+hmod(nd) else dzds=eta2(nd)+h_c+(hmod(nd)-h_c)*dcs(kin) endif hbar=hbar+dzds/3 out3(k,j)=dzds !save space enddo !j if(hmax<=h_bcc1) then !sigma- rrhs(k,1)=0 !dr_dx rrhs(k,2)=0 !dr_dy rrhs(k,3)=0 !dzdx rrhs(k,4)=0 !dzdy av=0 !average dr_ds sig_tm=(sig_t(node1,k)+sig_t(node2,k)+sig_t(node3,k))/3 !for removal of mean zmean=(z(k,node1)+z(k,node2)+z(k,node3))/3 do j=1,3 nd=nm(i,j) rrhs(k,1)=rrhs(k,1)+(sig_t(nd,k)-sig_tm)*dl(i,j,1) rrhs(k,2)=rrhs(k,2)+(sig_t(nd,k)-sig_tm)*dl(i,j,2) rrhs(k,3)=rrhs(k,3)+(z(k,nd)-zmean)*dl(i,j,1) rrhs(k,4)=rrhs(k,4)+(z(k,nd)-zmean)*dl(i,j,2) av=av+dr_ds(nd,k)/3 enddo !j alow(kin)=-g/rho0*area(i)*(hbar*rrhs(k,1)-rrhs(k,3)*av) !integrand M * (-g)/rho0 bdia(kin)=-g/rho0*area(i)*(hbar*rrhs(k,2)-rrhs(k,4)*av) else !z- rrhs(k,1)=0 !average dr_dx rrhs(k,2)=0 !average dr_dy icount=0 !valid nodes for drho do j=1,3 !node n1=nm(i,j) ifl=0 !flag to indicate valid computation do l=1,2 !other 2 nodes nd=nm(i,nx(j,l)) isd=js(i,nx(j,3-l)) if(isidenode(isd,1)==n1) then fac=1 else fac=-1 endif out2(2*l+1)=-fac*sny(isd) !l_x out2(2*l+2)=fac*snx(isd) !l_y if(z(k,n1)=1) then write(11,*)'Impossible 69:',zrat stop endif rho_tmp=zrat*sig_t(nd,kbp(nd))+(1-zrat)*sig_t(n1,kbp(n1)) rl=zrat*distj(isd) out2(l)=(rho_tmp-sig_t(n1,k))/rl endif else if(z(k,n1)>z(nvrt,nd)) then if(k==kbp(n1).or.k==nvrt) then ifl=1 exit else zrat=(z(nvrt,n1)-z(k,n1))/(z(nvrt,n1)-z(nvrt,nd)) if(zrat<=0.or.zrat>=1) then write(11,*)'Impossible 69b:',zrat stop endif rho_tmp=zrat*sig_t(nd,nvrt)+(1-zrat)*sig_t(n1,nvrt) rl=zrat*distj(isd) out2(l)=(rho_tmp-sig_t(n1,k))/rl endif else !must have a valid level lev=0 !flag nwild(2*j-2+l)=max0(nwild(2*j-2+l),kbp(nd)) do kk=nwild(2*j-2+l),nvrt-1 if(z(k,n1)>=z(kk,nd).and.z(k,n1)<=z(kk+1,nd)) then lev=kk zrat=(z(k,n1)-z(kk,nd))/(z(kk+1,nd)-z(kk,nd)) if(zrat<0.or.zrat>1) then write(11,*)'Impossible 70:',zrat stop endif exit endif enddo !kk if(lev==0) then write(11,*)'Failed to find a level in bcc:',n1,nd stop endif nwild(2*j-2+l)=lev !for next k-iteration rho_tmp=zrat*sig_t(nd,lev+1)+(1-zrat)*sig_t(nd,lev) out2(l)=(rho_tmp-sig_t(n1,k))/distj(isd) endif enddo !l=1,2 if(ifl==0) then icount=icount+1 delta=out2(3)*out2(6)-out2(5)*out2(4) if(delta==0) then write(11,*)'Ill formed element:',i stop endif rrhs(k,1)=rrhs(k,1)+(out2(6)*out2(1)-out2(4)*out2(2))/delta rrhs(k,2)=rrhs(k,2)+(out2(3)*out2(2)-out2(5)*out2(1))/delta endif !ifl==0 enddo !j=1,3; nodes if(icount/=0) then rrhs(k,1)=rrhs(k,1)/icount rrhs(k,2)=rrhs(k,2)/icount endif alow(kin)=-g/rho0*area(i)*hbar*rrhs(k,1) bdia(kin)=-g/rho0*area(i)*hbar*rrhs(k,2) endif !sigma or z enddo !k=kz,nvrt do k=1,nsig-1 !S-index if(mmm==0) then !trapzoidal rule soln(k,1)=(alow(k+1)+alow(k))/2*(sigma(k+1)-sigma(k)) soln(k,2)=(bdia(k+1)+bdia(k))/2*(sigma(k+1)-sigma(k)) else !Lagrangian soln(k,1)=rint_lag(mnv,1,nsig,mmm,k,sigma,sigmap,sigma_prod,alow,gam,ctmp) soln(k,2)=rint_lag(mnv,1,nsig,mmm,k,sigma,sigmap,sigma_prod,bdia,gam,ctmp) endif enddo !k do k=kz,nvrt hp_int(k,i,1)=0 !\int f_{c} d\Omega hp_int(k,i,2)=0 do kk=k,nvrt-1 kin=kk-kz+1 !S-index hp_int(k,i,1)=hp_int(k,i,1)+soln(kin,1) hp_int(k,i,2)=hp_int(k,i,2)+soln(kin,2) enddo !kk enddo !k ! Integrand for ghat1 do l=1,nsig-1 !integrand=0 when l=nsig lev=l-1+kz do m=l,nsig mlev=m-1+kz sum21=0 !double sum 1 sum22=0 !double sum 2 do j=1,3 do jj=1,3 if(j==jj) then fac=2 else fac=1 endif sum21=sum21+fac*out3(lev,j)*out3(mlev,jj) sum22=sum22+fac*out3(lev,j)*dr_ds(nm(i,jj),mlev) enddo !jj enddo !j if(hmax<=h_bcc1) then !sigma- alow(m)=-g/rho0*area(i)/12*(rrhs(mlev,1)*sum21-rrhs(mlev,3)*sum22) !integrand N bdia(m)=-g/rho0*area(i)/12*(rrhs(mlev,2)*sum21-rrhs(mlev,4)*sum22) !integrand N else !z alow(m)=-g/rho0*area(i)/12*sum21*rrhs(mlev,1) bdia(m)=-g/rho0*area(i)/12*sum21*rrhs(mlev,2) endif enddo !m cupp(l)=0 !outer integrand rrhs(l,5)=0 !outer integrand do m=l,nsig-1 if(mmm==0) then !trapzoidal rule cupp(l)=cupp(l)+(alow(m+1)+alow(m))/2*(sigma(m+1)-sigma(m)) rrhs(l,5)=rrhs(l,5)+(bdia(m+1)+bdia(m))/2*(sigma(m+1)-sigma(m)) else !Lagrangian cupp(l)=cupp(l)+rint_lag(mnv,l,nsig,mmm,m,sigma,sigmap,sigma_prod,alow,gam,ctmp) rrhs(l,5)=rrhs(l,5)+rint_lag(mnv,l,nsig,mmm,m,sigma,sigmap,sigma_prod,bdia,gam,ctmp) endif enddo !m enddo !l=1,nsig-1 cupp(nsig)=0; rrhs(nsig,5)=0 bigfc1=0 do l=1,nsig-1 if(mmm==0) then !trapzoidal rule bigfc1=bigfc1+(cupp(l+1)+cupp(l))/2*(sigma(l+1)-sigma(l)) else !Lagrangian bigfc1=bigfc1+rint_lag(mnv,1,nsig,mmm,l,sigma,sigmap,sigma_prod,cupp,gam,ctmp) endif enddo !l do l=1,nsig cupp(l)=rrhs(l,5) enddo !l bigfc2=0 do l=1,nsig-1 if(mmm==0) then !trapzoidal rule bigfc2=bigfc2+(cupp(l+1)+cupp(l))/2*(sigma(l+1)-sigma(l)) else !Lagrangian bigfc2=bigfc2+rint_lag(mnv,1,nsig,mmm,l,sigma,sigmap,sigma_prod,cupp,gam,ctmp) endif enddo !l ! z-levels if(kbe(i)kbe(i)+1) then soln(k,3)=ztot(k)-ztot(k-1) !thickness endif if(k/=kbe(i).and.soln(k,3)<=0) then write(11,*)'Thickness <=0:',i,k,soln(k,3) stop endif soln(k,1)=0 !dr_dx soln(k,2)=0 !dr_dy sig_tm=(sig_t(node1,k)+sig_t(node2,k)+sig_t(node3,k))/3 !for removal of mean do j=1,3 !nodes nd=nm(i,j) soln(k,1)=soln(k,1)+(sig_t(nd,k)-sig_tm)*dl(i,j,1) soln(k,2)=soln(k,2)+(sig_t(nd,k)-sig_tm)*dl(i,j,2) ! if(k/=kbe(i)) then ! if(k-10) then !open bnd node ibnd=isbnd(i) do l=1,2 !side if(l==1) then ie=ine(i,1) id=iself(i,1) isd=js(ie,nx(id,2)) nj=nm(ie,nx(id,1)) ind=1 else ie=ine(i,nne(i)) id=iself(i,nne(i)) isd=js(ie,nx(id,1)) nj=nm(ie,nx(id,2)) ind=nnp(i) endif nd=isidenode(isd,1)+isidenode(isd,2)-i if(nd/=nj) then write(11,*)'Impossible 79' stop endif ! I_3 if(isbs(isd)>0.and.ifltype(isbs(isd))/=0) then !natural or Flather 1 b.c. if(idry_s(isd)==1) then write(11,*)'Dry flow bnd:',isd,i,nd stop endif bigvn=0 do k=kbs(isd),nvrt-1 vn1=uth(isd,k)*snx(isd)+vth(isd,k)*sny(isd) vn2=uth(isd,k+1)*snx(isd)+vth(isd,k+1)*sny(isd) bigvn=bigvn+(zs(k+1,isd)-zs(k,isd))*(vn1+vn2)/2 enddo !k ri3=distj(isd)*bigvn/2 if(ifltype(isbs(isd))==-1) then !Flather 1 if(eta_mean(i)<-98.or.eta_mean(nj)<-98) then write(11,*)'Mismatch 1' stop endif if(dps(isd)<=0) then write(11,*)'Negative depth at Flather bnd:',i,dps(isd) stop endif con0=distj(isd)/6*dsqrt(g*dps(isd)) !for coefficient matrix ri3=ri3-con0*(2*eta_mean(i)+eta_mean(nj)) sparsem(i,0)=sparsem(i,0)+thetai*dt*con0*2 sparsem(i,ind)=sparsem(i,ind)+thetai*dt*con0 endif !Flather 1 qel(i)=qel(i)-thetai*dt*ri3 endif ! I_5 if(isbs(isd)>0.and.idry_s(isd)==0) then Unbar=bigu(isd,1)*snx(isd)+bigu(isd,2)*sny(isd) qel(i)=qel(i)-(1-thetai)*dt*distj(isd)*Unbar/2 endif enddo !l=1,2 sides endif !bnd node i enddo !i=1,np ! Check symmetry (comment out afterwards) do i=1,np do j=1,nnp(i) nd=inp(i,j) index=0 do l=1,nnp(nd) if(inp(nd,l)==i) index=l enddo !l if(index==0) then write(11,*)'Index not symmetric:',i,j,nd stop endif if(dabs(sparsem(i,j)-sparsem(nd,index))>1.e-5) then write(11,*)'Matrix not symmetric:',i,j,nd,sparsem(i,j),sparsem(nd,index) stop endif enddo !j enddo !i !... To impose elevation essential b.c., create a mapping between element index and actual eq. index icount=0 do i=1,np if(isbnd(i)>0.and.iettype(isbnd(i))/=0) then icount=icount+1 else imap(i)=i-icount endif enddo !i !... Assemble sparse matrix format !... neq=0 !final index of eqs. nnz=0 !!# of non-zero entries do i=1,np if(isbnd(i)>0.and.iettype(isbnd(i))/=0) cycle neq=neq+1 nnz=nnz+1 icoef(neq)=nnz jcoef(nnz)=imap(i) if(imap(i)/=neq) then write(11,*)'Impossible 300',i stop endif e2coef(nnz)=sparsem(i,0) qel2(neq)=qel(i) eta3(neq)=eta2(i) !initial guess do j=1,nnp(i) nd=inp(i,j) if(isbnd(nd)>0.and.iettype(isbnd(nd))/=0) then !essential b.c. if(elbc(nd)<-9998) then write(11,*)'Eta not assigned:',nd,isbnd(nd) stop endif qel2(neq)=qel2(neq)-sparsem(i,j)*elbc(nd) else if(nd>i) then !upper triangle only nnz=nnz+1 jcoef(nnz)=imap(nd) e2coef(nnz)=sparsem(i,j) endif enddo !j enddo !i=1,np if(neq<=0) then write(11,*)'No eqs. to be solved!' stop endif icoef(neq+1)=nnz+1 !... solve the wave equation for elevations at each element center !... jcg jacobi conjugate gradient solver from itpack2d, srcv2d.f !... st=0 !secnds(0.0) !timing the process !... input information about solver !... call dfault(iparm,rparm) iparm(1)=itmax1 iparm(2)=1 !level of output msg iparm(4)=33 !output msg to fort.?? iparm(5)=0 !symmetric system ! iparm(10)=iremove iparm(11)=1 !no timing iparm(12)=1 !error analysis rparm(1)=zeta !0.11102230E-13 !stopping criterion rparm(8)=tol !1.0e-8 !jcg call nspcg (jac1,basic,ndim,mdim,nor,4, !jcg & e2coef,jcoef,p,ip,eta2, !jcg & ubar,qel,wksp,iwksp,nwksp,inw,iparm,rparm,ier) if(isolver==1) then call jcg(neq,icoef,jcoef,e2coef,qel2,eta3,iwksp,nwksp,wksp,iparm,rparm,ier) else if(isolver==2) then call jsi(neq,icoef,jcoef,e2coef,qel2,eta3,iwksp,nwksp,wksp,iparm,rparm,ier) else if(isolver==3) then call ssorcg(neq,icoef,jcoef,e2coef,qel2,eta3,iwksp,nwksp,wksp,iparm,rparm,ier) else !isolver=4 call ssorsi(neq,icoef,jcoef,e2coef,qel2,eta3,iwksp,nwksp,wksp,iparm,rparm,ier) endif !... Save eta1 do i=1,np eta1(i)=eta2(i) enddo !... Re-assemble new elevations !... etatot=0 do i=1,np if(isbnd(i)>0.and.iettype(isbnd(i))/=0) then eta2(i)=elbc(i) else eta2(i)=eta3(imap(i)) endif etatot=etatot+dabs(eta2(i)) if(eta2(i)>elevmax(i)) elevmax(i)=eta2(i) enddo !i if(nscreen.eq.1) write(*,*) 'etatot=',etatot write(16,*) 'etatot=',etatot call system_clock(ien,icount_rate) btimer=real(ien-ist)/icount_rate if(nscreen.eq.1) write(*,*)'solver took',btimer,'seconds...',iparm(1),iparm(8) write(16,*)'solver took',btimer,'seconds...',iparm(1),iparm(8) ! !************************************************************************ ! * ! Momentum equations * ! * !************************************************************************ ! call system_clock(ist,icount_rate) !... Along each side !... (su2,sv2) are in global frame do j=1,ns if(idry_s(j)==1) then do k=1,nvrt su2(k,j)=0 sv2(k,j)=0 enddo !k cycle endif ! Wet sides node1=isidenode(j,1) node2=isidenode(j,2) ! Define layer thickness & diffusivities do k=kbs(j)+1,nvrt dzz(k)=zs(k,j)-zs(k-1,j) dfz(k)=(dfv(node1,k)+dfv(node2,k)+dfv(node1,k-1)+dfv(node2,k-1))/4 enddo !k ! Coefficient matrix ndim=nvrt-kbs(j) do k=kbs(j)+1,nvrt kin=k-kbs(j) !eq. # alow(kin)=0 cupp(kin)=0 bdia(kin)=0 if(kkbs(j)+1) then tmp=dt*dfz(k)/dzz(k) alow(kin)=alow(kin)+dzz(k)/6-tmp bdia(kin)=bdia(kin)+dzz(k)/3+tmp else !b.c. bdia(kin)=bdia(kin)+dt*chi(j) endif enddo !k ! RHS ! Elevation gradient, atmo. pressure and earth tidal potential deta2dx=0 deta2dy=0 deta1dx=0 deta1dy=0 icount1=0 icount2=0 dprdx=0 dprdy=0 detpdx=0 detpdy=0 icount3=0 do l=1,2 ie=is(j,l) if(ie/=0) then itmp=0 do m=1,3 nd=nm(ie,m) if(eta2(nd)+dp(nd)<=h0) itmp=1 enddo !m if(itmp==0) then !wet icount2=icount2+1 do m=1,3 deta2dx=deta2dx+eta2(nm(ie,m))*dl(ie,m,1) deta2dy=deta2dy+eta2(nm(ie,m))*dl(ie,m,2) enddo !m endif if(idry_e(ie)==0) then icount1=icount1+1 if(dpe(ie)>=tip_dp) icount3=icount3+1 do m=1,3 deta1dx=deta1dx+eta1(nm(ie,m))*dl(ie,m,1) deta1dy=deta1dy+eta1(nm(ie,m))*dl(ie,m,2) dprdx=dprdx+pr(nm(ie,m))*dl(ie,m,1) dprdy=dprdy+pr(nm(ie,m))*dl(ie,m,2) if(dpe(ie)>=tip_dp) then detpdx=detpdx+etp(nm(ie,m))*dl(ie,m,1) detpdy=detpdy+etp(nm(ie,m))*dl(ie,m,2) endif enddo !m endif endif !ie/=0 enddo !l if(icount1/=0) then deta1dx=deta1dx/icount1 deta1dy=deta1dy/icount1 dprdx=dprdx/icount1 dprdy=dprdy/icount1 endif if(icount3/=0) then detpdx=detpdx/icount3 detpdy=detpdy/icount3 endif if(icount2/=0) then deta2dx=deta2dx/icount2 deta2dy=deta2dy/icount2 endif ! b.c. to be imposed at the end do k=kbs(j)+1,nvrt kin=k-kbs(j) rrhs(kin,1)=0 rrhs(kin,2)=0 ! Elevation gradient, atmo. pressure and tidal potential if(kkbs(j)+1) then rrhs(kin,1)=rrhs(kin,1)-dzz(k)/2*dt*(g*thetai*deta2dx+g*(1-thetai)*deta1dx+dprdx/rho0-0.69*g*detpdx) rrhs(kin,2)=rrhs(kin,2)-dzz(k)/2*dt*(g*thetai*deta2dy+g*(1-thetai)*deta1dy+dprdy/rho0-0.69*g*detpdy) endif ! Coriolis, advection, wind stress, and horizontal viscosity if(kkbs(j)+1) then rrhs(kin,1)=rrhs(kin,1)+dzz(k)/6*(2*sdbt(j,k,1)+sdbt(j,k-1,1)+ & &dt*cori(j)*(2*sv2(k,j)+sv2(k-1,j))+dt*(2*d2u(k,j)+d2u(k-1,j))) rrhs(kin,2)=rrhs(kin,2)+dzz(k)/6*(2*sdbt(j,k,2)+sdbt(j,k-1,2)- & &dt*cori(j)*(2*su2(k,j)+su2(k-1,j))+dt*(2*d2v(k,j)+d2v(k-1,j))) endif ! Baroclinic if(ibc==0) then if(kkbs(j)+1) then rrhs(kin,1)=rrhs(kin,1)+dzz(k)/6*dt*(2*bcc(j,k,1)+bcc(j,k-1,1)) rrhs(kin,2)=rrhs(kin,2)+dzz(k)/6*dt*(2*bcc(j,k,2)+bcc(j,k-1,2)) endif endif !ibc==0 enddo !k call tridag(mnv,ndim,2,alow,bdia,cupp,rrhs,soln,gam) do k=kbs(j)+1,nvrt kin=k-kbs(j) ! Impose limits su2(k,j)=dmax1(-rmaxvel,dmin1(rmaxvel,soln(kin,1))) sv2(k,j)=dmax1(-rmaxvel,dmin1(rmaxvel,soln(kin,2))) enddo !k if(Cd(j)==0) then su2(kbs(j),j)=su2(kbs(j)+1,j) sv2(kbs(j),j)=sv2(kbs(j)+1,j) else !no slip bottom su2(kbs(j),j)=0 sv2(kbs(j),j)=0 endif ! Extend khh=0 !larger of the 2 element bottom indices do l=1,2 !element ie=is(j,l) if(ie/=0.and.idry_e(ie)==0.and.kbe(ie)>khh) khh=kbe(ie) enddo !l if(khh==0) then write(11,*)'Cannot find the higher bottom:',j,(is(j,l),l=1,2) stop endif if(kbs(j)>khh) then write(11,*)'Side index > elemnt:',kbs(j),khh stop endif do k=1,khh-1 su2(k,j)=0 !su2(kbs(j),j) sv2(k,j)=0 !sv2(kbs(j),j) enddo !k ! Impose b.c. do k=1,nvrt if(isbs(j)>0.and.ifltype(isbs(j))/=0) then !open bnd side ! ibnd=isbs(j) if(uth(j,k)<-98.or.vth(j,k)<-98) then write(11,*)'Wrong vel. input:',uth(j,k),vth(j,k),node1,node2 stop endif if(ifltype(isbs(j))==-1) then !Flather 1 if(eta_mean(node1)<-98.or.eta_mean(node2)<-98) then write(11,*)'Flather bnd elevation not assigned:',isbs(j) stop endif if(dps(j)<=0) then write(11,*)'Flather bnd has negative depth:',isbs(j),dps(j) stop endif vnorm=uth(j,k)*snx(j)+vth(j,k)*sny(j)+dsqrt(g/dps(j))* & &(eta2(node1)+eta2(node2)-eta_mean(node1)-eta_mean(node2))/2 su2(k,j)=vnorm*snx(j) sv2(k,j)=vnorm*sny(j) else !not Flather su2(k,j)=uth(j,k) sv2(k,j)=vth(j,k) endif !Flather or not endif !open bnd if(isbs(j)==0.and.is(j,2)==0) then !land bnd if(islip==0) then !free slip vtan=-su2(k,j)*sny(j)+sv2(k,j)*snx(j) su2(k,j)=-vtan*sny(j) sv2(k,j)=vtan*snx(j) else !no slip su2(k,j)=0 sv2(k,j)=0 endif endif enddo !k enddo !j=1,ns !... Shapiro filter (used only if indvel=0) ! use bcc as temporary variable if(indvel==0) then bcc=0 do i=1,ns if(is(i,2)==0.or.idry_s(i)==1) cycle ! Internal wet sides do k=kbs(i)+1,nvrt suru=0 surv=0 do j=1,4 id=isidenei2(i,j) if(idry_s(id)==1) then kin=k else kin=max(k,kbs(id)+1) endif suru=suru+su2(kin,id) surv=surv+sv2(kin,id) enddo !j bcc(i,k,1)=su2(k,i)+shapiro/4*(suru-4*su2(k,i)) bcc(i,k,2)=sv2(k,i)+shapiro/4*(surv-4*sv2(k,i)) enddo !k enddo !i do j=1,ns if(is(j,2)==0.or.idry_s(j)==1) cycle do k=kbs(j)+1,nvrt su2(k,j)=bcc(j,k,1) sv2(k,j)=bcc(j,k,2) enddo !k ! Extend khh=0 !larger of the 2 element bottom indices do l=1,2 !element ie=is(j,l) if(ie/=0.and.idry_e(ie)==0.and.kbe(ie)>khh) khh=kbe(ie) enddo !l if(khh==0) then write(11,*)'Cannot find the higher bottom (2):',j,(is(j,l),l=1,2) stop endif if(kbs(j)>khh) then write(11,*)'Side index > elemnt (2):',kbs(j),khh stop endif do k=1,khh-1 su2(k,j)=0 !su2(kbs(j),j) sv2(k,j)=0 !sv2(kbs(j),j) enddo !k enddo !i endif !indvel=0; Shapiro filter if(nscreen.eq.1) write(*,*)'done solving momentum eq...' write(16,*)'done solving momentum eq...' !... solve for vertical velocities !... we=0 !for dry and below bottom levels do i=1,ne if(idry_e(i)==1) cycle ! Wet elements with 3 wet nodes ! Compute upward normals and areas @ all levels n1=nm(i,1) n2=nm(i,2) n3=nm(i,3) av_bdef1=(bdef1(n1)+bdef1(n2)+bdef1(n3))/3 !average bed deformation av_bdef2=(bdef2(n1)+bdef2(n2)+bdef2(n3))/3 if(kbe(i)==0) then write(11,*)'Impossible 95' stop endif do l=kbe(i),nvrt xcon=(y(n2)-y(n1))*(z(l,n3)-z(l,n1))-(y(n3)-y(n1))*(z(l,n2)-z(l,n1)) ycon=(x(n3)-x(n1))*(z(l,n2)-z(l,n1))-(x(n2)-x(n1))*(z(l,n3)-z(l,n1)) zcon=area(i)*2 area_e(l)=dsqrt(xcon**2+ycon**2+zcon**2)/2 if(area_e(l)==0) then write(11,*)'Zero area:',i,l stop endif sne(l,1)=xcon/area_e(l)/2 sne(l,2)=ycon/area_e(l)/2 sne(l,3)=zcon/area_e(l)/2 !>0 enddo !l ! Bottom b.c. ! Error: only we=0 ! dhdx=dp(n1)*dl(i,1,1)+dp(n2)*dl(i,2,1)+dp(n3)*dl(i,3,1) ! dhdy=dp(n1)*dl(i,1,2)+dp(n2)*dl(i,2,2)+dp(n3)*dl(i,3,2) ! ubar=(su2(1,js(i,1))+su2(1,js(i,2))+su2(1,js(i,3)))/3 ! vbar=(sv2(1,js(i,1))+sv2(1,js(i,2))+sv2(1,js(i,3)))/3 we(kbe(i),i)=(av_bdef2-av_bdef1)/dt !-dhdx*ubar-dhdy*vbar do l=kbe(i),nvrt-1 sum=0 ubar=0 vbar=0 ubar1=0 vbar1=0 do j=1,3 jsj=js(i,j) vnor1=su2(l,jsj)*snx(jsj)+sv2(l,jsj)*sny(jsj) vnor2=su2(l+1,jsj)*snx(jsj)+sv2(l+1,jsj)*sny(jsj) if(lkbb) then tmp=dt*dfz(k)/dzz(k) alow(kin)=alow(kin)-tmp bdia(kin)=bdia(kin)+dzz(k)/2+tmp endif enddo !k ! RHS ! b.c. to be imposed at the end do k=kbb,nvrt kin=k-kbb+1 rrhs(kin,1)=0 rrhs(kin,2)=0 if(kkbb) then if(l==1) then rrhs(kin,1)=rrhs(kin,1)+dzz(k)/2*ptbt(nd0,k,3) rrhs(kin,2)=rrhs(kin,2)+dzz(k)/2*ptbt(nd0,k,4) else rrhs(kin,1)=rrhs(kin,1)+dzz(k)/2*sdbt(isd0,k,3) rrhs(kin,2)=rrhs(kin,2)+dzz(k)/2*sdbt(isd0,k,4) endif ! else if(ihconsv/=0) then !bottom solar ! if(l==1) then ! htot=dmin1(1.d2,eta1(nd0)+dp(nd0)) !to prevent underflow ! if(htot<=h0) then ! write(11,*)'Total depth (1) < 0:',htot ! stop ! endif ! rrhs(k,1)=rrhs(k,1)-dt/rho0/shw*srad(nd0)*(0.8*dexp(-htot/0.9)+0.2*dexp(-htot/2.1)) ! else ! htot=dmin1(1.d2,(eta1(node1)+eta1(node2))/2+dps(isd0)) ! if(htot<=h0) then ! write(11,*)'Total depth (2) < 0:',htot ! stop ! endif ! rrhs(k,1)=rrhs(k,1)-dt/rho0/shw*(srad(node1)+srad(node2))/2*(0.8*dexp(-htot/0.9)+0.2*dexp(-htot/2.1)) ! endif endif ! Compute fucntion F() for heat exchange ! if(ihconsv/=0) then !solar ! if(l==1) then ! zz1=dmax1(-1.d2,z(k,nd0)-eta1(nd0)) ! if(zz1>0) then ! write(11,*)'Above f.s.:',zz1 ! stop ! endif ! rrhs(k,5)=srad(nd0)*(0.8*0.9*dexp(zz1/0.9)+0.2*2.1*dexp(zz1/2.1)) !F() ! else ! zz1=dmax1(-1.d2,zs(k,isd0)-(eta1(node1)+eta1(node2))/2) !! Error: turn ifort12(16) back on after debugging ! if(zz1>0) then !.and.ifort12(16)==0) then ! ifort12(16)=1 ! write(12,*)'Above f.s. (2):',l,i,k,zz1 ! endif ! zz1=dmin1(0.d0,zz1) ! rrhs(k,5)=(srad(node1)+srad(node2))/2*(0.8*0.9*dexp(zz1/0.9)+0.2*2.1*dexp(zz1/2.1)) ! endif ! endif !solar enddo !k=1,nvrt ! Solar ! if(ihconsv/=0) then ! do k=1,nvrt ! if(k1) rrhs(k,1)=rrhs(k,1)-dt/rho0/shw*(rrhs(k,5)-rrhs(k-1,5))/dzz(k) ! enddo !k ! endif call tridag(mnv,ndim,2,alow,bdia,cupp,rrhs,soln,gam) ! Impose no flux condition at bottom B.L. for slipless bottom if(l==1.and.Cdp(nd0)/=0.or.l==2.and.Cd(isd0)/=0) soln(1,1:2)=soln(2,1:2) ! Correct overshoots for S,T ! Debug ! if(l==1.and.i==23) then ! write(98,*)totalflux ! do k=1,nvrt ! write(98,*)k,soln(k,1),ptbt(nd0,k,3),rrhs(k,5),rrhs(k,4)*dt ! enddo ! endif tmin=100; tmax=-100 smin=100; smax=-100 do k=kbb,nvrt if(l==1) then if(tmin>ptbt(nd0,k,3)) tmin=ptbt(nd0,k,3) if(tmaxptbt(nd0,k,4)) smin=ptbt(nd0,k,4) if(smaxsdbt(isd0,k,3)) tmin=sdbt(isd0,k,3) if(tmaxsdbt(isd0,k,4)) smin=sdbt(isd0,k,4) if(smaxtmax.or.tmin<0.or.smin>smax.or.smin<0) then ! write(11,*)'Illegal min/max:',tmin,tmax,smin,smax,l,i ! stop ! endif ! Store S,T in swild2 temporarily do k=kbb,nvrt kin=k-kbb+1 swild2(k,1:2)=soln(kin,1:2) ! if(ihconsv/=0) swild2(k,1)=dmax1(tempmin,dmin1(tempmax,soln(kin,1))) ! if(isconsv/=0) swild2(k,2)=dmax1(saltmin,dmin1(saltmax,soln(kin,2))) enddo !k ! Impose b.c. on bnd nodes & sides if(l==1) then !nodes if(isbnd(nd0)>0) then ibnd=isbnd(nd0) ind=0 do ll=1,nond(ibnd) ndo=iond(ibnd,ll) if(ndo==nd0) then ind=ll exit endif enddo !ll if(ind==0) then write(11,*)'Impossible 101' stop endif isd=0 !flag do ll=1,2 !side if(ll==1) then ie=ine(nd0,1) id=iself(nd0,1) isd3=js(ie,nx(id,2)) else ie=ine(nd0,nne(nd0)) id=iself(nd0,nne(nd0)) isd3=js(ie,nx(id,1)) endif if(isbs(isd3)==ibnd) then isd=isd3 exit endif enddo !ll if(isd==0) then write(11,*)'Cannot find an open side:',nd0 stop endif do k=1,nvrt if(itetype(ibnd)==1.or.itetype(ibnd)==2) then swild2(k,1)=tth(ibnd,1,1) else if(itetype(ibnd)==3) then swild2(k,1)=tem0(k,nd0) else if(itetype(ibnd)==4) then swild2(k,1)=tth(ibnd,ind,k) else if(itetype(ibnd)==-4) then vnn=su2(k,isd)*snx(isd)+sv2(k,isd)*sny(isd) if(vnn<0) swild2(k,1)=tobc(ibnd)*tth(ibnd,ind,k)+(1-tobc(ibnd))*swild2(k,1) else if(itetype(ibnd)==-1) then vnn=su2(k,isd)*snx(isd)+sv2(k,isd)*sny(isd) if(vnn<0) swild2(k,1)=tobc(ibnd)*tem0(k,nd0)+(1-tobc(ibnd))*swild2(k,1) endif if(isatype(ibnd)==1.or.isatype(ibnd)==2) then swild2(k,2)=sth(ibnd,1,1) else if(isatype(ibnd)==3) then swild2(k,2)=sal0(k,nd0) else if(isatype(ibnd)==4) then swild2(k,2)=sth(ibnd,ind,k) else if(isatype(ibnd)==-4) then vnn=su2(k,isd)*snx(isd)+sv2(k,isd)*sny(isd) if(vnn<0) swild2(k,2)=sobc(ibnd)*sth(ibnd,ind,k)+(1-sobc(ibnd))*swild2(k,2) else if(isatype(ibnd)==-1) then vnn=su2(k,isd)*snx(isd)+sv2(k,isd)*sny(isd) if(vnn<0) swild2(k,2)=sobc(ibnd)*sal0(k,nd0)+(1-sobc(ibnd))*swild2(k,2) endif enddo !k endif !isbnd>0 else !sides if(isbs(isd0)>0) then ibnd=isbs(isd0) in1=0; in2=0 do ll=1,nond(ibnd) ndo=iond(ibnd,ll) if(ndo==node1) in1=ll if(ndo==node2) in2=ll if(in1/=0.and.in2/=0) exit enddo !ll if(in1==0.or.in2==0) then write(11,*)'Impossible 102' stop endif do k=1,nvrt if(itetype(ibnd)==1.or.itetype(ibnd)==2) then swild2(k,1)=tth(ibnd,1,1) else if(itetype(ibnd)==3) then swild2(k,1)=(tem0(k,node1)+tem0(k,node2))/2 else if(itetype(ibnd)==4) then swild2(k,1)=(tth(ibnd,in1,k)+tth(ibnd,in2,k))/2 else if(itetype(ibnd)==-4) then vnn=su2(k,isd0)*snx(isd0)+sv2(k,isd0)*sny(isd0) if(vnn<0) swild2(k,1)=tobc(ibnd)*(tth(ibnd,in1,k)+tth(ibnd,in2,k))/2+(1-tobc(ibnd))*swild2(k,1) else if(itetype(ibnd)==-1) then vnn=su2(k,isd0)*snx(isd0)+sv2(k,isd0)*sny(isd0) if(vnn<0) swild2(k,1)=tobc(ibnd)*(tem0(k,node1)+tem0(k,node2))/2+(1-tobc(ibnd))*swild2(k,1) endif if(isatype(ibnd)==1.or.isatype(ibnd)==2) then swild2(k,2)=sth(ibnd,1,1) else if(isatype(ibnd)==3) then swild2(k,2)=(sal0(k,node1)+sal0(k,node2))/2 else if(isatype(ibnd)==4) then swild2(k,2)=(sth(ibnd,in1,k)+sth(ibnd,in2,k))/2 else if(isatype(ibnd)==-4) then vnn=su2(k,isd0)*snx(isd0)+sv2(k,isd0)*sny(isd0) if(vnn<0) swild2(k,2)=sobc(ibnd)*(sth(ibnd,in1,k)+sth(ibnd,in2,k))/2+(1-sobc(ibnd))*swild2(k,2) else if(isatype(ibnd)==-1) then vnn=su2(k,isd0)*snx(isd0)+sv2(k,isd0)*sny(isd0) if(vnn<0) swild2(k,2)=sobc(ibnd)*(sal0(k,node1)+sal0(k,node2))/2+(1-sobc(ibnd))*swild2(k,2) endif enddo !k endif !isbs(isd0)>0 endif ! Nudging if(inu_st/=0) then do k=kbb,nvrt if(l==1) then !nodes if(z(k,nd0)>=-vnh1) then vnf=vnf1 !vertical nudging factor else if(z(k,nd0)>=-vnh2) then vnf=vnf1+(vnf2-vnf1)*(z(k,nd0)+vnh1)/(-vnh2+vnh1) else vnf=vnf2 endif tnu=t_nudge(nd0)+vnf snu=s_nudge(nd0)+vnf if(tnu<0.or.tnu>1.or.snu<0.or.snu>1.or.vnf<0.or.vnf>1) then write(11,*)'Nudging factor out of bound (1):',tnu,snu,vnf stop endif if(inu_st==1) then !to i.c. swild2(k,1)=swild2(k,1)*(1-tnu)+tem0(k,nd0)*tnu swild2(k,2)=swild2(k,2)*(1-snu)+sal0(k,nd0)*snu else if(inu_st==2) then swild2(k,1)=swild2(k,1)*(1-tnu)+tnd_nu(nd0,k)*tnu swild2(k,2)=swild2(k,2)*(1-snu)+snd_nu(nd0,k)*snu endif else !sides if(zs(k,isd0)>=-vnh1) then vnf=vnf1 !vertical nudging factor else if(zs(k,isd0)>=-vnh2) then vnf=vnf1+(vnf2-vnf1)*(zs(k,isd0)+vnh1)/(-vnh2+vnh1) else vnf=vnf2 endif tnu=(t_nudge(node1)+t_nudge(node2))/2+vnf snu=(s_nudge(node1)+s_nudge(node2))/2+vnf if(tnu<0.or.tnu>1.or.snu<0.or.snu>1.or.vnf<0.or.vnf>1) then write(11,*)'Nudging factor out of bound (2):',tnu,snu,vnf stop endif if(inu_st==1) then !to i.c. swild2(k,1)=swild2(k,1)*(1-tnu)+(tem0(k,node1)+tem0(k,node2))/2*tnu swild2(k,2)=swild2(k,2)*(1-snu)+(sal0(k,node1)+sal0(k,node2))/2*snu else if(inu_st==2) then swild2(k,1)=swild2(k,1)*(1-tnu)+(tnd_nu(node1,k)+tnd_nu(node2,k))/2*tnu swild2(k,2)=swild2(k,2)*(1-snu)+(snd_nu(node1,k)+snd_nu(node2,k))/2*snu endif endif enddo !k endif !nudging ! Extend do k=1,kbb-1 swild2(k,1)=swild2(kbb,1) swild2(k,2)=swild2(kbb,2) enddo !k ! Check bounds ! Error: compute initial min. max, and check against them do k=1,nvrt if(swild2(k,1)<-98.or.swild2(k,2)<-98) then write(11,*)'Werid ST (1):',l,i,k,swild2(k,1),swild2(k,2) stop endif enddo !k ! Output S,T do k=1,nvrt if(iupwind_t==0) then if(l==1) then tnd(k,nd0)=swild2(k,1) else tsd(k,isd0)=swild2(k,1) endif endif !iupwind_t if(iupwind_s==0) then if(l==1) then snd(k,nd0)=swild2(k,2) else ssd(k,isd0)=swild2(k,2) endif endif !iupwind_s enddo !k enddo !i=1,limit enddo !l=1,2 !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ endif ! end of ELM option !************************************************************************************* ! ! Upwind and TVD option ! !************************************************************************************* if(iupwind_t/=0.or.iupwind_s/=0) then ! b.c. and body forces bdy_frc=0; flx_sf=0; flx_bt=0 if(ihconsv/=0) then do i=1,ne if(idry_e(i)==1) cycle ! Wet element n1=nm(i,1) n2=nm(i,2) n3=nm(i,3) ! Surface flux sflux_e=(sflux(n1)+sflux(n2)+sflux(n3))/3 flx_sf(i,1)=sflux_e/rho0/shw ! Solar do k=kbe(i)+1,nvrt srad_e=(srad(n1)+srad(n2)+srad(n3))/3 ! Don't use eta2 as it has been updated but not z() ! elv_e=(eta2(n1)+eta2(n2)+eta2(n3))/3 dp1=dmin1(ze(nvrt,i)-ze(k-1,i),1.d2) !to prevent underflow dp2=dmin1(ze(nvrt,i)-ze(k,i),1.d2) !to prevent underflow if(dp2<0.or.dp2>dp1) then write(11,*)'Depth<0 in upwind transport:',i,k,dp1,dp2 write(11,*)eta2(n1),eta2(n2),eta2(n3),ze(nvrt,i) do l=kbe(i),nvrt write(11,*)l,z(l,n1),z(l,n2),z(l,n3) enddo !l stop endif if(k==kbe(i)+1) then srad1=0 else srad1=srad_e*(0.8*dexp(-dp1/0.9)+0.2*dexp(-dp1/2.1)) endif srad2=srad_e*(0.8*dexp(-dp2/0.9)+0.2*dexp(-dp2/2.1)) if(srad20) then ibnd=isbs(isd) isd00=isd exit !first open bnd counts endif enddo !j if(ibnd>0) then !open bnd node1=isidenode(isd00,1) node2=isidenode(isd00,2) ind1=0; ind2=0 do ll=1,nond(ibnd) ndo=iond(ibnd,ll) if(ndo==node1) ind1=ll if(ndo==node2) ind2=ll enddo !ll if(ind1==0.or.ind2==0) then write(11,*)'Cannot find a local index' stop endif do k=kbe(i)+1,nvrt tsel01=(tem0(k,n1)+tem0(k,n2)+tem0(k,n3)+tem0(k-1,n1)+tem0(k-1,n2)+tem0(k-1,n3))/6 tsel02=(sal0(k,n1)+sal0(k,n2)+sal0(k,n3)+sal0(k-1,n1)+sal0(k-1,n2)+sal0(k-1,n3))/6 if(itetype(ibnd)==1.or.itetype(ibnd)==2) then tsel(k,i,1)=tth(ibnd,1,1) else if(itetype(ibnd)==3) then tsel(k,i,1)=tsel01 else if(iabs(itetype(ibnd))==4) then tmp=(tth(ibnd,ind1,k)+tth(ibnd,ind1,k-1)+tth(ibnd,ind2,k)+tth(ibnd,ind2,k-1))/4 if(itetype(ibnd)==4) then tsel(k,i,1)=tmp else vnn=su2(k,isd00)*snx(isd00)+sv2(k,isd00)*sny(isd00) if(vnn<0) tsel(k,i,1)=tobc(ibnd)*tmp+(1-tobc(ibnd))*tsel(k,i,1) endif else if(itetype(ibnd)==-1) then vnn=su2(k,isd00)*snx(isd00)+sv2(k,isd00)*sny(isd00) if(vnn<0) tsel(k,i,1)=tobc(ibnd)*tsel01+(1-tobc(ibnd))*tsel(k,i,1) endif if(isatype(ibnd)==1.or.isatype(ibnd)==2) then tsel(k,i,2)=sth(ibnd,1,1) else if(isatype(ibnd)==3) then tsel(k,i,2)=tsel02 else if(iabs(isatype(ibnd))==4) then tmp=(sth(ibnd,ind1,k)+sth(ibnd,ind1,k-1)+sth(ibnd,ind2,k)+sth(ibnd,ind2,k-1))/4 if(isatype(ibnd)==4) then tsel(k,i,2)=tmp else vnn=su2(k,isd00)*snx(isd00)+sv2(k,isd00)*sny(isd00) if(vnn<0) tsel(k,i,2)=sobc(ibnd)*tmp+(1-sobc(ibnd))*tsel(k,i,2) endif else if(isatype(ibnd)==-1) then vnn=su2(k,isd00)*snx(isd00)+sv2(k,isd00)*sny(isd00) if(vnn<0) tsel(k,i,2)=sobc(ibnd)*tsel02+(1-sobc(ibnd))*tsel(k,i,2) endif enddo !k endif !open bnd if(inu_st/=0) then do k=kbe(i)+1,nvrt if(ze(k,i)>=-vnh1) then vnf=vnf1 !vertical nudging factor else if(ze(k,i)>=-vnh2) then vnf=vnf1+(vnf2-vnf1)*(ze(k,i)+vnh1)/(-vnh2+vnh1) else vnf=vnf2 endif tnu=(t_nudge(n1)+t_nudge(n2)+t_nudge(n3))/3+vnf snu=(s_nudge(n1)+s_nudge(n2)+s_nudge(n3))/3+vnf if(tnu<0.or.tnu>1.or.snu<0.or.snu>1.or.vnf<0.or.vnf>1) then write(11,*)'Nudging factor out of bound (1):',tnu,snu,vnf stop endif if(inu_st==1) then !to i.c. tsel01=(tem0(k,n1)+tem0(k,n2)+tem0(k,n3)+tem0(k-1,n1)+tem0(k-1,n2)+tem0(k-1,n3))/6 tsel02=(sal0(k,n1)+sal0(k,n2)+sal0(k,n3)+sal0(k-1,n1)+sal0(k-1,n2)+sal0(k-1,n3))/6 tsel(k,i,1)=tsel(k,i,1)*(1-tnu)+tsel01*tnu tsel(k,i,2)=tsel(k,i,2)*(1-snu)+tsel02*snu else if(inu_st==2) then tnd_nu_e=(tnd_nu(n1,k)+tnd_nu(n2,k)+tnd_nu(n3,k)+tnd_nu(n1,k-1)+tnd_nu(n2,k-1)+tnd_nu(n3,k-1))/6 snd_nu_e=(snd_nu(n1,k)+snd_nu(n2,k)+snd_nu(n3,k)+snd_nu(n1,k-1)+snd_nu(n2,k-1)+snd_nu(n3,k-1))/6 tsel(k,i,1)=tsel(k,i,1)*(1-tnu)+tnd_nu_e*tnu tsel(k,i,2)=tsel(k,i,2)*(1-snu)+snd_nu_e*snu endif enddo !k endif !inu_st/=0 ! Extend do k=1,kbe(i) tsel(k,i,1:2)=tsel(kbe(i)+1,i,1:2) enddo !k enddo !i=1,ne ! Convert to S,T at nodes and sides and whole levels ! Use hp_int to temporarily store values at elements and whole levels do i=1,ne if(idry_e(i)==1) cycle do k=kbe(i)+1,nvrt-1 zrat=(ze(k+1,i)-ze(k,i))/(ze(k+1,i)-ze(k-1,i)) if(zrat<=0.or.zrat>=1) then write(11,*)'Ratio out of bound:',i,k,zrat stop endif hp_int(k,i,1:2)=(1-zrat)*tsel(k+1,i,1:2)+zrat*tsel(k,i,1:2) enddo !k hp_int(nvrt,i,1:2)=tsel(nvrt,i,1:2) hp_int(kbe(i),i,1:2)=tsel(kbe(i)+1,i,1:2) enddo !i=1,ne do i=1,np if(idry(i)==1) cycle do k=1,nvrt tt1=0; ss1=0 ta=0 do j=1,nne(i) ie=ine(i,j) if(idry_e(ie)==0) then ta=ta+area(ie) kin=max0(k,kbe(ie)) tt1=tt1+hp_int(kin,ie,1)*area(ie) ss1=ss1+hp_int(kin,ie,2)*area(ie) endif enddo !j if(ta==0) then !from levels(), a node is wet if and only if at least one surrounding element is wet write(11,*)'Isolated wet node (9):',i stop else if(iupwind_t/=0) tnd(k,i)=tt1/ta if(iupwind_s/=0) snd(k,i)=ss1/ta endif enddo !k enddo !i=1,np do i=1,ns if(idry_s(i)==1) cycle do k=1,nvrt tt1=0; ss1=0 ta=0 do j=1,2 ie=is(i,j) if(ie/=0.and.idry_e(ie)==0) then ta=ta+area(ie) kin=max0(k,kbe(ie)) tt1=tt1+hp_int(kin,ie,1)*area(ie) ss1=ss1+hp_int(kin,ie,2)*area(ie) endif enddo !j if(ta==0) then write(11,*)'Isolated wet side (9):',i,(is(i,j),j=1,2) stop else if(iupwind_t/=0) tsd(k,i)=tt1/ta if(iupwind_s/=0) ssd(k,i)=ss1/ta endif enddo !k enddo !i=1,ns !... Compute total mass of S,T !... open(91,file='total_ST.dat') tot_heat=0 tot_salt=0 do i=1,ne if(idry_e(i)==1) cycle do k=kbe(i)+1,nvrt vol=(ze(k,i)-ze(k-1,i))*area(i) tot_heat=tot_heat+vol*tsel(k,i,1) tot_salt=tot_salt+vol*tsel(k,i,2) enddo !k enddo !i=1,ne write(91,*)time/86400,tot_heat,tot_salt endif !upwind if(nscreen==1) write(*,*)'done solving transport equation' write(16,*)'done solving transport equation' !---------------------------------------------------------------------- endif !ibc.eq.0.or.ibtp.eq.1 !... Tracer transport if(ntracers>0) then ! user-defined tracer part ! define bdy_frc, flx_sf, flx_bt ! bdy_frc(kbe(i)+1:nvrt,1:ne,ntracers): body force at prism center Q_{i,k} (for all wet elements i) ! flx_sf(mne,mntr): surface b.c. \kappa*dC/dz = flx_sf (at element center) ! flx_bt(mne,mntr): bottom b.c. ! bdy_frc=0; flx_sf=0; flx_bt=0 rkk1=log(10.)/3/3600 rkk2=log(10.)/30/3600 flx_sf=0; flx_bt=0 bdy_frc(1:nvrt,1:ne,1)=-rkk1*trel(1:nvrt,1:ne,1) bdy_frc(1:nvrt,1:ne,2)=-rkk2*trel(1:nvrt,1:ne,2)+0.5*rkk1*trel(1:nvrt,1:ne,1) ! end user-defined tracer part up_tvd=itr_met==2 tr_el(1:mnv,1:mne,1:ntracers)=trel(1:mnv,1:mne,1:ntracers) call do_transport_tvd(1,up_tvd,tvd_mid2,flimiter2,ntracers) trel(1:mnv,1:mne,1:ntracers)=tr_el(1:mnv,1:mne,1:ntracers) ! Impose b.c. do i=1,ne if(idry_e(i)==1) cycle n1=nm(i,1) n2=nm(i,2) n3=nm(i,3) ibnd=0 !flag do j=1,3 isd=js(i,j) if(isbs(isd)>0) then ibnd=isbs(isd) isd00=isd exit !first open bnd counts endif enddo !j if(ibnd>0) then !open bnd node1=isidenode(isd00,1) node2=isidenode(isd00,2) ind1=0; ind2=0 do ll=1,nond(ibnd) ndo=iond(ibnd,ll) if(ndo==node1) ind1=ll if(ndo==node2) ind2=ll enddo !ll if(ind1==0.or.ind2==0) then write(11,*)'Cannot find a local index' stop endif do k=kbe(i)+1,nvrt if(itrtype(ibnd)==2) then trel(k,i,1:ntracers)=trth(ibnd,1:ntracers) else if(itrtype(ibnd)==3) then trel(k,i,1:ntracers)=trel0(k,i,1:ntracers) endif enddo !k endif !open bnd ! Extend do k=1,kbe(i) trel(k,i,1:ntracers)=trel(kbe(i)+1,i,1:ntracers) enddo !k enddo !i=1,ne ! Convert to S,T at nodes and sides and whole levels ! Use tr_el to temporarily store values at elements and whole levels do i=1,ne if(idry_e(i)==1) cycle do k=kbe(i)+1,nvrt-1 zrat=(ze(k+1,i)-ze(k,i))/(ze(k+1,i)-ze(k-1,i)) if(zrat<=0.or.zrat>=1) then write(11,*)'Ratio out of bound:',i,k,zrat stop endif tr_el(k,i,1:ntracers)=(1-zrat)*trel(k+1,i,1:ntracers)+zrat*trel(k,i,1:ntracers) enddo !k tr_el(nvrt,i,1:ntracers)=trel(nvrt,i,1:ntracers) tr_el(kbe(i),i,1:ntracers)=trel(kbe(i)+1,i,1:ntracers) enddo !i=1,ne tr_nd=-99 !for dry nodes do i=1,np if(idry(i)==1) cycle do k=1,nvrt swild(1:ntracers)=0 ta=0 do j=1,nne(i) ie=ine(i,j) if(idry_e(ie)==0) then ta=ta+area(ie) kin=max0(k,kbe(ie)) swild(1:ntracers)=swild(1:ntracers)+tr_el(kin,ie,1:ntracers)*area(ie) endif enddo !j if(ta==0) then !from levels(), a node is wet if and only if at least one surrounding element is wet write(11,*)'Isolated wet node (9):',i stop else tr_nd(k,i,1:ntracers)=swild(1:ntracers)/ta endif enddo !k enddo !i=1,np !... Compute total mass !... open(92,file='total_TR.dat') swild(1:ntracers)=0 do i=1,ne if(idry_e(i)==1) cycle do k=kbe(i)+1,nvrt vol=(ze(k,i)-ze(k-1,i))*area(i) swild(1:ntracers)=swild(1:ntracers)+vol*trel(k,i,1:ntracers) enddo !k enddo !i=1,ne write(92,*)time/86400,swild(1:ntracers) endif !... End of tracer transport !... Update bed deformation and depth info do i=1,np bdef1(i)=bdef2(i) dp(i)=dp00(i)-bdef1(i) hmod(i)=dmin1(dp(i),h_s) enddo !i do i=1,ns n1=isidenode(i,1) n2=isidenode(i,2) dps(i)=(dp(n1)+dp(n2))/2 enddo !i do i=1,ne dpe(i)=1.e10 do j=1,3 if(dpe(i)>dp(nm(i,j))) dpe(i)=dp(nm(i,j)) enddo !j enddo !i=1,ne !... Recompute vgrid and calculate rewetted pts if(inunfl==0) then call levels0(iths,it) else call levels1(iths,it) endif if(nscreen.eq.1) write(*,*) 'done recomputing levels...' write(16,*) 'done recomputing levels...' !... Compute nodal vel. for output and next backtracking call nodalvel(ifltype) !... Density (using new level indices) call eqstate call system_clock(ien,icount_rate) btimer=real(ien-ist)/icount_rate if(nscreen.eq.1) write(*,*)'transport eqs. took',btimer,'sec' write(16,*)'transport eqs. took',btimer,'sec' !... Compute depth averaged h-vel. !... dav=0 do i=1,np if(idry(i)==1) cycle do k=kbp(i),nvrt-1 dav(i,1)=dav(i,1)+(uu2(k+1,i)+uu2(k,i))/2*(z(k+1,i)-z(k,i)) dav(i,2)=dav(i,2)+(vv2(k+1,i)+vv2(k,i))/2*(z(k+1,i)-z(k,i)) enddo !k htot=eta2(i)+dp(i) if(htot<=h0) then write(11,*)'Impossible 24' stop endif dav(i,1)=dav(i,1)/htot dav(i,2)=dav(i,2)/htot enddo !i=1,np !... Optional computation of fluxes and total volume etc. if(iflux/=0) then !-------------------------------------------------- ! Compute total mass etc. tvol=0 !total volume tmass=0 !total mass tpe=0 !total potential energy tkne=0 !total kinetic energy (2D only) enerf=0 !energy loss due to bottom friction; only correct for 2D model ener_ob=0 !total wave enery out of open bnds; only correct for 0 mean flows! do i=1,ne if(idry_e(i)==1) cycle n1=nm(i,1) n2=nm(i,2) n3=nm(i,3) etam=(eta2(n1)+eta2(n2)+eta2(n3))/3 tpe=tpe+0.5*rho0*g*area(i)*etam**2 av_dep=etam+(dp(n1)+dp(n2)+dp(n3))/3 tvol=tvol+area(i)*av_dep do k=kbe(i),nvrt-1 ah=(z(k+1,n1)+z(k+1,n2)+z(k+1,n3)-z(k,n1)-z(k,n2)-z(k,n3))/3 enddo !j do j=1,3 nd=nm(i,j) do k=kbp(nd),nvrt-1 tmass=tmass+area(i)*(prho(nd,k)+prho(nd,k+1))*(z(k+1,nd)-z(k,nd))/6 enddo !k htot=eta2(nd)+dp(nd) if(htot<=h0) then write(11,*)'Impossible dry (9):',i,j,nd,htot stop endif isd=js(i,j) do k=kbs(isd),nvrt-1 vmag1=su2(k,isd)**2+sv2(k,isd)**2 vmag2=su2(k+1,isd)**2+sv2(k+1,isd)**2 tkne=tkne+rho0*area(i)/6*(zs(k+1,isd)-zs(k,isd))*(vmag1+vmag2)/2 enddo !k ! enerf only correct for 2D model enerf=enerf+dt*area(i)/3*rho0*Cdp(nd)*dsqrt(dav(nd,1)**2+dav(nd,2)**2)**3 ! ener_ob isd=js(i,j) if(isbs(isd)>0) then !open bnd n1=isidenode(isd,1) n2=isidenode(isd,2) eta_m=(eta2(n1)+eta2(n2))/2 vel_m1=(dav(n1,1)+dav(n2,1))/2 vel_m2=(dav(n1,2)+dav(n2,2))/2 ener_ob=ener_ob+rho0/2*dsqrt(g*dps(isd))*dt*(g*eta_m**2+dps(isd)*(vel_m1**2+vel_m2**2))*distj(isd) endif enddo !j=1,3 enddo !i=1,ne write(10,*)time/3600,tvol,tmass,tpe,tkne,tpe+tkne,enerf,ener_ob ! Fluxes open(13,file='fluxflag.gr3',status='old') read(13,*) read(13,*)ntmp,npflag if(npflag/=np) then write(11,*)'# of pts in fluxflag should = np' stop endif do i=1,np read(13,*)j,xtmp,ytmp,wild nwild2(i)=wild enddo close(13) do i=1,ne nwild(i)=0 do j=1,3 nd=nm(i,j) if(nwild(i)=1' stop endif if(nc.gt.100) then write(11,*)'Increase # of columns in tridag' stop endif if(b(1).eq.0.) then write(11,*)'tridag: b(1)=0' stop endif bet=b(1) do i=1,nc u(1,i)=r(1,i)/bet enddo do j=2,n gam(j)=c(j-1)/bet bet=b(j)-a(j)*gam(j) if(bet.eq.0) then write(11,*)'tridag failed' stop endif do i=1,nc u(j,i)=(r(j,i)-a(j)*u(j-1,i))/bet enddo !i enddo !j ! Backsubstitution do j=n-1,1,-1 do i=1,nc u(j,i)=u(j,i)-gam(j+1)*u(j+1,i) enddo enddo return end ! !******************************************************************** ! ! Routine to update z-coordinates and wetting and drying ! Use levels1() for better inundation if resolution is fine enough. ! !******************************************************************** ! subroutine levels0(iths,it) use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) integer, intent(in) :: iths,it dimension idry_new(mnp),idry_s_new(mns),out2(12+mnv) !... z-coor. for nodes !... do i=1,np if(dp(i)+eta2(i)<=h0) then !dry idry_new(i)=1 if(dp(i)>=h_s) then write(11,*)'Deep depth dry:',i stop endif kbp(i)=0 else !wet idry_new(i)=0 ! S-levels do k=kz,nvrt kin=k-kz+1 if(hmod(i)<=h_c) then if(ifort12(12)==0) then ifort12(12)=1 write(12,*)'Initial depth too shallow for S:',i,hmod(i),h_c endif iback(i)=1 z(k,i)=sigma(kin)*(hmod(i)+eta2(i))+eta2(i) else if(eta2(i)<=-h_c-(hmod(i)-h_c)*theta_f/s_con1) then !hmod(i)>h_c>=0 write(11,*)'Pls choose a larger h_c (1):',eta2(i),h_c stop else z(k,i)=eta2(i)*(1+sigma(kin))+h_c*sigma(kin)+(hmod(i)-h_c)*cs(kin) endif enddo !k=kz,nvrt ! z-levels if(dp(i)<=h_s) then kbp(i)=kz else !bottom index if(imm==1) then kbp(i)=0 !flag do k=1,kz-1 if(-dp(i)>=ztot(k).and.-dp(i)=kz.or.kbp(i)<1) then write(11,*)'Impossible 92:',kbp(i),kz,i stop endif z(kbp(i),i)=-dp(i) do k=kbp(i)+1,kz-1 z(k,i)=ztot(k) enddo !k endif do k=kbp(i)+1,nvrt if(z(k,i)-z(k-1,i)<=0) then write(11,*)'Inverted z-levels at:',i,k,z(k,i)-z(k-1,i),eta2(i),hmod(i) stop endif enddo !k endif !wet ot dry enddo !i=1,np !... Set wet/dry flags for element; element is "dry" if one of nodes is dry; conversely, !... an element is wet if all nodes are wet (and all sides are wet as well) !... Weed out fake wet nodes; a node is wet if and only if at least one surrounding element is wet !... if(it/=iths) idry_e0=idry_e !save only for upwindtrack() idry_s_new(1:np)=idry(1:np) !temporary save idry=1 !dry unless wet kbe=0 do i=1,ne n1=nm(i,1) n2=nm(i,2) n3=nm(i,3) idry_e(i)=max0(idry_new(n1),idry_new(n2),idry_new(n3)) if(idry_e(i)==0) then idry(n1)=0; idry(n2)=0; idry(n3)=0 kbe(i)=max0(kbp(n1),kbp(n2),kbp(n3)) do k=kbe(i),nvrt ze(k,i)=(z(k,n1)+z(k,n2)+z(k,n3))/3 if(k>=kbe(i)+1.and.ze(k,i)-ze(k-1,i)<=0) then write(11,*)'Weird element:' write(11,*)k,i,ze(k,i),ze(k-1,i) stop endif enddo !k endif enddo !i ! Compute vel., S,T for re-wetted nodes (q2 and xl are fine) ! Vel. as average; back-up S,T do i=1,np if(it/=iths.and.idry_s_new(i)==1.and.idry(i)==0) then do k=1,nvrt uu2(k,i)=0 vv2(k,i)=0 tnd(k,i)=0 snd(k,i)=0 icount=0 do j=1,nnp(i) nd=inp(i,j) if(idry_s_new(nd)==0) then !all indices extended icount=icount+1 uu2(k,i)=uu2(k,i)+uu2(k,nd) vv2(k,i)=vv2(k,i)+vv2(k,nd) tnd(k,i)=tnd(k,i)+tnd(k,nd) snd(k,i)=snd(k,i)+snd(k,nd) endif enddo !j if(icount==0) then if(ifort12(7)==0) then ifort12(7)=1 write(12,*)'Isolated rewetted node:',i endif tnd(k,i)=tem0(k,i) snd(k,i)=sal0(k,i) else uu2(k,i)=uu2(k,i)/icount vv2(k,i)=vv2(k,i)/icount tnd(k,i)=tnd(k,i)/icount snd(k,i)=snd(k,i)/icount endif enddo !k=1,nvrt endif !rewetted enddo !i=1,np do i=1,np if(it/=iths.and.idry_s_new(i)==1.and.idry(i)==0) then do k=kbp(i),nvrt x0=x(i) y0=y(i) uuint=uu2(k,i) vvint=vv2(k,i) vmag=dsqrt(uuint**2+vvint**2) nnel=ine(i,1) !any element jlev=k if(idry_e0(nnel)==0) then write(11,*)'Starting element must be dry' stop endif if(vmag/=0) then uuint=uuint/vmag vvint=vvint/vmag call upwindtrack(i,jlev,nnel,x0,y0,uuint,vvint,out2,nfl) if(nfl==0) then tnd(k,i)=out2(1) snd(k,i)=out2(2) endif endif !vmag/=0 enddo !k=kbp(i),nvrt do k=1,kbp(i)-1 tnd(k,i)=tnd(kbp(i),i) snd(k,i)=snd(kbp(i),i) enddo !k endif !rewetted enddo !i=1,np !... z-coor. for sides !... A side is wet if and only if at least one of its elements is wet do i=1,ns n1=isidenode(i,1) n2=isidenode(i,2) idry_s_new(i)=1 do j=1,2 !elements ie=is(i,j) if(ie/=0.and.idry_e(ie)==0) idry_s_new(i)=0 enddo !j kbs(i)=0 !dry if(idry_s_new(i)==0) then !wet side with 2 wet nodes if(dps(i)+(eta2(n1)+eta2(n2))/2<=h0) then write(11,*)'Weird side:',i,n1,n2,eta2(n1),eta2(n2) stop endif kbs(i)=max0(kbp(n1),kbp(n2)) do k=kbs(i),nvrt zs(k,i)=(z(k,n1)+z(k,n2))/2 if(k>=kbs(i)+1.and.zs(k,i)-zs(k-1,i)<=0) then write(11,*)'Weird side:' write(11,*)k,n1,n2,z(k,n1),z(k,n2),z(k-1,n1),z(k-1,n2) stop endif enddo !k endif enddo !i=1,ns ! Compute vel., S,T for re-wetted sides ! Vel. as average; back-up S,T do i=1,ns if(it/=iths.and.idry_s(i)==1.and.idry_s_new(i)==0) then n1=isidenode(i,1) n2=isidenode(i,2) do k=1,nvrt su2(k,i)=0 sv2(k,i)=0 tsd(k,i)=0 ssd(k,i)=0 icount=0 do j=1,2 ie=is(i,j) if(ie/=0) then do jj=1,3 !side isd=js(ie,jj) if(idry_s(isd)==0) then icount=icount+1 su2(k,i)=su2(k,i)+su2(k,isd) sv2(k,i)=sv2(k,i)+sv2(k,isd) tsd(k,i)=tsd(k,i)+tsd(k,isd) ssd(k,i)=ssd(k,i)+ssd(k,isd) endif enddo !jj endif !ie/=0 enddo !j if(icount==0) then if(ifort12(10)==0) then ifort12(10)=1 write(12,*)'Isolated rewetted side:',i,n1,n2 endif tsd(k,i)=(tem0(k,n1)+tem0(k,n2))/2 ssd(k,i)=(sal0(k,n1)+sal0(k,n2))/2 else su2(k,i)=su2(k,i)/icount sv2(k,i)=sv2(k,i)/icount tsd(k,i)=tsd(k,i)/icount ssd(k,i)=ssd(k,i)/icount endif enddo !k endif !rewetted enddo !i=1,ns do i=1,ns if(it/=iths.and.idry_s(i)==1.and.idry_s_new(i)==0) then n1=isidenode(i,1) n2=isidenode(i,2) do k=kbs(i),nvrt x0=xcj(i) y0=ycj(i) uuint=su2(k,i) vvint=sv2(k,i) vmag=dsqrt(uuint**2+vvint**2) nnel=is(i,1) !any element jlev=k if(idry_e0(nnel)==0) then write(11,*)'Starting element must be dry (2)' stop endif if(vmag/=0) then uuint=uuint/vmag vvint=vvint/vmag call upwindtrack(i,jlev,nnel,x0,y0,uuint,vvint,out2,nfl) if(nfl==0) then tsd(k,i)=out2(1) ssd(k,i)=out2(2) endif endif enddo !k=kbs(i),nvrt do k=1,kbs(i)-1 tsd(k,i)=tsd(kbs(i),i) ssd(k,i)=ssd(kbs(i),i) enddo !k endif !rewetted enddo !i=1,ns idry_s=idry_s_new return end ! !******************************************************************** ! ! Inundation routine to update z-coordinates and wetting and drying. ! Better for fine resolution. ! !******************************************************************** ! subroutine levels1(iths,it) use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) integer, intent(in) :: iths,it dimension idry2(mnp),idry_s2(mns),idry_e2(mne),out2(12+mnv),sutmp(mnv),svtmp(mnv) dimension isdf(mns),inew(mns),icolor(mnp),icolor2(mns) !... An element is wet if and only if depths at all nodes >h0 !... A node is wet if and only if at least one surrounding element is wet !... A side is wet if and only if at least one surrounding element is wet ! Initialize element flags for first step if(it==iths) then idry_e=0 do i=1,ne do j=1,3 nd=nm(i,j) if(eta2(nd)+dp(nd)<=h0) then idry_e(i)=1 exit endif enddo !j enddo !i endif !it if(it/=iths) idry_e0=idry_e !save only for upwindtrack() !... Wetting/drying algorithm idry_e2=idry_e !starting from step n's indices if(it/=iths) then istop=0 !stop iteration and go to extrapolation stage itr=0 loop15: do itr=itr+1 if(itr>200) then write(11,*)'Too many iterations in wet/dry' stop endif ! Interface sides nsdf=0 icolor=0 !nodes on the interface sides icolor2=0 !interface sides do i=1,ns if(is(i,2)/=0.and.idry_e2(is(i,1))+idry_e2(is(i,2))==1) then nsdf=nsdf+1 isdf(nsdf)=i icolor(isidenode(i,1:2))=1 icolor2(i)=1 endif enddo !i if(nsdf==0) exit loop15 ! Final extrapolation if(istop==1) then icolor=0 !frontier nodes inew=0 !for initializing and counting su2 sv2 do i=1,nsdf isd=isdf(i) if(idry_e2(is(isd,1))+idry_e2(is(isd,2))/=1) cycle if(idry_e2(is(isd,1))==1) then ie=is(isd,1) else ie=is(isd,2) endif n1=isidenode(isd,1) n2=isidenode(isd,2) nodeA=nm(ie,1)+nm(ie,2)+nm(ie,3)-n1-n2 if(icolor(nodeA)==1) cycle !this node is done icolor(nodeA)=1 !this node is done inun=0 !inundation flag do j=1,nne(nodeA) ie2=ine(nodeA,j) id=iself(nodeA,j) isd2=js(ie2,id) if(icolor2(isd2)==1) then tmp=su2(nvrt,isd2)*snx(isd2)+sv2(nvrt,isd2)*sny(isd2) flux_t=-tmp*ssign(ie2,id) !inward normal if(flux_t>0) then n1=isidenode(isd2,1) n2=isidenode(isd2,2) ! avh=(eta2(n1)+dp(n1)+eta2(n2)+dp(n2))/2 ! vol=flux_t*dt*avh*distj(isd2) !inflow volume in one step ! avh3=(eta2(n1)+dp(n1)+eta2(n2)+dp(n2))/3 !assume total depth at nodeA=0 ! volmin=avh3*area(ie2) etm=max(eta2(n1),eta2(n2)) if(etm+dp(nodeA)>h0) then inun=1 exit endif endif endif enddo !j if(inun==1) then eta2(nodeA)=max(eta2(nodeA),-dp(nodeA)+2*h0) do j=1,nne(nodeA) ie2=ine(nodeA,j) id=iself(nodeA,j) isd2=js(ie2,id) if(icolor2(isd2)==1) then do l=1,3 nd=nm(ie2,l) if(eta2(nd)+dp(nd)<=h0) then write(11,*)'Failed to wet element:',l stop endif enddo !l=1,3 idry_e2(ie2)=0 do l=1,2 !sides sharing nodeA id1=js(ie2,nx(id,l)) if(inew(id1)==0) then su2(1:nvrt,id1)=su2(1:nvrt,isd2) sv2(1:nvrt,id1)=sv2(1:nvrt,isd2) inew(id1)=1 else su2(1:nvrt,id1)=su2(1:nvrt,id1)+su2(1:nvrt,isd2) sv2(1:nvrt,id1)=sv2(1:nvrt,id1)+sv2(1:nvrt,isd2) inew(id1)=inew(id1)+1 endif enddo !l=1,2 endif !icolor2(isd2)==1 enddo !j=1,nne(nodeA) endif !inun==1 enddo !i=1,nsdf do i=1,ns if(inew(i)/=0) then su2(1:nvrt,i)=su2(1:nvrt,i)/inew(i) sv2(1:nvrt,i)=sv2(1:nvrt,i)/inew(i) endif enddo !i ! exit loop15 istop=2 go to 991 endif !istop=1; final extrapolation inew=0 !for initializing and counting su2 sv2 istop=1 !stop iteration and go to extrapolation stage do i=1,nsdf isd=isdf(i) ifl=0 !flag for making dry do j=1,2 nd=isidenode(isd,j) if(eta2(nd)+dp(nd)<=h0) then istop=0 ifl=1 do l=1,nne(nd) idry_e2(ine(nd,l))=1 enddo !l endif enddo !j=1,2 nodes if(ifl==1) cycle ! 2 end nodes have total depths > h0 if(idry_e2(is(isd,1))+idry_e2(is(isd,2))/=1) cycle if(idry_e2(is(isd,1))==1) then ie=is(isd,1) else ie=is(isd,2) endif n1=isidenode(isd,1) n2=isidenode(isd,2) nodeA=nm(ie,1)+nm(ie,2)+nm(ie,3)-n1-n2 l0=lindex(nodeA,ie) ! if(l0==0.or.icolor(nodeA)==1.or.nodeA==n1.or.nodeA==n2) then if(l0==0.or.nodeA==n1.or.nodeA==n2) then write(11,*)'Frontier node outside, or on the interface:',l0,icolor(nodeA),nodeA,n1,n2,itr,it,iths do l=1,ns if(icolor2(l)==1) then write(99,*)l,isidenode(l,1:2) write(99,*)l,is(l,1:2),idry_e2(is(l,1:2)),idry_e(is(l,1:2)) endif enddo !l do l=1,ne write(98,*)l,idry_e2(l),idry_e(l) enddo !l stop endif if(eta2(nodeA)+dp(nodeA)>h0) then !all 3 nodes have depths > h0 ! Check do j=1,3 nd=nm(ie,j) if(eta2(nd)+dp(nd)<=h0) then write(11,*)'Failed to wet element (11):',nd,nodeA stop endif enddo !j istop=0 idry_e2(ie)=0 do j=1,2 !sides sharing nodeA id1=js(ie,nx(l0,j)) if(icolor2(id1)==0) then if(inew(id1)==0) then su2(1:nvrt,id1)=su2(1:nvrt,isd) sv2(1:nvrt,id1)=sv2(1:nvrt,isd) inew(id1)=1 else su2(1:nvrt,id1)=su2(1:nvrt,id1)+su2(1:nvrt,isd) sv2(1:nvrt,id1)=sv2(1:nvrt,id1)+sv2(1:nvrt,isd) inew(id1)=inew(id1)+1 endif endif !icolor2(id)==0 enddo !j endif enddo !i=1,nsdf; interfacial sides ! Compute average vel. for rewetted sides do i=1,ns if(inew(i)/=0) then su2(1:nvrt,i)=su2(1:nvrt,i)/inew(i) sv2(1:nvrt,i)=sv2(1:nvrt,i)/inew(i) endif enddo !i ! Enforce wet/dry flag consistency between nodes and elements due to added wet elements 991 continue idry2=1 do i=1,ne if(idry_e2(i)==0) idry2(nm(i,1:3))=0 enddo !i do i=1,ne itmp=0 do j=1,3 if(idry2(nm(i,j))==1) itmp=1 enddo !j ! Compute su2 sv2 for rewetted sides if(idry_e2(i)==1.and.itmp==0) then sutmp=0 svtmp=0 icount=0 do j=1,3 isd=js(i,j) if(idry_e2(is(isd,1))==0.or.is(isd,2)/=0.and.idry_e2(is(isd,2))==0) then !at least one wet element icount=icount+1 sutmp(1:nvrt)=sutmp(1:nvrt)+su2(1:nvrt,isd) svtmp(1:nvrt)=svtmp(1:nvrt)+sv2(1:nvrt,isd) endif enddo !j if(icount/=0) then do j=1,3 isd=js(i,j) if(idry_e2(is(isd,1))==1) then if(is(isd,2)==0.or.is(isd,2)/=0.and.idry_e2(is(isd,2))==1) then su2(1:nvrt,isd)=sutmp(1:nvrt)/icount sv2(1:nvrt,isd)=svtmp(1:nvrt)/icount endif endif enddo !j endif endif !rewetted sides idry_e2(i)=itmp enddo !i=1,ne if(istop==2) exit loop15 end do loop15 endif !it/=iths !... Isolated dry nodes (do nothing for isolated wet) do i=1,np if(dp(i)+eta2(i)<=h0) idry_e2(ine(i,1:nne(i)))=1 enddo !i !... Wet/dry flags for nodes/sides idry2=1; idry_s2=1 do i=1,ne if(idry_e2(i)==0) then idry2(nm(i,1:3))=0 idry_s2(js(i,1:3))=0 endif enddo !i !... Reset vel. at dry sides do i=1,ns if(idry_s2(i)==1) then su2(1:nvrt,i)=0 sv2(1:nvrt,i)=0 endif enddo !i !... Reset elevation at dry nodes do i=1,np if(idry2(i)==1) then eta2(i)=min(0.d0,-dp(i)) endif enddo !i !... z-coor. for nodes !... do i=1,np if(eta2(i)<=h0-h_s) then write(11,*)'Deep depth dry:',i stop endif if(idry2(i)==1) then kbp(i)=0 else !wet if(dp(i)+eta2(i)<=h0) then write(11,*)'Mismatch in node index (2):',i,dp(i)+eta2(i) stop endif ! S-levels do k=kz,nvrt kin=k-kz+1 if(hmod(i)<=h_c) then if(ifort12(12)==0) then ifort12(12)=1 write(12,*)'Initial depth too shallow for S:',i,hmod(i),h_c endif iback(i)=1 z(k,i)=sigma(kin)*(hmod(i)+eta2(i))+eta2(i) else if(eta2(i)<=-h_c-(hmod(i)-h_c)*theta_f/s_con1) then !hmod(i)>h_c>=0 write(11,*)'Pls choose a larger h_c (1):',eta2(i),h_c stop else z(k,i)=eta2(i)*(1+sigma(kin))+h_c*sigma(kin)+(hmod(i)-h_c)*cs(kin) endif enddo !k=kz,nvrt ! z-levels if(dp(i)<=h_s) then kbp(i)=kz else !bottom index ! if(imm==1) then ! Redo every step for wet/dry changes kbp(i)=0 !flag do k=1,kz-1 if(-dp(i)>=ztot(k).and.-dp(i)=kz.or.kbp(i)<1) then write(11,*)'Impossible 92:',kbp(i),kz,i stop endif z(kbp(i),i)=-dp(i) do k=kbp(i)+1,kz-1 z(k,i)=ztot(k) enddo !k endif do k=kbp(i)+1,nvrt if(z(k,i)-z(k-1,i)<=0) then write(11,*)'Inverted z-levels at:',i,k,z(k,i)-z(k-1,i),eta2(i),hmod(i) stop endif enddo !k endif !wet ot dry enddo !i=1,np !... Z-coord. for elements kbe=0 do i=1,ne if(idry_e2(i)==0) then n1=nm(i,1) n2=nm(i,2) n3=nm(i,3) kbe(i)=max0(kbp(n1),kbp(n2),kbp(n3)) do k=kbe(i),nvrt ze(k,i)=(z(k,n1)+z(k,n2)+z(k,n3))/3 if(k>=kbe(i)+1.and.ze(k,i)-ze(k-1,i)<=0) then write(11,*)'Weird element:' write(11,*)k,i,ze(k,i),ze(k-1,i) stop endif enddo !k endif enddo !i !... z-coor. for sides !... A side is wet if and only if at least one of its elements is wet do i=1,ns kbs(i)=0 !dry if(idry_s2(i)==0) then !wet side with 2 wet nodes n1=isidenode(i,1) n2=isidenode(i,2) if(dps(i)+(eta2(n1)+eta2(n2))/2<=h0) then write(11,*)'Weird side:',i,n1,n2,eta2(n1),eta2(n2) stop endif kbs(i)=max0(kbp(n1),kbp(n2)) do k=kbs(i),nvrt zs(k,i)=(z(k,n1)+z(k,n2))/2 if(k>=kbs(i)+1.and.zs(k,i)-zs(k-1,i)<=0) then write(11,*)'Weird side:' write(11,*)k,n1,n2,z(k,n1),z(k,n2),z(k-1,n1),z(k-1,n2) stop endif enddo !k endif enddo !i=1,ns ! Compute S,T for re-wetted nodes (q2 and xl are fine) ! back-up S,T ! uu2 and vv2 are first estimates; will be overwritten by nodalvel later do i=1,np if(it/=iths.and.idry(i)==1.and.idry2(i)==0) then do k=1,nvrt uu2(k,i)=0 vv2(k,i)=0 tnd(k,i)=0 snd(k,i)=0 icount=0 do j=1,nnp(i) nd=inp(i,j) if(idry(nd)==0) then !all indices extended icount=icount+1 uu2(k,i)=uu2(k,i)+uu2(k,nd) vv2(k,i)=vv2(k,i)+vv2(k,nd) tnd(k,i)=tnd(k,i)+tnd(k,nd) snd(k,i)=snd(k,i)+snd(k,nd) endif enddo !j if(icount==0) then if(ifort12(7)==0) then ifort12(7)=1 write(12,*)'Isolated rewetted node:',i endif tnd(k,i)=tem0(k,i) snd(k,i)=sal0(k,i) else uu2(k,i)=uu2(k,i)/icount vv2(k,i)=vv2(k,i)/icount tnd(k,i)=tnd(k,i)/icount snd(k,i)=snd(k,i)/icount endif enddo !k=1,nvrt endif !rewetted enddo !i=1,np do i=1,np if(it/=iths.and.idry(i)==1.and.idry2(i)==0) then do k=kbp(i),nvrt x0=x(i) y0=y(i) uuint=uu2(k,i) vvint=vv2(k,i) vmag=dsqrt(uuint**2+vvint**2) nnel=ine(i,1) !any element jlev=k if(idry_e0(nnel)==0) then write(11,*)'Starting element must be dry' stop endif if(vmag/=0) then uuint=uuint/vmag vvint=vvint/vmag call upwindtrack(i,jlev,nnel,x0,y0,uuint,vvint,out2,nfl) if(nfl==0) then tnd(k,i)=out2(1) snd(k,i)=out2(2) endif endif !vmag/=0 enddo !k=kbp(i),nvrt do k=1,kbp(i)-1 tnd(k,i)=tnd(kbp(i),i) snd(k,i)=snd(kbp(i),i) enddo !k endif !rewetted enddo !i=1,np ! Compute vel., S,T for re-wetted sides ! back-up S,T do i=1,ns if(it/=iths.and.idry_s(i)==1.and.idry_s2(i)==0) then n1=isidenode(i,1) n2=isidenode(i,2) do k=1,nvrt ! su2(k,i)=0 ! sv2(k,i)=0 tsd(k,i)=0 ssd(k,i)=0 icount=0 do j=1,2 ie=is(i,j) if(ie/=0) then do jj=1,3 !side isd=js(ie,jj) if(isd/=i.and.idry_s(isd)==0) then !wet at step n icount=icount+1 ! su2(k,i)=su2(k,i)+su2(k,isd) ! sv2(k,i)=sv2(k,i)+sv2(k,isd) tsd(k,i)=tsd(k,i)+tsd(k,isd) ssd(k,i)=ssd(k,i)+ssd(k,isd) endif enddo !jj endif !ie/=0 enddo !j if(icount==0) then if(ifort12(10)==0) then ifort12(10)=1 write(12,*)'Isolated rewetted side:',i,n1,n2 endif tsd(k,i)=(tem0(k,n1)+tem0(k,n2))/2 ssd(k,i)=(sal0(k,n1)+sal0(k,n2))/2 else ! su2(k,i)=su2(k,i)/icount ! sv2(k,i)=sv2(k,i)/icount tsd(k,i)=tsd(k,i)/icount ssd(k,i)=ssd(k,i)/icount endif enddo !k endif !rewetted enddo !i=1,ns do i=1,ns if(it/=iths.and.idry_s(i)==1.and.idry_s2(i)==0) then n1=isidenode(i,1) n2=isidenode(i,2) do k=kbs(i),nvrt x0=xcj(i) y0=ycj(i) uuint=su2(k,i) vvint=sv2(k,i) vmag=dsqrt(uuint**2+vvint**2) nnel=is(i,1) !any element jlev=k if(idry_e0(nnel)==0) then write(11,*)'Starting element must be dry (2)' stop endif if(vmag/=0) then uuint=uuint/vmag vvint=vvint/vmag call upwindtrack(i,jlev,nnel,x0,y0,uuint,vvint,out2,nfl) if(nfl==0) then tsd(k,i)=out2(1) ssd(k,i)=out2(2) endif endif enddo !k=kbs(i),nvrt do k=1,kbs(i)-1 tsd(k,i)=tsd(kbs(i),i) ssd(k,i)=ssd(kbs(i),i) enddo !k endif !rewetted enddo !i=1,ns !... Update wet/dry flags idry=idry2 idry_s=idry_s2 idry_e=idry_e2 return end ! !*************************************************************************** ! ! Routine for backtracking. ! Input: ! ielem: initial starting element; ! l_ns: starting from nodes (l_ns<=3) or sides (3=1 else !sides isd=js(ielem,l_ns-3) sum=0 icount=0 do i=1,2 ie=is(isd,i) if(ie==0) cycle icount=icount+1 dudx=0; dudy=0; dvdx=0; dvdy=0 do j=1,3 dudx=dudx+ufg(j0,ie,j)*dl(ie,j,1) !not strictly along z dudy=dudy+ufg(j0,ie,j)*dl(ie,j,2) !not strictly along z dvdx=dvdx+vfg(j0,ie,j)*dl(ie,j,1) dvdy=dvdy+vfg(j0,ie,j)*dl(ie,j,2) enddo !j sum=sum+dt*sqrt(dudx**2+dudy**2+dvdx**2+dvdy**2) enddo !i=1,2 if(icount==0) then write(11,*)'Impossible 77' stop endif ndelt=max0(1,min0(ndelt_max,int(sum/icount)*4)) !>=1 endif dtb=dt/ndelt nnel0=nnel jlev0=jlev x0=x00 y0=y00 z0=z00 do idt=1,ndelt xt=x0-dtb*uuint yt=y0-dtb*vvint zt=z0-dtb*wwint call quicksearch(1,idt,ielem,nnel0,jlev0,dtb,x0,y0,z0,xt,yt,zt,nnel,jlev,arco,zrat,ztmp,kbpl,iflqs1,ss) ! nnel wet ! No interpolate in time do j=1,3 nd=nm(nnel,j) do l=1,2 lev=jlev+l-2 vxl(j,l)=(1-vis_coe)*uu2(lev,nd)+vis_coe*ufg(lev,nnel,j) vyl(j,l)=(1-vis_coe)*vv2(lev,nd)+vis_coe*vfg(lev,nnel,j) vzl(j,l)=ww2(lev,nd) enddo !l enddo !j ! Interpolate in vertical do j=1,3 if(interpol(nnel)==1) then nd=nm(nnel,j) kbb=kbp(nd) swild3(kbb:nvrt)=z(kbb:nvrt,nd) swild2(kbb:nvrt,1)=(1-vis_coe)*uu2(kbb:nvrt,nd)+vis_coe*ufg(kbb:nvrt,nnel,j) swild2(kbb:nvrt,2)=(1-vis_coe)*vv2(kbb:nvrt,nd)+vis_coe*vfg(kbb:nvrt,nnel,j) swild2(kbb:nvrt,3)=ww2(kbb:nvrt,nd) call vinter(mnv,3,zt,kbb,nvrt,jlev,swild3,swild2,swild,ibelow) vxn(j)=swild(1) vyn(j)=swild(2) vzn(j)=swild(3) else !pure S region vxn(j)=vxl(j,2)*(1-zrat)+vxl(j,1)*zrat vyn(j)=vyl(j,2)*(1-zrat)+vyl(j,1)*zrat vzn(j)=vzl(j,2)*(1-zrat)+vzl(j,1)*zrat endif enddo !j ! Interpolate in horizontal uuint=vxn(1)*arco(1)+vxn(2)*arco(2)+vxn(3)*arco(3) vvint=vyn(1)*arco(1)+vyn(2)*arco(2)+vyn(3)*arco(3) wwint=vzn(1)*arco(1)+vzn(2)*arco(2)+vzn(3)*arco(3) if(iflqs1==1) exit x0=xt y0=yt z0=zt nnel0=nnel jlev0=jlev enddo !idt=1,ndelt !------------------------------------------------------------------------------------------------ endif !Euler !... 5th-order R-K tracking if(iadvf==2) then !------------------------------------------------------------------------------------------------ dtb0=dmin1(dtb_max,dt) t_m=dt !t^m idt=0 rk(1,1)=-dtb0*uuint rk(1,2)=-dtb0*vvint rk(1,3)=-dtb0*wwint ! Initialize nnel0 and jlev0 nnel0=nnel jlev0=jlev x0=x00 y0=y00 z0=z00 uuint0=uuint vvint0=vvint wwint0=wwint icount=0 loop5: do idt=idt+1 icount=icount+1 ! k2-6 and k1 for the next step do k=2,7 !k=7 --> k1 xt=x0 yt=y0 zt=z0 do l=1,k-1 xt=xt+rk(l,1)*b(k,l) yt=yt+rk(l,2)*b(k,l) zt=zt+rk(l,3)*b(k,l) enddo !l call quicksearch(1,idt,ielem,nnel0,jlev0,dtb0*a(k),x0,y0,z0,xt,yt,zt,nnel,jlev,arco,zrat,ztmp,kbpl,iflqs1,ss) if(k==7) then dx=0 dy=0 dz=0 do l=1,k-1 dx=dx+rk(l,1)*dc(l) dy=dy+rk(l,2)*dc(l) dz=dz+rk(l,3)*dc(l) enddo !l del_xy=dsqrt(dx*dx+dy*dy) del_z=dabs(dz) n1=nm(nnel,1) !wet node del0_xy=per1*radiel(nnel) jmin=max0(jlev,kbp(n1)+1) del0_z=per1*(z(jmin,n1)-z(jmin-1,n1)) if(del0_z<=0) then write(11,*)'Negative layer:',del0_z stop endif if(del_xy==0) then dtb_xy=dtb0 else dtb_xy=safety*dtb0*(del0_xy/del_xy)**0.2 endif if(del_z==0) then dtb_z=dtb0 else dtb_z=safety*dtb0*(del0_z/del_z)**0.2 endif ! Proposed time step for next iteration dtb=dmin1(dtb_xy,dtb_z,t_m,dtb_max) !dtb_xy,dtb_z,t_m >0 if(del_xy>del0_xy.or.del_z>del0_z) then ! Debug ! write(90,*)ielem,icount,t_m,dtb0,dtb,idt if(icount<=5) then ! Update dtb0 and k1, and redo current step dtb0=dtb rk(1,1)=-dtb0*uuint0 rk(1,2)=-dtb0*vvint0 rk(1,3)=-dtb0*wwint0 cycle loop5 else !trap reached if(ifort12(2)==0) then ifort12(2)=1 write(12,*)'Adaptivity trap reached after ',icount endif endif endif ! Successful t_m=t_m-dtb0 if(t_m<0) then write(11,*)'Negative time level:',t_m stop endif ! Update dtb0 dtb0=dmin1(dtb,t_m) if(dtb0==0.and.t_m/=0) then write(11,*)'Weird btrack:',dtb0,t_m stop endif icount=0 !reset ! Debug ! close(90) ! open(90,file='fort.90') ! rewind(90) endif !k==7 ! nnel wet ! Interpolate in time if(k==7) then trat=t_m/dt !t_m updated else trat=(t_m-a(k)*dtb0)/dt !dtb0 not updated for k=2-6 endif do j=1,3 nd=nm(nnel,j) do l=1,2 lev=jlev+l-2 vxl(j,l)=(1-vis_coe)*uu2(lev,nd)+vis_coe*ufg(lev,nnel,j) vyl(j,l)=(1-vis_coe)*vv2(lev,nd)+vis_coe*vfg(lev,nnel,j) vzl(j,l)=ww2(lev,nd) enddo !l enddo !j ! Interpolate in vertical do j=1,3 if(interpol(nnel)==1) then nd=nm(nnel,j) kbb=kbp(nd) swild3(kbb:nvrt)=z(kbb:nvrt,nd) swild2(kbb:nvrt,1)=(1-vis_coe)*uu2(kbb:nvrt,nd)+vis_coe*ufg(kbb:nvrt,nnel,j) swild2(kbb:nvrt,2)=(1-vis_coe)*vv2(kbb:nvrt,nd)+vis_coe*vfg(kbb:nvrt,nnel,j) swild2(kbb:nvrt,3)=ww2(kbb:nvrt,nd) call vinter(mnv,3,zt,kbb,nvrt,jlev,swild3,swild2,swild,ibelow) vxn(j)=swild(1) vyn(j)=swild(2) vzn(j)=swild(3) else !pure S region vxn(j)=vxl(j,2)*(1-zrat)+vxl(j,1)*zrat vyn(j)=vyl(j,2)*(1-zrat)+vyl(j,1)*zrat vzn(j)=vzl(j,2)*(1-zrat)+vzl(j,1)*zrat endif enddo !j ! Interpolate in horizontal uuint=vxn(1)*arco(1)+vxn(2)*arco(2)+vxn(3)*arco(3) vvint=vyn(1)*arco(1)+vyn(2)*arco(2)+vyn(3)*arco(3) wwint=vzn(1)*arco(1)+vzn(2)*arco(2)+vzn(3)*arco(3) if(k==7) then in=1 else in=k endif rk(in,1)=-dtb0*uuint !dtb0 updated for k=7 rk(in,2)=-dtb0*vvint rk(in,3)=-dtb0*wwint ! if(iflqs1==1) exit loop5 enddo !k=2,7 x0=xt y0=yt z0=zt nnel0=nnel jlev0=jlev uuint0=uuint vvint0=vvint wwint0=wwint if(t_m<=0) exit loop5 end do loop5 !------------------------------------------------------------------------------------------------ endif !R-K ! Kriging for vel. (excluding bnd nodes/sides) if(krvel(nnel)==1.and.(l_ns<=3.and.isbnd(nm(ielem,l_ns))==0.or.l_ns>3.and.is(js(ielem,l_ns-3),2)/=0)) then ! Prepare data ie=ie_kr(nnel) !local index if(ie==0) then write(11,*)'Out of Kriging zone:',nnel stop endif npp=itier_nd(ie,0) do i=1,npp nd=itier_nd(ie,i) if(idry(nd)==1) then !i.c. uvdata(i,1)=0 uvdata(i,2)=0 else !wet if(interpol(nnel)==1) then kbb=kbp(nd) swild3(kbb:nvrt)=z(kbb:nvrt,nd) swild2(kbb:nvrt,1)=uu2(kbb:nvrt,nd) swild2(kbb:nvrt,2)=vv2(kbb:nvrt,nd) call vinter(mnv,2,zt,kbb,nvrt,jlev,swild3,swild2,swild,ibelow) uvdata(i,1:2)=swild(1:2) else !along S uvdata(i,1)=uu2(jlev,nd)*(1-zrat)+uu2(jlev-1,nd)*zrat uvdata(i,2)=vv2(jlev,nd)*(1-zrat)+vv2(jlev-1,nd)*zrat endif endif enddo !all ball nodes do i=1,npp+3 al_beta(i,1:2)=0 do j=1,npp al_beta(i,1:2)=al_beta(i,1:2)+akrmat_nd(ie,i,j)*uvdata(j,1:2) enddo !j enddo !i uuint=al_beta(npp+1,1)+al_beta(npp+2,1)*xt+al_beta(npp+3,1)*yt vvint=al_beta(npp+1,2)+al_beta(npp+2,2)*xt+al_beta(npp+3,2)*yt do i=1,npp nd=itier_nd(ie,i) rr=dsqrt((x(nd)-xt)**2+(y(nd)-yt)**2) covar2=covar(kr_co,decorrel(ie),rr) uuint=uuint+al_beta(i,1)*covar2 vvint=vvint+al_beta(i,2)*covar2 enddo !i endif !Kriging vel. !... Interpolation at the foot for S,T !... out6=0 !initialize ! nnel wet if(zrat<0.or.zrat>1) then write(11,*)'zrat wrong:',jlev stop endif ! Split-linear, quadratic or Kriging if(lqk(nnel)==1) then !----------------------------------------------------------------------- ! Split-linear index=0 do i=1,4 if(i<=3) then n1=nm(nnel,i) n2=js(nnel,nx(i,2)) n3=js(nnel,nx(i,1)) aa1=signa(xt,xcj(n2),xcj(n3),yt,ycj(n2),ycj(n3)) aa2=signa(x(n1),xt,xcj(n3),y(n1),yt,ycj(n3)) aa3=signa(x(n1),xcj(n2),xt,y(n1),ycj(n2),yt) aa=dabs(aa1)+dabs(aa2)+dabs(aa3) subrat(i)=dabs(aa-area(nnel)/4)*4/area(nnel) if(subrat(i)<100*small1) then index=1 sig(1)=aa1*4/area(nnel) sig(2)=aa2*4/area(nnel) sig(1)=dmax1(0.0d0,dmin1(1.0d0,sig(1))) sig(2)=dmax1(0.0d0,dmin1(1.0d0,sig(2))) if(sig(1)+sig(2)>1) then sig(3)=0 sig(2)=1-sig(1) else sig(3)=1-sig(1)-sig(2) endif ! S,T extended ! t_xi(1)=tnd(jlev,n1)*(1-zrat)+tnd(jlev-1,n1)*zrat ! t_xi(2)=tsd(jlev,n2)*(1-zrat)+tsd(jlev-1,n2)*zrat ! smax=-99; tmin=100; ibb=0 !flag do jj=1,3 !node or side if(jj==1) then kbb=kbp(n1) swild3(kbb:nvrt)=z(kbb:nvrt,n1) swild2(kbb:nvrt,1)=tnd(kbb:nvrt,n1) swild2(kbb:nvrt,2)=snd(kbb:nvrt,n1) ! swild2(kbb:nvrt,3)=uu2(kbb:nvrt,n1) ! swild2(kbb:nvrt,4)=vv2(kbb:nvrt,n1) else if(jj==2) then kbb=kbs(n2) swild3(kbb:nvrt)=zs(kbb:nvrt,n2) swild2(kbb:nvrt,1)=tsd(kbb:nvrt,n2) swild2(kbb:nvrt,2)=ssd(kbb:nvrt,n2) ! swild2(kbb:nvrt,3)=su2(kbb:nvrt,n2) ! swild2(kbb:nvrt,4)=sv2(kbb:nvrt,n2) else !=3 kbb=kbs(n3) swild3(kbb:nvrt)=zs(kbb:nvrt,n3) swild2(kbb:nvrt,1)=tsd(kbb:nvrt,n3) swild2(kbb:nvrt,2)=ssd(kbb:nvrt,n3) ! swild2(kbb:nvrt,3)=su2(kbb:nvrt,n3) ! swild2(kbb:nvrt,4)=sv2(kbb:nvrt,n3) endif call vinter(mnv,2,zt,kbb,nvrt,jlev,swild3,swild2,swild,ibelow) ! if(ibelow==1) ibb=1 ! if(smaxswild(1)) tmin=swild(1) t_xi(jj)=swild(1); s_xi(jj)=swild(2) enddo !jj=1,3 out6(1)=t_xi(1)*sig(1)+t_xi(2)*sig(2)+t_xi(3)*sig(3) out6(2)=s_xi(1)*sig(1)+s_xi(2)*sig(2)+s_xi(3)*sig(3) exit endif !subrat(i)<100*small1 else !i=4 n1=js(nnel,1) n2=js(nnel,2) n3=js(nnel,3) aa1=signa(xt,xcj(n2),xcj(n3),yt,ycj(n2),ycj(n3)) aa2=signa(xcj(n1),xt,xcj(n3),ycj(n1),yt,ycj(n3)) aa3=signa(xcj(n1),xcj(n2),xt,ycj(n1),ycj(n2),yt) aa=dabs(aa1)+dabs(aa2)+dabs(aa3) subrat(i)=dabs(aa-area(nnel)/4)*4/area(nnel) if(subrat(i)<100*small1) then index=1 sig(1)=aa1*4/area(nnel) sig(2)=aa2*4/area(nnel) sig(1)=dmax1(0.0d0,dmin1(1.0d0,sig(1))) sig(2)=dmax1(0.0d0,dmin1(1.0d0,sig(2))) if(sig(1)+sig(2)>1) then sig(3)=0 sig(2)=1-sig(1) else sig(3)=1-sig(1)-sig(2) endif ! t_xi(1)=tsd(jlev,n1)*(1-zrat)+tsd(jlev-1,n1)*zrat ! t_xi(2)=tsd(jlev,n2)*(1-zrat)+tsd(jlev-1,n2)*zrat ! smax=-99; tmin=100; ibb=0 !flag do jj=1,3 !side isd=js(nnel,jj) kbb=kbs(isd) swild3(kbb:nvrt)=zs(kbb:nvrt,isd) swild2(kbb:nvrt,1)=tsd(kbb:nvrt,isd) swild2(kbb:nvrt,2)=ssd(kbb:nvrt,isd) ! swild2(kbb:nvrt,3)=su2(kbb:nvrt,isd) ! swild2(kbb:nvrt,4)=sv2(kbb:nvrt,isd) call vinter(mnv,2,zt,kbb,nvrt,jlev,swild3,swild2,swild,ibelow) ! if(ibelow==1) ibb=1 ! if(smaxswild(1)) tmin=swild(1) t_xi(jj)=swild(1); s_xi(jj)=swild(2) enddo !jj=1,3 ! if(ibb==1) then ! if(smax<-98) then ! write(11,*)'Max. S failed to exist (2):',zt,nnel ! stop ! endif ! t_xi(1:3)=tmin; s_xi(1:3)=smax ! endif out6(1)=t_xi(1)*sig(1)+t_xi(2)*sig(2)+t_xi(3)*sig(3) out6(2)=s_xi(1)*sig(1)+s_xi(2)*sig(2)+s_xi(3)*sig(3) exit endif !subrat(i)<100*small1 endif !i<=3 enddo !i=1,4 if(index==0) then write(11,*)'Not in any sub-element',nnel,(subrat(i),i=1,4) write(11,*)xt,yt stop endif !----------------------------------------------------------------------- else if(lqk(nnel)==2) then !----------------------------------------------------------------------- ! Quadratic interplation ! For pure S only if(ss<-1.or.ss>0.or.kbpl/=kz) then write(11,*)'ss out of bound:',ss,kbpl stop endif if(wwint00>=0) then lin=-1 !lower interval if(jlev==kbpl+1) lin=-99 else lin=1 if(jlev==nvrt) lin=-98 endif outq1=0; outq2=0 t_min=100; t_max=-100; s_min=100; s_max=-100 do i=1,3 !nodes and sides nd=nm(nnel,i) isd=js(nnel,i) in1=nx(i,1) in2=nx(i,2) ! check (range extended) if(tnd(jlev,nd)<-98.or.snd(jlev,nd)<-98.or.tsd(jlev,isd)<-98.or.ssd(jlev,isd)<-98) then write(11,*)'Wrong S,T:',i,nd,isd,tnd(jlev,nd),snd(jlev,nd),tsd(jlev,isd),ssd(jlev,isd) stop endif if(dabs(ss+1)<1.e-4.or.dabs(ss)<1.e-4) then !two surfaces if(dabs(ss+1)<1.e-4) then lev=kz else lev=nvrt endif t_n=tnd(lev,nd) s_n=snd(lev,nd) t_s=tsd(lev,isd) s_s=ssd(lev,isd) temp_min=dmin1(tnd(lev,nd),tsd(lev,isd)) temp_max=dmax1(tnd(lev,nd),tsd(lev,isd)) salt_min=dmin1(snd(lev,nd),ssd(lev,isd)) salt_max=dmax1(snd(lev,nd),ssd(lev,isd)) else if(lin<=-98) then !constrained bottom or surface if(lin==-99) then ! zrat3=((zt-ztmp(kbpl))/(ztmp(kbpl+1)-ztmp(kbpl)))**2 srat=((ss+1)/(sigma(2)+1))**2 else ! zrat3=((zt-ztmp(nvrt))/(ztmp(nvrt-1)-ztmp(nvrt)))**2 ! zrat3=1-zrat3 !to put in same form srat=(ss/sigma(nsig-1))**2 srat=1-srat !to put in same form endif if(srat<0.or.srat>1) then write(11,*)'Out of bound (9):',srat stop endif t_n=tnd(jlev,nd)*srat+tnd(jlev-1,nd)*(1-srat) s_n=snd(jlev,nd)*srat+snd(jlev-1,nd)*(1-srat) t_s=tsd(jlev,isd)*srat+tsd(jlev-1,isd)*(1-srat) s_s=ssd(jlev,isd)*srat+ssd(jlev-1,isd)*(1-srat) temp_min=dmin1(tnd(jlev,nd),tnd(jlev-1,nd),tsd(jlev,isd),tsd(jlev-1,isd)) temp_max=dmax1(tnd(jlev,nd),tnd(jlev-1,nd),tsd(jlev,isd),tsd(jlev-1,isd)) salt_min=dmin1(snd(jlev,nd),snd(jlev-1,nd),ssd(jlev,isd),ssd(jlev-1,isd)) salt_max=dmax1(snd(jlev,nd),snd(jlev-1,nd),ssd(jlev,isd),ssd(jlev-1,isd)) else !normal if(i==1) then !the following is indepdendent of loop i if(lin==1) then k1=jlev-1 else !=-1 k1=jlev-2 endif k2=k1+1; k3=k2+1 if(k1nvrt) then write(11,*)'Weird level:',k1,k2,k3 stop endif k1s=k1-kz+1; k2s=k2-kz+1; k3s=k3-kz+1 !change to sigma indices denom=sigma(k3s)-2*sigma(k2s)+sigma(k1s) if(dabs(denom)<1.e-5) then !degenerate xi=2*(ss-sigma(k2s))/(sigma(k3s)-sigma(k1s)) else del=(sigma(k3s)-sigma(k1s))**2-8*(sigma(k2s)-ss)*denom if(del<0) then write(11,*)'No inverse quadratic mapping:',del stop endif icount=0 vzn(1)=(sigma(k1s)-sigma(k3s)+dsqrt(del))/2/denom !!temporary storage vzn(2)=(sigma(k1s)-sigma(k3s)-dsqrt(del))/2/denom xi_m=vzn(1) !for no root scenario if(dabs(vzn(2))t_max) t_max=temp_max if(salt_mins_max) s_max=salt_max enddo !i=1,3 if(t_min>t_max) then write(11,*)'Illegal min/max for temp:',t_min,t_max,nnel stop endif if(s_min>s_max) then write(11,*)'Illegal min/max for salt:',s_min,s_max,nnel stop endif out6(1)=dmax1(t_min,dmin1(t_max,outq1)) out6(2)=dmax1(s_min,dmin1(s_max,outq2)) !----------------------------------------------------------------------- endif !linear or quadratic return end function sums(x1,x2,x3,x4,y1,y2,y3,y4) use kind_par implicit real(kind=dbl_kind1)(a-h,o-z),integer(i-n) sums=dabs((x4-x3)*(y2-y3)+(x2-x3)*(y3-y4))/2+& & dabs((x4-x1)*(y3-y1)-(y4-y1)*(x3-x1))/2+& & dabs((y4-y1)*(x2-x1)-(x4-x1)*(y2-y1))/2 return end function signa(x1,x2,x3,y1,y2,y3) !... Compute signed area formed by pts 1,2,3 use kind_par implicit real(kind=dbl_kind1)(a-h,o-z),integer(i-n) signa=((x1-x3)*(y2-y3)-(x2-x3)*(y1-y3))/2 return end subroutine header use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) character(len=48) :: variable_out ! integer :: ivs,i23d do i=1,noutput if(iwrite.eq.0) irec(i)=0 !record # for binary ichan(i)=100+i !output channel # if(i>=13.and.i<=15.or.i==25) then ivs=2 else ivs=1 endif if(i<=15) then i23d=2 !2 or 3D else i23d=3 endif if(iof(i)==1) then if(iwrite.eq.0) then open(ichan(i),file=ifile_char//'_'//outfile(i),access='direct',recl=nbyte) ! ' (ylz) else !evm open(ichan(i),file=ifile_char//'_'//outfile(i)) endif if(iwrite.eq.0) then do m=1,48/nbyte write(ichan(i),rec=irec(i)+m) data_format(nbyte*(m-1)+1:nbyte*m) enddo irec(i)=irec(i)+48/nbyte do m=1,48/nbyte write(ichan(i),rec=irec(i)+m) version(nbyte*(m-1)+1:nbyte*m) enddo irec(i)=irec(i)+48/nbyte do m=1,48/nbyte write(ichan(i),rec=irec(i)+m) start_time(nbyte*(m-1)+1:nbyte*m) enddo irec(i)=irec(i)+48/nbyte variable_out=variable_nm(i) do m=1,48/nbyte write(ichan(i),rec=irec(i)+m) variable_out(nbyte*(m-1)+1:nbyte*m) enddo irec(i)=irec(i)+48/nbyte variable_out=variable_dim(i) do m=1,48/nbyte write(ichan(i),rec=irec(i)+m) variable_out(nbyte*(m-1)+1:nbyte*m) enddo irec(i)=irec(i)+48/nbyte write(ichan(i),rec=irec(i)+1) nrec write(ichan(i),rec=irec(i)+2) real(dt*nspool) write(ichan(i),rec=irec(i)+3) nspool write(ichan(i),rec=irec(i)+4) ivs write(ichan(i),rec=irec(i)+5) i23d irec(i)=irec(i)+5 else !evm write(ichan(i),'(a48)',advance="no") data_format write(ichan(i),'(a48)',advance="no") version write(ichan(i),'(a48)',advance="no") start_time write(ichan(i),'(a48)',advance="no") variable_nm(i) write(ichan(i),'(a48)',advance="no") variable_dim(i) a_4 = transfer(source=nrec,mold=a_4) write(ichan(i),"(a4)",advance="no") a_4 a_4 = transfer(source=real(dt*nspool),mold=a_4) write(ichan(i),"(a4)",advance="no") a_4 a_4 = transfer(source=nspool,mold=a_4) write(ichan(i),"(a4)",advance="no") a_4 a_4 = transfer(source=ivs,mold=a_4) write(ichan(i),"(a4)",advance="no") a_4 a_4 = transfer(source=i23d,mold=a_4) write(ichan(i),"(a4)",advance="no") a_4 endif ! Vertical grid if(iwrite.eq.0) then write(ichan(i),rec=irec(i)+1) nvrt write(ichan(i),rec=irec(i)+2) kz write(ichan(i),rec=irec(i)+3) real(h_0) write(ichan(i),rec=irec(i)+4) real(h_s) write(ichan(i),rec=irec(i)+5) real(h_c) write(ichan(i),rec=irec(i)+6) real(theta_b) write(ichan(i),rec=irec(i)+7) real(theta_f) irec(i)=irec(i)+7 else !evm a_4 = transfer(source=nvrt,mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 a_4 = transfer(source=kz,mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 a_4 = transfer(source=real(h_0),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 a_4 = transfer(source=real(h_s),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 a_4 = transfer(source=real(h_c),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 a_4 = transfer(source=real(theta_b),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 a_4 = transfer(source=real(theta_f),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 endif do k=1,kz-1 if(iwrite.eq.0) then write(ichan(i),rec=irec(i)+k) real(ztot(k)) else !evm a_4 = transfer(source=real(ztot(k)),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 endif enddo do k=kz,nvrt kin=k-kz+1 if(iwrite.eq.0) then write(ichan(i),rec=irec(i)+k) real(sigma(kin)) else !evm a_4 = transfer(source=real(sigma(kin)),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 endif enddo if(iwrite.eq.0) irec(i)=irec(i)+nvrt irecm=48/nbyte*5+5+7+nvrt !estimates of total record # ! Horizontal grid if(iwrite.eq.0) then write(ichan(i),rec=irec(i)+1) np write(ichan(i),rec=irec(i)+2) ne irec(i)=irec(i)+2 else !evm a_4 = transfer(source=np,mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 a_4 = transfer(source=ne,mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 endif do m=1,np if(iwrite.eq.0) then write(ichan(i),rec=irec(i)+1)real(x(m)) write(ichan(i),rec=irec(i)+2)real(y(m)) write(ichan(i),rec=irec(i)+3)real(dp00(m)) write(ichan(i),rec=irec(i)+4)kbp00(m) irec(i)=irec(i)+4 else !evm a_4 = transfer(source=real(x(m)),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 a_4 = transfer(source=real(y(m)),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 a_4 = transfer(source=real(dp00(m)),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 a_4 = transfer(source=kbp00(m),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 endif enddo !m=1,np do m=1,ne if(iwrite.eq.0) then write(ichan(i),rec=irec(i)+1) 3 irec(i)=irec(i)+1 do mm=1,3 write(ichan(i),rec=irec(i)+mm)nm(m,mm) enddo !mm irec(i)=irec(i)+3 else !evm a_4 = transfer(source=3,mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 do mm=1,3 a_4 = transfer(source=nm(m,mm),mold=a_4) write(ichan(i),'(a4)',advance="no") a_4 enddo !mm endif enddo !m ! Estimate total # of records irecm=irecm+3*np+4*ne if(i23d.eq.2) then !2D irecm=irecm+(2+np+np*ivs)*nrec else !3D irecm=irecm+(2+np+np*nvrt*ivs)*nrec endif if(irecm.gt.mirec) then write(11,*)'Output file too large',i,irecm stop endif if(iwrite.eq.0) then close(ichan(i)) ! do this to flush the write buffer open(ichan(i),file=ifile_char//'_'//outfile(i),access='direct',recl=nbyte) ! ' (ylz) endif endif !iof(i)=1 enddo !i=1,noutput ! Test output (old vis5 format) igmp=0 if(noutgm.eq.1) then open(100,file=ifile_char//'_test.60',access='direct',recl=nbyte) igmp=(32+24+24)/nbyte write(100,rec=igmp+1) nrec write(100,rec=igmp+2) ns write(100,rec=igmp+3) real(dt*nspool) write(100,rec=igmp+4) nspool write(100,rec=igmp+5) 2 igmp=igmp+5 close(100) open(100,file=ifile_char//'_test.60',access='direct',recl=nbyte) endif return end !****************************************************************************** ! * ! Transform from lon,lat (lamda,phi) coordinates into CPP coordinates. * ! Lon,Lat must be in radians. * ! * !****************************************************************************** subroutine cpp(x,y,rlambda,phi,rlambda0,phi0) use kind_par implicit real(kind=dbl_kind1)(a-h,o-z), integer(i-n) r=6378206.4 x=r*(rlambda-rlambda0)*dcos(phi0) y=phi*r return end ! !******************************************************************************** ! * ! Straightline search algorithm. Initially nnel0 is an element that * ! encompasses (x0,y0). iloc=0: do not nudge initial pt; iloc=1: nudge. * ! Input: iloc,nnel0,x0,y0,z0,xt,yt,zt,jlev0, time, and su2,sv2,ww2 for * ! abnormal cases; * ! Output the updated end pt (xt,yt,zt) (if so), nnel1, jlev1, area * ! coordinates, vertical ratio and a flag nfl. * ! nfl=1 if a bnd or dry element is hit and vel. there is small, * ! or death trap is reached. * ! * !******************************************************************************** ! subroutine quicksearch(iloc,idt,id0,nnel0,jlev0,time,x0,y0,z0,xt,yt,zt,nnel1,jlev1,arco,zrat,ztmp,kbpl,nfl,ss) use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) integer, intent(in) :: iloc,idt,id0,nnel0,jlev0 real(kind=dbl_kind), intent(in) :: time,x0,y0,z0 integer, intent(out) :: nnel1,jlev1,nfl real(kind=dbl_kind), intent(inout) :: xt,yt,zt integer, intent(out) :: kbpl real(kind=dbl_kind), intent(out) :: arco(3),zrat,ztmp(mnv),ss dimension out2(mnv) if(iloc>1) then write(11,*)'iloc > 1' stop endif if(idry_e(nnel0)==1) then write(11,*)'Starting element is dry' stop endif nfl=0 trm=time !time remaining ! Starting element nel ! Try area_coord nel=nnel0 aa=0 aa1=0 do i=1,3 n1=nm(nel,i) n2=nm(nel,nx(i,1)) aa=aa+dabs(signa(x(n1),x(n2),x0,y(n1),y(n2),y0)) aa1=aa1+dabs(signa(x(n1),x(n2),xt,y(n1),y(n2),yt)) enddo !i ae=dabs(aa-area(nel))/area(nel) if(ae>small1) then write(11,*)'(x0,y0) not in nnel0 initially',ae,nnel0 stop endif ae=dabs(aa1-area(nel))/area(nel) if(ae=1. if(iloc==0) then xcg=x0 ycg=y0 else if(iloc==1) then ! weit=1./3; al=0; bet=0 ! xint=x(nm(nel,1))*(weit-al)+x(nm(nel,2))*(weit-bet)+x(nm(nel,3))*(weit+al+bet) ! yint=y(nm(nel,1))*(weit-al)+y(nm(nel,2))*(weit-bet)+y(nm(nel,3))*(weit+al+bet) ! xcg=(1-5.e-4)*x0+5.e-4*xint ! ycg=(1-5.e-4)*y0+5.e-4*yint xcg=(1-1.0d-4)*x0+1.0d-4*xctr(nel) ycg=(1-1.0d-4)*y0+1.0d-4*yctr(nel) endif pathl=dsqrt((xt-xcg)**2+(yt-ycg)**2) if(pathl==0) then write(11,*)'Zero path',x0,y0,xt,yt,xcg,ycg stop endif ! Starting edge nel_j nel_j=0 do j=1,3 jd1=nm(nel,nx(j,1)) jd2=nm(nel,nx(j,2)) call intersect2(xcg,xt,x(jd1),x(jd2),ycg,yt,y(jd1),y(jd2),iflag,xin,yin,tt1,tt2) if(iflag==1) then nel_j=j exit endif enddo !j=1,3 if(nel_j==0) then write(11,*)'Found no intersecting edges I:',nel,xcg,ycg,xt,yt,ae stop endif zin=z0 !intialize it=0 loop4: do !---------------------------------------------------------------------------------------- it=it+1 if(it>1000) then if(ifort12(3)==0) then ifort12(3)=1 write(12,*)'Death trap reached',idt,id0 endif nfl=1 xt=xin yt=yin zt=zin nnel1=nel exit loop4 endif md1=nm(nel,nx(nel_j,1)) md2=nm(nel,nx(nel_j,2)) ! Compute z position dist=dsqrt((xin-xt)**2+(yin-yt)**2) if(dist/pathl.gt.1+1.0d-4) then write(11,*)'Path overshot' stop endif zin=zt-dist/pathl*(zt-zin) trm=trm*dist/pathl !time remaining pathl=dsqrt((xin-xt)**2+(yin-yt)**2) if(pathl==0.or.trm==0) then write(11,*)'Target reached' stop endif lit=0 !flag ! For horizontal exit and dry elements, compute tangential vel., ! update target (xt,yt,zt) and continue. if(ic3(nel,nel_j)==0.or.idry_e(ic3(nel,nel_j))==1) then lit=1 isd=js(nel,nel_j) if(isidenode(isd,1)+isidenode(isd,2)/=md1+md2) then write(11,*)'Wrong side' stop endif ! Nudge intersect (xin,yin), and update starting pt xin=(1-1.0d-4)*xin+1.0d-4*xctr(nel) yin=(1-1.0d-4)*yin+1.0d-4*yctr(nel) xcg=xin ycg=yin vtan=-su2(jlev0,isd)*sny(isd)+sv2(jlev0,isd)*snx(isd) xvel=-vtan*sny(isd) yvel=vtan*snx(isd) zvel=(ww2(jlev0,md1)+ww2(jlev0,md2))/2 xt=xin-xvel*trm yt=yin-yvel*trm zt=zin-zvel*trm hvel=dsqrt(xvel**2+yvel**2) if(hvel<1.e-4) then nfl=1 xt=xin yt=yin zt=zin nnel1=nel exit loop4 endif pathl=hvel*trm endif !abnormal cases ! Search for nel's neighbor with edge nel_j, or in abnormal cases, the same element if(lit==0) nel=ic3(nel,nel_j) !next front element aa=0 do i=1,3 k1=nm(nel,i) k2=nm(nel,nx(i,1)) aa=aa+dabs(signa(x(k1),x(k2),xt,y(k1),y(k2),yt)) enddo !i ae=dabs(aa-area(nel))/area(nel) if(ae=ztot(k).and.-dep=ztmp(nvrt)) then zt=ztmp(nvrt) zrat=0 jlev1=nvrt else jlev1=0 do k=kbpl,nvrt-1 if(zt>=ztmp(k).and.zt<=ztmp(k+1)) then jlev1=k+1 exit endif enddo !k if(jlev1==0) then write(11,*)'Cannot find a vert. level:',zt,etal,dep write(11,*)(ztmp(k),k=kbpl,nvrt) stop endif zrat=(ztmp(jlev1)-zt)/(ztmp(jlev1)-ztmp(jlev1-1)) endif if(zrat<0.or.zrat>1) then write(11,*)'Sigma coord. wrong (4):',jlev1,zrat stop endif if(kbpl==kz) then !in pure S region ss=(1-zrat)*sigma(jlev1-kz+1)+zrat*sigma(jlev1-kz) else ss=-99 endif ! if(sssigma(jlev1)) then ! write(11,*)'Sigma coord. wrong (5):',jlev1,ss,sigma(jlev1-1),sigma(jlev1) ! stop ! endif return end !-----------------------------------------------------------------------------------------------! ! ! ! Find first wet upwind element for rewetted points, and compute S,T. ! ! Use idry_e0 (from previous step) and S,T from previous step. ! ! Abnormal exit: death trap or a horizontal bnd is reached and vel.=0 there. ! ! ! !-----------------------------------------------------------------------------------------------! ! subroutine upwindtrack(id0,jlev,nnel,x0,y0,uuint,vvint,out2,nfl) use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) integer, intent(in) :: id0,jlev,nnel real(kind=dbl_kind), intent(in) :: x0,y0 real(kind=dbl_kind), intent(inout) :: uuint,vvint integer, intent(out) :: nfl real(kind=dbl_kind), intent(out) :: out2(12) nfl=0 !trap flag ! Starting element nel (must be dry) nel=nnel ! An interior pt close to (x0,y0) to prevent underflow xcg=(1-1.0d-4)*x0+1.0d-4*xctr(nel) ycg=(1-1.0d-4)*y0+1.0d-4*yctr(nel) ! Starting edge nel_j nel_j=0 do j=1,3 !side jd1=nm(nel,nx(j,1)) jd2=nm(nel,nx(j,2)) call intersect3(xcg,uuint,x(jd1),x(jd2),ycg,vvint,y(jd1),y(jd2),iflag,xin,yin,tt1,tt2) if(iflag==1) then nel_j=j exit endif enddo !j=1,3 if(nel_j==0) then write(11,*)'Found no intersecting edges III:',nel,xcg,ycg,uuint,vvint stop endif it=0 loop7: do !---------------------------------------------------------------------------------------- it=it+1 if(it>50) then if(ifort12(9)==0) then ifort12(9)=1 write(12,*)'Death trap reached in upwindtrack',id0 endif nfl=1 exit loop7 endif md1=nm(nel,nx(nel_j,1)) md2=nm(nel,nx(nel_j,2)) lit=0 !flag ! For horizontal exit, compute tangential vel, update target uunit & vvint, and continue. if(ic3(nel,nel_j)==0) then !.or.idry_e(ic3(nel,nel_j))==1) then lit=1 isd=js(nel,nel_j) if(isidenode(isd,1)+isidenode(isd,2)/=md1+md2) then write(11,*)'Wrong side' stop endif ! Nudge intersect (xin,yin), and update starting pt xin=(1-1.0d-4)*xin+1.0d-4*xctr(nel) yin=(1-1.0d-4)*yin+1.0d-4*yctr(nel) xcg=xin ycg=yin vtan=-su2(jlev,isd)*sny(isd)+sv2(jlev,isd)*snx(isd) xvel=-vtan*sny(isd) yvel=vtan*snx(isd) hvel=dsqrt(xvel**2+yvel**2) if(hvel==0) then nfl=1 exit loop7 endif uuint=xvel/hvel vvint=yvel/hvel endif !abnormal cases ! Search for nel's neighbor with edge nel_j, or in abnormal cases, the same element if(lit==0) nel=ic3(nel,nel_j) !next front element if(idry_e0(nel)==0) then isd0=0 do j=1,3 !side isd=js(nel,j) n1=isidenode(isd,1) n2=isidenode(isd,2) if(n1==md1.and.n2==md2.or.n1==md2.and.n2==md1) isd0=isd enddo if(isd0==0) then write(11,*)'Wrong connectivity (3)' stop endif if(tsd(jlev,isd0)<-98.or.ssd(jlev,isd0)<-98) then write(11,*)'Impossible dry (9)' stop endif out2(1)=tsd(jlev,isd0) out2(2)=ssd(jlev,isd0) exit loop7 endif ! Next intersecting edge do j=1,3 jd1=nm(nel,nx(j,1)) jd2=nm(nel,nx(j,2)) if(jd1==md1.and.jd2==md2.or.jd2==md1.and.jd1==md2) cycle call intersect3(xcg,uuint,x(jd1),x(jd2),ycg,vvint,y(jd1),y(jd2),iflag,xin,yin,tt1,tt2) if(iflag==1) then nel_j=j !next front edge cycle loop7 endif enddo !j write(11,*)'Failed to find next edge (4):',lit,xin,yin,nel,md1,md2,id0 stop !---------------------------------------------------------------------------------------- end do loop7 return end ! !******************************************************************************** ! * ! Program to detect if an infinite line (3,4) and a semi-infinite line * ! from pt 1 in (uuint,vvint) have common pts * ! Assumption: the 3 pts are distinctive. * ! The eq. for the infinite line is: X=X3+(X4-X3)*tt2 (-\infty =-small2.and.tt2<=1+small2) then iflag=1 xin=x3+(x4-x3)*tt2 yin=y3+(y4-y3)*tt2 endif endif return end ! !******************************************************************************** ! * ! Program to detect if two segments (1,2) and (3,4) have common pts * ! Assumption: the 4 pts are distinctive. * ! The eqs. for the 2 lines are: X=X1+(X2-X1)*tt1 and X=X3+(X4-X3)*tt2. * ! Output: iflag: 0: no intersection or colinear; 1: exactly 1 intersection. * ! If iflag=1, (xin,yin) is the intersection. * ! * !******************************************************************************** ! subroutine intersect2(x1,x2,x3,x4,y1,y2,y3,y4,iflag,xin,yin,tt1,tt2) use kind_par implicit real(kind=dbl_kind1)(a-h,o-z), integer(i-n) real(kind=dbl_kind1), parameter :: small2=0.0 !small positive number or 0 real(kind=dbl_kind1), intent(in) :: x1,x2,x3,x4,y1,y2,y3,y4 integer, intent(out) :: iflag real(kind=dbl_kind1), intent(out) :: xin,yin,tt1,tt2 tt1=-1000 tt2=-1000 iflag=0 delta=(x2-x1)*(y3-y4)-(y2-y1)*(x3-x4) delta1=(x3-x1)*(y3-y4)-(y3-y1)*(x3-x4) delta2=(x2-x1)*(y3-y1)-(y2-y1)*(x3-x1) if(delta/=0) then tt1=delta1/delta tt2=delta2/delta if(tt1>=-small2.and.tt1<=1+small2.and.tt2>=-small2.and.tt2<=1+small2) then iflag=1 xin=x1+(x2-x1)*tt1 yin=y1+(y2-y1)*tt1 endif endif return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! Compute area coordinates of pt (xt,yt), which must be inside element nnel. ! ! Impose bounds for area coordinates. ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine area_coord(nnel,xt,yt,arco) use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) integer, intent(in) :: nnel real(kind=dbl_kind), intent(in) :: xt,yt real(kind=dbl_kind), intent(out) :: arco(3) n1=nm(nnel,1) n2=nm(nnel,2) n3=nm(nnel,3) arco(1)=signa(xt,x(n2),x(n3),yt,y(n2),y(n3))/area(nnel) arco(2)=signa(x(n1),xt,x(n3),y(n1),yt,y(n3))/area(nnel) arco(1)=dmax1(0.0d0,dmin1(1.0d0,arco(1))) arco(2)=dmax1(0.0d0,dmin1(1.0d0,arco(2))) if(arco(1)+arco(2)>1) then arco(3)=0 arco(1)=dmin1(1.d0,dmax1(0.d0,arco(1))) arco(2)=1-arco(1) else arco(3)=1-arco(1)-arco(2) endif return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! Compute area coordinates of pt (xt,yt), which may not be inside element nnel. ! ! ifl=0: inside; =1: outside. ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine area_coord2(nnel,xt,yt,arco,ifl) use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) integer, intent(in) :: nnel integer, intent(out) :: ifl real(kind=dbl_kind), intent(in) :: xt,yt real(kind=dbl_kind), intent(out) :: arco(3) ifl=0 n1=nm(nnel,1) n2=nm(nnel,2) n3=nm(nnel,3) arco(1)=signa(xt,x(n2),x(n3),yt,y(n2),y(n3))/area(nnel) arco(2)=signa(x(n1),xt,x(n3),y(n1),yt,y(n3))/area(nnel) arco(3)=1-arco(1)-arco(2) if(arco(1)<0.or.arco(1)>1.or.arco(2)<0.or.arco(2)>1.or.arco(3)<0.or.arco(3)>1) ifl=1 return end ! !*************************************************************************** ! * ! Solve for the density at nodes and sides. * ! From Pond and Pickard's book. * ! validity region: T: [0,40], S: [0:42] * ! * !*************************************************************************** ! subroutine eqstate use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) den(t,s)=1000-0.157406+6.793952E-2*t-9.095290E-3*t**2 & &+1.001685E-4*t**3-1.120083E-6*t**4+6.536332E-9*t**5+ & &s*(0.824493-4.0899E-3*t+& &7.6438E-5*t**2-8.2467E-7*t**3+5.3875E-9*t**4)+& &dsqrt(s)**3*(-5.72466E-3+1.0227E-4*t-1.6546E-6*t**2)+& &4.8314E-4*s**2 prho=-99 !flags ! do l=1,2 !nodes & sides do l=1,1 !nodes only if(l==1) then limit=np else limit=ns endif do i=1,limit if(l==1.and.idry(i)==1.or.l==2.and.idry_s(i)==1) cycle ! Valid S,T do k=1,nvrt if(l==1) then !node ttmp=tnd(k,i) stmp=snd(k,i) else !side ttmp=tsd(k,i) stmp=ssd(k,i) endif if(ttmp<-98.or.stmp<-98) then write(11,*)'Impossible dry (7):',l,i,k,ttmp,stmp stop endif if(ttmptempmax.or.stmpsaltmax) then if(ifort12(6)==0) then ifort12(6)=1 write(12,*)'Invalid temp. or salinity for density' write(12,*)ttmp,stmp,l,i,k endif ttmp=dmax1(tempmin,dmin1(ttmp,tempmax)) stmp=dmax1(saltmin,dmin1(stmp,saltmax)) endif ! Density at one standard atmosphere rho=den(ttmp,stmp) if(rho<980) then write(11,*)'Weird density at:',l,i,k,rho,ttmp,stmp stop endif if(l==1) then prho(i,k)=rho sig_t(i,k)=rho-rho0 else if(l==2) then ! srho(i,k)=rho endif enddo !k=1,nvrt enddo !i=1,limit enddo !l=1,1 return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! Generic routine to compute \int_{\sigma_k}^{\sigma_{k+1}} \psi(\sigma)d\sigma, ! ! where Nmin<=k<=Nmax-1, \sigma & \psi(Nmin:Nmax), using Lagrangian ! ! interpolation of order 2*m (i.e., from k-m to k+m). ! ! mnv: dimensioning parameter from driving routine (input); ! ! Nmin, Nmax: limits of vertical levels (input); ! ! m: order of Lagrangian polynormial (input); ! ! k: input for limits; ! ! sigma,sigmap,sigma_prod,psi: input (sigmap&sigma_prod are the pre-computed ! ! powers and products of sigma for speed) ! ! gam, coef: working arrays (output). ! ! WARNING: Nmax must =nsig, and 1<=Nmin<=nsig-1 for sigma_prod!! ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! function rint_lag(mnv,Nmin,Nmax,m,k,sigma,sigmap,sigma_prod,psi,gam,coef) implicit real*8(a-h,o-z) integer, intent(in) :: mnv,Nmin,Nmax,m,k real(kind=8), intent(in) :: sigma(mnv),sigmap(mnv,10),sigma_prod(mnv,mnv,-4:4),psi(mnv) real(kind=8), intent(out) :: gam(mnv),coef(0:mnv) ! Sanity check if(Nmin>=Nmax.or.Nmax>mnv.or.Nmin<1) then write(11,*)'Check inputs in rint_lag:',Nmin,Nmax stop endif if(k>Nmax-1.or.k3) then write(*,*)'m>3 not covered presently' stop endif if(2*m+1>10) then write(11,*)'Re-dimension sigmap' stop endif ! Compute J1,2 j1=max0(Nmin,k-m) j2=min0(Nmax,k+m) if(j1>=j2) then write(11,*)'Weird indices:',j1,j2 stop endif ! Compute sum rint_lag=0 do i=j1,j2 ! Denominator & assemble working array gam ! prod=1 id=0 do j=j1,j2 if(j/=i) then id=id+1 gam(id)=-sigma(j) endif enddo !j if(id/=j2-j1.or.id>2*m) then write(11,*)'Miscount:',id,j2-j1,m stop endif ! Inner sum if(id==1) then coef(0)=gam(1); coef(1)=1 else if(id==2) then coef(0)=gam(1)*gam(2) coef(1)=gam(1)+gam(2) coef(2)=1 else if(id==3) then coef(0)=gam(1)*gam(2)*gam(3) coef(1)=gam(1)*(gam(2)+gam(3))+gam(2)*gam(3) coef(2)=gam(1)+gam(2)+gam(3) coef(3)=1 else if(id==4) then coef(0)=gam(1)*gam(2)*gam(3)*gam(4) coef(1)=gam(1)*gam(2)*(gam(3)+gam(4))+(gam(1)+gam(2))*gam(3)*gam(4) coef(2)=gam(1)*(gam(2)+gam(3))+(gam(1)+gam(3))*gam(4)+gam(2)*(gam(3)+gam(4)) ! coef(2)=gam(1)*gam(2)+gam(1)*gam(3)+gam(1)*gam(4)+gam(2)*gam(3)+gam(2)*gam(4)+gam(3)*gam(4) coef(3)=gam(1)+gam(2)+gam(3)+gam(4) coef(4)=1 else if(id==5) then coef(0)=gam(1)*gam(2)*gam(3)*gam(4)*gam(5) coef(1)=gam(1)*gam(2)*gam(3)*gam(4)+gam(1)*gam(2)*gam(3)*gam(5)+gam(1)*gam(2)*gam(4)*gam(5)+ & &gam(1)*gam(3)*gam(4)*gam(5)+gam(2)*gam(3)*gam(4)*gam(5) coef(2)=gam(1)*gam(2)*gam(3)+gam(1)*gam(2)*gam(4)+gam(1)*gam(2)*gam(5)+gam(1)*gam(3)*gam(4)+ & &gam(1)*gam(3)*gam(5)+gam(1)*gam(4)*gam(5)+gam(2)*gam(3)*gam(4)+gam(2)*gam(3)*gam(5)+ & &gam(2)*gam(4)*gam(5)+gam(3)*gam(4)*gam(5) coef(3)=gam(1)*gam(2)+gam(1)*gam(3)+gam(1)*gam(4)+gam(1)*gam(5)+gam(2)*gam(3)+ & &gam(2)*gam(4)+gam(2)*gam(5)+gam(3)*gam(4)+gam(3)*gam(5)+gam(4)*gam(5) coef(4)=gam(1)+gam(2)+gam(3)+gam(4)+gam(5) coef(5)=1 else if(id==6) then coef(0)=gam(1)*gam(2)*gam(3)*gam(4)*gam(5)*gam(6) coef(1)=gam(1)*gam(2)*gam(3)*gam(4)*gam(5)+gam(1)*gam(2)*gam(3)*gam(4)*gam(6)+& &gam(1)*gam(2)*gam(3)*gam(5)*gam(6)+gam(1)*gam(2)*gam(4)*gam(5)*gam(6)+ & &gam(1)*gam(3)*gam(4)*gam(5)*gam(6)+gam(2)*gam(3)*gam(4)*gam(5)*gam(6) coef(2)=gam(1)*gam(2)*gam(3)*gam(4)+gam(1)*gam(2)*gam(3)*gam(5)+gam(1)*gam(2)*gam(3)*gam(6)+ & &gam(1)*gam(2)*gam(4)*gam(5)+gam(1)*gam(2)*gam(4)*gam(6)+gam(1)*gam(2)*gam(5)*gam(6)+ & &gam(1)*gam(3)*gam(4)*gam(5)+gam(1)*gam(3)*gam(4)*gam(6)+gam(1)*gam(3)*gam(5)*gam(6)+ & &gam(1)*gam(4)*gam(5)*gam(6)+gam(2)*gam(3)*gam(4)*gam(5)+gam(2)*gam(3)*gam(4)*gam(6)+ & &gam(2)*gam(3)*gam(5)*gam(6)+gam(2)*gam(4)*gam(5)*gam(6)+gam(3)*gam(4)*gam(5)*gam(6) coef(3)=gam(1)*gam(2)*gam(3)+gam(1)*gam(2)*gam(4)+gam(1)*gam(2)*gam(5)+ & &gam(1)*gam(2)*gam(6)+gam(1)*gam(3)*gam(4)+gam(1)*gam(3)*gam(5)+gam(1)*gam(3)*gam(6)+ & &gam(1)*gam(4)*gam(5)+gam(1)*gam(4)*gam(6)+gam(1)*gam(5)*gam(6)+gam(2)*gam(3)*gam(4)+ & &gam(2)*gam(3)*gam(5)+gam(2)*gam(3)*gam(6)+gam(2)*gam(4)*gam(5)+gam(2)*gam(4)*gam(6)+ & &gam(2)*gam(5)*gam(6)+gam(3)*gam(4)*gam(5)+gam(3)*gam(4)*gam(6)+gam(3)*gam(5)*gam(6)+ & &gam(4)*gam(5)*gam(6) coef(4)=gam(1)*gam(2)+gam(1)*gam(3)+gam(1)*gam(4)+gam(1)*gam(5)+gam(1)*gam(6)+ & &gam(2)*gam(3)+gam(2)*gam(4)+gam(2)*gam(5)+gam(2)*gam(6)+gam(3)*gam(4)+gam(3)*gam(5)+ & &gam(3)*gam(6)+gam(4)*gam(5)+gam(4)*gam(6)+gam(5)*gam(6) coef(5)=gam(1)+gam(2)+gam(3)+gam(4)+gam(5)+gam(6) coef(6)=1 else write(*,*)'Not covered:',id stop endif sum=0 do l=0,id sum=sum+coef(l)/(l+1)*(sigmap(k+1,l+1)-sigmap(k,l+1)) enddo !l if(abs(i-k)>4) then write(11,*)'sigma_prod index out of bound (2)' stop endif rint_lag=rint_lag+psi(i)/sigma_prod(Nmin,k,i-k)*sum enddo !i=j1,j2 return end ! !*************************************************************************** ! * ! Convert normal vel. to 3D nodal vel. at WHOLE levels. * ! * !*************************************************************************** ! subroutine nodalvel(ifltype) use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) integer, intent(in) :: ifltype(mnope) dimension swild(10),swild2(mnv,10),swild3(mnv) !swild2's dimension must match vinter() ! Compute discontinuous hvel first (used in btrack) ufg=0; vfg=0 do i=1,ne do k=1,nvrt do j=1,3 nd=nm(i,j) isd0=js(i,j) isd1=js(i,nx(j,1)) isd2=js(i,nx(j,2)) ufg(k,i,j)=su2(k,isd1)+su2(k,isd2)-su2(k,isd0) vfg(k,i,j)=sv2(k,isd1)+sv2(k,isd2)-sv2(k,isd0) ! Error: impose bounds for ufg, vfg? enddo !j enddo !k enddo !i=1,ne if(indvel==0) then !------------------------------------------------------------------------------- uu2=0; vv2=0; ww2=0 !initialize and for dry nodes etc. do i=1,np if(idry(i)==1) cycle ! Wet node do k=kbp(i),nvrt weit_w=0 icount=0 do j=1,nne(i) ie=ine(i,j) id=iself(i,j) if(idry_e(ie)==0) then icount=icount+1 uu2(k,i)=uu2(k,i)+ufg(k,ie,id) vv2(k,i)=vv2(k,i)+vfg(k,ie,id) endif ! if(.not.(isbnd(i)>0.and.ifltype(isbnd(i))/=0.and.isbs(isd)/=isbnd(i))) then if(interpol(ie)==1) then !along Z if(idry_e(ie)==1) then swild(1)=0 else !wet eleemnt; node i is also wet kbb=kbe(ie) swild3(kbb:nvrt)=ze(kbb:nvrt,ie) swild2(kbb:nvrt,1)=we(kbb:nvrt,ie) call vinter(mnv,1,z(k,i),kbb,nvrt,k,swild3,swild2,swild,ibelow) endif else !along S swild(1)=we(k,ie) endif !Z or S ww2(k,i)=ww2(k,i)+swild(1)*area(ie) weit_w=weit_w+area(ie) enddo !j if(icount==0) then write(11,*)'Isolated wet node (8):',i stop else uu2(k,i)=uu2(k,i)/icount vv2(k,i)=vv2(k,i)/icount endif ww2(k,i)=ww2(k,i)/weit_w enddo !k=kbp(i),nvrt ! Extend do k=1,kbp(i)-1 uu2(k,i)=0 !uu2(kbp(i),i) vv2(k,i)=0 !vv2(kbp(i),i) ww2(k,i)=0 !ww2(kbp(i),i) enddo !k enddo !i=1,np !------------------------------------------------------------------------------- else !indvel=1: averaging vel. !------------------------------------------------------------------------------- uu2=0; vv2=0; ww2=0 !initialize and for dry nodes etc. do i=1,np if(idry(i)==1) cycle ! Wet node icase=2 do j=1,nne(i) ie=ine(i,j) if(interpol(ie)==1) icase=1 enddo !j do k=kbp(i),nvrt weit=0 icount=0 weit_w=0 do j=1,nne(i) ie=ine(i,j) id=iself(i,j) if(isbnd(i)/=0) then !bnd ball limit=1 else !internal ball limit=2 endif do l=2,limit,-1 isd=js(ie,nx(id,l)) if(.not.(isbnd(i)>0.and.ifltype(isbnd(i))/=0.and.isbs(isd)/=isbnd(i))) then if(icase==1) then !along Z if(idry_s(isd)==1) then swild(1:2)=0 else !wet side; node i is also wet kbb=kbs(isd) swild2(kbb:nvrt,1)=su2(kbb:nvrt,isd) swild2(kbb:nvrt,2)=sv2(kbb:nvrt,isd) swild3(kbb:nvrt)=zs(kbb:nvrt,isd) call vinter(mnv,2,z(k,i),kbb,nvrt,k,swild3,swild2,swild,ibelow) endif else !along S swild(1)=su2(k,isd) swild(2)=sv2(k,isd) endif !Z or S icount=icount+1 uu2(k,i)=uu2(k,i)+swild(1)/distj(isd) vv2(k,i)=vv2(k,i)+swild(2)/distj(isd) weit=weit+1/distj(isd) endif enddo !l if(interpol(ie)==1) then !along Z if(idry_e(ie)==1) then swild(1)=0 else !wet eleemnt; node i is also wet kbb=kbe(ie) swild3(kbb:nvrt)=ze(kbb:nvrt,ie) swild2(kbb:nvrt,1)=we(kbb:nvrt,ie) call vinter(mnv,1,z(k,i),kbb,nvrt,k,swild3,swild2,swild,ibelow) endif else !along S swild(1)=we(k,ie) endif !Z or S ww2(k,i)=ww2(k,i)+swild(1)*area(ie) weit_w=weit_w+area(ie) enddo !j if(icount==0) then write(11,*)'Isolated open bnd node:',i,isbnd(i) stop endif uu2(k,i)=uu2(k,i)/weit vv2(k,i)=vv2(k,i)/weit ww2(k,i)=ww2(k,i)/weit_w enddo !k=kbp(i),nvrt ! Extend do k=1,kbp(i)-1 uu2(k,i)=0 !uu2(kbp(i),i) vv2(k,i)=0 !vv2(kbp(i),i) ww2(k,i)=0 !ww2(kbp(i),i) enddo !k enddo !i=1,np !------------------------------------------------------------------------------- endif !discontinous or averaging vel. !... Compute discrepancy between avergaed and elemental vel. vectors ! do i=1,np ! do k=1,nvrt ! testa(i,k)=0 ! do j=1,nne(i) ! iel=ine(i,j) ! index=0 ! do l=1,3 ! if(nm(iel,l).eq.i) index=l ! enddo !l ! if(index.eq.0) then ! write(*,*)'Wrong element ball' ! stop ! endif ! testa(i,k)=testa(i,k)+dsqrt((uuf(iel,index,k)-uu2(k,i))**2+ ! +(vvf(iel,index,k)-vv2(k,i))**2)/nne(i) ! enddo !j ! enddo !k ! enddo !i return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! Algebraic Stress Models ! ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! subroutine asm(g,i,j,vd,td,qd1,qd2) use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) integer, intent(in) :: i,j real(kind=dbl_kind), intent(in) :: g real(kind=dbl_kind), intent(out) :: vd,td,qd1,qd2 if(jnvrt) then write(11,*)'Wrong input level:',j stop endif ! Wet node i with prho defined; kbp(i)<=j<=nvrt if(j==kbp(i).or.j==nvrt) then drho_dz=0 else drho_dz=(prho(i,j+1)-prho(i,j-1))/(z(j+1,i)-z(j-1,i)) endif bvf=g/rho0*drho_dz Gh=xl(i,j)**2/2/q2(i,j)*bvf Gh=dmin1(dmax1(Gh,-0.28d0),0.0233d0) if(stab.eq.'GA') then sh=0.49393/(1-34.676*Gh) sm=(0.39327-3.0858*Gh)/(1-34.676*Gh)/(1-6.1272*Gh) cmiu=dsqrt(2.d0)*sm cmiup=dsqrt(2.d0)*sh cmiu1=dsqrt(2.d0)*0.2 !for k-eq cmiu2=dsqrt(2.d0)*0.2 !for psi-eq. else if(stab.eq.'KC') then !Kantha and Clayson ! Error: Warner's paper wrong ! Ghp=(Gh-(Gh-0.02)**2)/(Gh+0.0233-0.04) !smoothing Ghp=Gh sh=0.4939/(1-30.19*Ghp) sm=(0.392+17.07*sh*Ghp)/(1-6.127*Ghp) cmiu=dsqrt(2.d0)*sm cmiup=dsqrt(2.d0)*sh cmiu1=cmiu/schk cmiu2=cmiu/schpsi else write(11,*)'Unknown ASM:',mid stop endif vd=cmiu*xl(i,j)*dsqrt(q2(i,j)) td=cmiup*xl(i,j)*dsqrt(q2(i,j)) qd1=cmiu1*xl(i,j)*dsqrt(q2(i,j)) qd2=cmiu2*xl(i,j)*dsqrt(q2(i,j)) return end ! Routine to do vertical interpolation in z ! Inputs: ! mnv: dimensioning paramter for za etc. ! nc: actual # of variables ! k1,k2: lower and upper limits for za, sint ! k3: initial guess for level index (to speed up) ! zt: desired interpolation level ! za(k1:k2): z-cor for sint (must be in ascending order) ! sint(k1:k2,1:nc): values to be interpolated from; dimensions must match driving program ! Outputs: ! sout(1:nc): interpolated value @ z=zt (bottom value if ibelow=1) ! ibelow: flag indicating if zt is below za(k1) ! subroutine vinter(mnv,nc,zt,k1,k2,k3,za,sint,sout,ibelow) use kind_par implicit real(kind=dbl_kind1)(a-h,o-z),integer(i-n) integer, intent(in) :: mnv,nc,k1,k2,k3 integer, intent(out) :: ibelow real(kind=dbl_kind1), intent(in) :: zt,za(mnv),sint(mnv,10) real(kind=dbl_kind1), intent(out) :: sout(10) if(k1>k2.or.nc>10) then write(11,*)'k1>k2 in vinter()' stop endif if(zt=za(k2)) then sout(1:nc)=sint(k2,1:nc) else kout=0 !flag if(k3k2) then l1=k1; l2=k2-1 else if(zt=za(k).and.zt<=za(k+1)) then kout=k exit endif enddo !k if(kout==0.or.za(kout+1)-za(kout)==0) then write(11,*)'Failed to find a level in vinter():',kout,zt,(za(k),k=k1,k2) stop endif zrat=(zt-za(kout))/(za(kout+1)-za(kout)) sout(1:nc)=sint(kout,1:nc)*(1-zrat)+sint(kout+1,1:nc)*zrat endif endif return end ! Flux limiter functions used in TVD schemes function flux_lim(ss,flimiter) implicit real*8(a-h,o-z) character(len=2) :: flimiter if(flimiter.eq.'SB') then !Superbee flux_lim=max(0.d0,min(1.d0,2*ss),min(2.d0,ss)) else if(flimiter.eq.'MM') then !MINMOD flux_lim=max(0.d0,min(1.d0,ss)) else if(flimiter.eq.'OS') then !OSHER flux_lim=max(0.d0,min(2.d0,ss)) else if(flimiter.eq.'VL') then !Van Leer flux_lim=(ss+abs(ss))/(1+abs(ss)) else write(11,*)'Unknown limiter:',flimiter stop endif return end ! Compute local index of a side (0 if not a local side) function lindex_s(i,ie) use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) integer, intent(in) :: i,ie l0=0 !local index do l=1,3 if(js(ie,l)==i) then l0=l exit endif enddo !l lindex_s=l0 return end ! Compute local index of a node (0 if not a local node) function lindex(i,ie) use global implicit real(kind=dbl_kind)(a-h,o-z),integer(i-n) integer, intent(in) :: i,ie l0=0 !local index do l=1,3 if(nm(ie,l)==i) then l0=l exit endif enddo !l lindex=l0 return end function covar(kr_co,decor,hh) implicit real*8(a-h,o-z) if(hh<0) then write(11,*)'Negative hh in covar:',hh stop endif if(kr_co==1) then covar=-hh else if(kr_co==2) then if(hh==0) then covar=0 else covar=hh*hh*dlog(hh) endif else if(kr_co==3) then covar=hh*hh*hh else if(kr_co==4) then h2=hh*hh covar=-h2*h2*hh else if(kr_co==5) then covar=dexp(-hh*hh/decor/decor) else write(11,*)'Unknown covariance function option:',kr_co stop endif return end ! ----------------------------------------------------------------------- ! *** Gauss elimination routine with full pivoting ! *** ! Input: ! a(np,np) (in/out): original and inverted square matrix; ! n: actual rank of a and b; ! np: dimension of a and b (must match the driving routine); ! b(np,mp) (in/out): RHS or solution vectors; ! m: actual # of columns on the RHS ! mp: used in dimensioning of RHS b (must match the driving routine); subroutine gaussj(a,n,np,b,m,mp) implicit real*8(a-h,o-z) parameter (nmax=50000) dimension a(np,np),b(np,mp),ipiv(nmax),indxr(nmax),indxc(nmax) ! Check dimension if(nmax= ne); ! swild4(:,:,1:2): original horizontal flux (1: the local x-driection) and vertical flux (2: positive upward) ! ptbt(:,:,1:4): upwind ratios for T,S (order follows sdbt) ! sdbt(:,:,1:4): limited horizontal flux (1 & 3 (for T,S); in the local x-driection) and vertical flux (2 & 4: positive upward) ! Check if(ntr>100) then write(11,*)'Too many tracers:',ntr stop endif ! For rewetted elements, tr_el takes the value from last wet step ! Compute (pre-limiting) fluxes at all faces flx_adv=-1.e34 !flags do i=1,ne if(idry_e(i)==1) cycle ! Wet element with 3 wet nodes ! Compute upward normals and areas @ all levels n1=nm(i,1) n2=nm(i,2) n3=nm(i,3) isd1=js(i,1) isd2=js(i,2) isd3=js(i,3) if(kbe(i)==0) then write(11,*)'Impossible 95 (2)' stop endif do l=kbe(i),nvrt xcon=(y(n2)-y(n1))*(z(l,n3)-z(l,n1))-(y(n3)-y(n1))*(z(l,n2)-z(l,n1)) ycon=(x(n3)-x(n1))*(z(l,n2)-z(l,n1))-(x(n2)-x(n1))*(z(l,n3)-z(l,n1)) zcon=area(i)*2 area_e(l)=dsqrt(xcon**2+ycon**2+zcon**2)/2 if(area_e(l)==0) then write(11,*)'Zero area (2):',i,l stop endif sne(l,1)=xcon/area_e(l)/2 sne(l,2)=ycon/area_e(l)/2 sne(l,3)=zcon/area_e(l)/2 !>0 enddo !l ! Compute vertical fluxes first do k=kbe(i),nvrt if(k==kbe(i)) then !bottom normal vel. is we(kbe(i),i) dot1=we(kbe(i),i) else dot1=(su2(k,isd1)+su2(k,isd2)+su2(k,isd3))/3*sne(k,1)+ & !upward normal vel. & (sv2(k,isd1)+sv2(k,isd2)+sv2(k,isd3))/3*sne(k,2)+we(k,i)*sne(k,3) endif flx_adv(i,k,2)=dot1*area_e(k) !vertical flux (positive upward) ! Debug ! if(it==46.and.i==58422) write(99,*)k,we(k,i),dot1,area_e(k),flx_adv(i,k,2) if(k/=kbe(i)) swild(k)=flx_adv(i,k,2)-flx_adv(i,k-1,2) !local volume conservation ! Limit flux later enddo !k=kbe(i),nvrt ! Horizontal fluxes do j=1,3 !side jsj=js(i,j) iel=ic3(i,j) do k=kbe(i)+1,nvrt if(flx_adv(jsj,k,1)>-1.e33) cycle !already computed if(iel==0.and.isbs(jsj)==0) then !land flx_adv(jsj,k,1)=0 cycle endif ! Check near bottom vel. tmp=dabs(su2(k,jsj))+dabs(sv2(k,jsj))+dabs(su2(k-1,jsj))+dabs(sv2(k-1,jsj)) if(iel/=0.and.k0) then kup=k !upwind prism kdo=k+1 !downwind prism else kup=k+1 kdo=k endif psum=0 !sum of original fluxes psumtr(1:ntr)=0 !sum of products if(flx_adv(i,kup,2)<-1.e33.or.flx_adv(i,kup-1,2)<-1.e33) then write(11,*)'Left out vertical flux (4):',i,kup stop endif if(flx_adv(i,kup,2)<0.and.kup/=nvrt) then psum=psum+abs(flx_adv(i,kup,2)) psumtr(1:ntr)=psumtr(1:ntr)+abs(flx_adv(i,kup,2))*(tr_el(kup+1,i,1:ntr)-tr_el(kup,i,1:ntr)) endif if(flx_adv(i,kup-1,2)>0.and.kup/=kbe(i)+1) then psum=psum+abs(flx_adv(i,kup-1,2)) psumtr(1:ntr)=psumtr(1:ntr)+abs(flx_adv(i,kup-1,2))*(tr_el(kup-1,i,1:ntr)-tr_el(kup,i,1:ntr)) endif do j=1,3 jsj=js(i,j) ie=ic3(i,j) if(flx_adv(jsj,kup,1)<-1.e33) then write(11,*)'Left out horizontal flux (5):',jsj,kup stop endif if(ie/=0.and.idry_e(ie)==0.and.ssign(i,j)*flx_adv(jsj,kup,1)<0) then psum=psum+abs(flx_adv(jsj,kup,1)) psumtr(1:ntr)=psumtr(1:ntr)+abs(flx_adv(jsj,kup,1))*(tr_el(kup,ie,1:ntr)-tr_el(kup,i,1:ntr)) endif enddo !j if(tvd_mid.eq.'AA') then !my formulation do j=1,ntr tmp=(tr_el(kup,i,j)-tr_el(kdo,i,j))*abs(flx_adv(i,k,2)) if(abs(tmp)>1.e-20) up_rat(i,k,j,2)=psumtr(j)/tmp enddo !j else if(tvd_mid.eq.'CC') then !Casulli's do j=1,ntr tmp=(tr_el(kup,i,j)-tr_el(kdo,i,j))*psum if(abs(tmp)>1.e-20) up_rat(i,k,j,2)=psumtr(j)/tmp enddo !j else write(11,*)'Unknown tvd_mid:',tvd_mid stop endif if(flux_lim(up_rat(i,k,1,2),flimiter)>0.1) ntot_v=ntot_v+1 enddo !k=kbe(i)+1,nvrt-1 enddo !i=1,ne ! Horizontal limiters ntot_h=0 !total # of horizontal faces that have large limiters (for 1st tracer) do i=1,ns if(idry_s(i)==1) cycle ! At least one element is wet up_rat(i,1:mnv,1:ntr,1)=-1 !initialize (for below bottom etc) if(is(i,2)==0.or.idry_e(is(i,2))==1.or.idry_e(is(i,1))==1) cycle ! Not bnd face; 2 elements are wet kb1=min(kbe(is(i,1)),kbe(is(i,2))) kb=max(kbe(is(i,1)),kbe(is(i,2))) do k=kb1+1,kb-1 if(flx_adv(i,k,1)/=0) then write(11,*)'Pls zero out the excess layers:',flx_adv(i,k,1),i,is(i,1),is(i,2),k,kb1,kb stop endif enddo !k ! Leave k=kb unchanged do k=kb+1,nvrt !prisms if(flx_adv(i,k,1)<-1.e33) then write(11,*)'Left out horizontal flux (3):',i,k stop else if(flx_adv(i,k,1)>0) then iup=is(i,1); ido=is(i,2) else iup=is(i,2); ido=is(i,1) endif psum=0 psumtr(1:ntr)=0 if(flx_adv(iup,k,2)<-1.e33.or.flx_adv(iup,k-1,2)<-1.e33) then write(11,*)'Left out vertical flux (6):',iup,k stop endif if(flx_adv(iup,k,2)<0.and.k/=nvrt) then psum=psum+abs(flx_adv(iup,k,2)) psumtr(1:ntr)=psumtr(1:ntr)+abs(flx_adv(iup,k,2))*(tr_el(k+1,iup,1:ntr)-tr_el(k,iup,1:ntr)) endif if(flx_adv(iup,k-1,2)>0.and.k>kbe(iup)+1) then psum=psum+abs(flx_adv(iup,k-1,2)) psumtr(1:ntr)=psumtr(1:ntr)+abs(flx_adv(iup,k-1,2))*(tr_el(k-1,iup,1:ntr)-tr_el(k,iup,1:ntr)) endif do j=1,3 jsj=js(iup,j) ie=ic3(iup,j) if(flx_adv(jsj,k,1)<-1.e33) then write(11,*)'Left out horizontal flux (6):',jsj,k stop endif if(ie/=0.and.idry_e(ie)==0.and.ssign(iup,j)*flx_adv(jsj,k,1)<0) then psum=psum+abs(flx_adv(jsj,k,1)) psumtr(1:ntr)=psumtr(1:ntr)+abs(flx_adv(jsj,k,1))*(tr_el(k,ie,1:ntr)-tr_el(k,iup,1:ntr)) endif enddo !j if(tvd_mid.eq.'AA') then do j=1,ntr tmp=(tr_el(k,iup,j)-tr_el(k,ido,j))*abs(flx_adv(i,k,1)) if(abs(tmp)>1.e-20) up_rat(i,k,j,1)=psumtr(j)/tmp enddo !j else !model CC do j=1,ntr tmp=(tr_el(k,iup,j)-tr_el(k,ido,j))*psum if(abs(tmp)>1.e-20) up_rat(i,k,j,1)=psumtr(j)/tmp enddo !j endif if(flux_lim(up_rat(i,k,1,1),flimiter)>0.1) ntot_h=ntot_h+1 enddo !k=kb+1,nvrt enddo !i=1,ns ! Debug ! if(it==1.and.it_sub==1) then ! do i=1,ne ! do j=1,3 ! jsj=js(i,j) ! write(99,*)is(jsj,1),is(jsj,2),up_rat(jsj,nvrt,1) ! enddo !j ! enddo !i ! stop ! endif ! Modifed fluxes flx_mod (their signs do not change) ! Vertical fluxes do i=1,ne if(idry_e(i)==1) cycle do k=kbe(i)+1,nvrt-1 !leave out the bnd ! Compute \delta_i if(flx_adv(i,k,2)>0) then kup=k !upwind prism else kup=k+1 endif delta_tr(1:ntr)=0 do l=0,1 !two vertical faces if(flx_adv(i,kup-l,2)*(1-2*l)>0) then !outflow do j=1,ntr rat=up_rat(i,kup-l,j,2) if(rat<-1.e33) then write(11,*)'Left out (1):',i,kup-l,rat,it_sub,j stop else if(rat/=0) then tmp=flux_lim(rat,flimiter)/rat/2 if(tmp<0.or.tmp>1) then write(11,*)'Flux limiting failed (1):',tmp,rat,flx_adv(i,kup-l,2),l,kup stop endif delta_tr(j)=delta_tr(j)+tmp endif enddo !j=1,ntr endif !outflow face enddo !l=0,1 do j=1,3 jsj=js(i,j) ie=ic3(i,j) if(ssign(i,j)*flx_adv(jsj,kup,1)>0) then do jj=1,ntr rat=up_rat(jsj,kup,jj,1) if(rat<-1.e33) then write(11,*)'Left out (3):',i,j,kup,rat,jj stop else if(rat/=0) then tmp=flux_lim(rat,flimiter)/rat/2 if(tmp<0.or.tmp>1) then write(11,*)'Flux limiting failed (3):',tmp,rat,jj stop endif delta_tr(jj)=delta_tr(jj)+tmp endif enddo !jj=1,ntr endif enddo !j=1,3 do j=1,ntr flx_mod(i,k,j,2)=flx_adv(i,k,2)*(1-flux_lim(up_rat(i,k,j,2),flimiter)/2+delta_tr(j)) enddo !j enddo !k=kbe(i)+1,nvrt-1 enddo !i=1,ne ! Horizontal fluxes do i=1,ns if(idry_s(i)==1.or.is(i,2)==0.or.idry_e(is(i,1))==1.or.idry_e(is(i,2))==1) cycle ! Both elements are wet kb=max(kbe(is(i,1)),kbe(is(i,2))) do k=kb+1,nvrt if(flx_adv(i,k,1)>0) then iup=is(i,1) else iup=is(i,2) endif delta_tr(1:ntr)=0 do l=0,1 !two vertical faces if(flx_adv(iup,k-l,2)*(1-2*l)>0) then !outflow do j=1,ntr rat=up_rat(iup,k-l,j,2) if(rat<-1.e33) then write(11,*)'Left out (5):',iup,k-l,rat,j stop else if(rat/=0) then tmp=flux_lim(rat,flimiter)/rat/2 if(tmp<0.or.tmp>1) then write(11,*)'Flux limiting failed (5):',tmp,rat,j stop endif delta_tr(j)=delta_tr(j)+tmp endif enddo !j=1,ntr endif !outflow face enddo !l=0,1 do j=1,3 jsj=js(iup,j) ie=ic3(iup,j) if(ssign(iup,j)*flx_adv(jsj,k,1)>0) then !outflow do jj=1,ntr rat=up_rat(jsj,k,jj,1) if(rat<-1.e33) then write(11,*)'Left out (7):',iup,ie,k,rat,jj stop else if(rat/=0) then tmp=flux_lim(rat,flimiter)/rat/2 if(tmp<0.or.tmp>1) then write(11,*)'Flux limiting failed (7):',tmp,rat,jj stop endif delta_tr(jj)=delta_tr(jj)+tmp endif enddo !jj=1,ntr endif !outflow enddo !j=1,3 do j=1,ntr flx_mod(i,k,j,1)=flx_adv(i,k,1)*(1-flux_lim(up_rat(i,k,j,1),flimiter)/2+delta_tr(j)) enddo !j enddo !k=kb+1,nvrt enddo !i=1,ns endif !flux limiter ! Compute sub time step ! Strike out \hat{S}^- (including all horizontal and vertical bnds, and where ic3(i,j) is dry) ! Causion: \hat{S}^- conditions must be consistent later in the advective flux part!!!!!! ! Implicit vertical flux for upwind; explicit for TVD if(up_tvd.or.it_sub==1) then !for upwind, only compute dtb for the first step dtb=time_r dtb_alt=time_r !alternative for TVD (more restrictive) ie01=0 !element # where the exteme is attained lev01=0 !level # in_st=0 !tracer # do i=1,ne if(idry_e(i)==1) cycle do k=kbe(i)+1,nvrt !prism qj=0 !sum of original fluxes for all inflow bnds psumtr(1:ntr)=0 !sum of modified fluxes for all inflow bnds nplus=0 !# of outflow bnds if(up_tvd) then !neither can be upwind any more if(k/=nvrt.and.flx_mod(i,k,1,2)<0) then !flx_mod and flx_adv same sign qj=qj+abs(flx_adv(i,k,2)) psumtr(1:ntr)=psumtr(1:ntr)+abs(flx_mod(i,k,1:ntr,2)) ! Debug ! if(it==46.and.it_sub==1.and.i==58422) write(99,*)k,flx_adv(i,k,2),flx_mod(i,k,2) endif if(k-1/=kbe(i).and.flx_mod(i,k-1,1,2)>0) then qj=qj+abs(flx_adv(i,k-1,2)) psumtr(1:ntr)=psumtr(1:ntr)+abs(flx_mod(i,k-1,1:ntr,2)) ! Debug ! if(it==46.and.it_sub==1.and.i==58422) write(99,*)k,flx_adv(i,k-1,2),flx_mod(i,k-1,2) endif endif !flux limiter if(k/=nvrt.and.flx_adv(i,k,2)>0) nplus=nplus+1 if(k-1/=kbe(i).and.flx_adv(i,k-1,2)<0) nplus=nplus+1 do j=1,3 jsj=js(i,j) ie=ic3(i,j) do jj=1,ntr if(flx_mod(jsj,k,jj,1)<-1.e33) then write(11,*)'Left out horizontal flux (10):',i,k,j,jj stop endif enddo !jj=1,ntr if(ie/=0.and.idry_e(ie)==0) then if(ssign(i,j)*flx_mod(jsj,k,1,1)<0) then !flx_mod(:) same sign as flx_adv qj=qj+abs(flx_adv(jsj,k,1)) psumtr(1:ntr)=psumtr(1:ntr)+abs(flx_mod(jsj,k,1:ntr,1)) ! Debug ! if(it==46.and.it_sub==1.and.i==58422) write(99,*)j,k,flx_adv(jsj,k,1),flx_mod(jsj,k,1) endif if(ssign(i,j)*flx_adv(jsj,k,1)>0) nplus=nplus+1 endif enddo !j vj=area(i)*(ze(k,i)-ze(k-1,i)) ! Debug ! if(it==46.and.it_sub==1.and.i==58422) write(99,*)k,nplus,vj do jj=1,ntr if(psumtr(jj)/=0) then tmp=vj/psumtr(jj)*(1-1.e-6) !safety factor included if(tmptime_r) then write(11,*)'Illegal sub step:',dtb,time_r stop endif ! Output time step if(up_tvd) write(18,*)it,it_sub,dtb,dtb_alt,ie01,lev01,in_st endif !compute dtb dtb=min(dtb,time_r) !for upwind time_r=time_r-dtb ! Store last step's S,T trel_tmp=tr_el do i=1,ne if(idry_e(i)==1) cycle ! Wet elements with 3 wet nodes n1=nm(i,1) n2=nm(i,2) n3=nm(i,3) ! Check if having a dry neighbor (interface) ! Interface element will not be subject to ELAD because the vel. there may be altered by levels()? ! iedge=0 !flag ! do j=1,3 ! if(ic3(i,j)/=0.and.idry_e(ic3(i,j))==1) iedge=1 ! enddo !j ! Matrix ! tmin=tempmax+1; tmax=tempmin-1 !extrema for ELAD ! smin=saltmax+1; smax=saltmin-1 ndim=nvrt-kbe(i) do k=kbe(i)+1,nvrt kin=k-kbe(i) alow(kin)=0 cupp(kin)=0 bigv=area(i)*(ze(k,i)-ze(k-1,i)) !volume if(bigv<=0) then write(11,*)'Negative volume: ',bigv,i,k stop endif bdia(kin)=1 if(kkbe(i)+1) then av_df=(dfh(n1,k-1)+dfh(n2,k-1)+dfh(n3,k-1))/3 av_dz=(ze(k,i)-ze(k-2,i))/2 if(av_dz<=0) then write(11,*)'Impossible 112' stop endif tmp=area(i)*dtb*av_df/av_dz/bigv alow(kin)=alow(kin)-tmp bdia(kin)=bdia(kin)+tmp endif ! b.c. to be imposed at the end ! Advective flux ! Strike out \hat{S}^- (see above) psumtr(1:ntr)=0 !sum of modified fluxes at all inflow bnds delta_tr(1:ntr)=0 !sum of tracer fluxes at all inflow bnds adv_tr(1:ntr)=trel_tmp(k,i,1:ntr) !alternative mass conservative form for the advection part if(ntr>1.and.flx_mod(i,k,1,2)*flx_mod(i,k,2,2)<0) then write(11,*)'Left out vertical flux (0):',i,k,flx_mod(i,k,1:2,2) stop endif do jj=1,ntr if(flx_mod(i,k,jj,2)<-1.e33) then write(11,*)'Left out vertical flux:',i,k,flx_mod(i,k,jj,2),jj stop endif enddo !jj if(k/=nvrt.and.flx_mod(i,k,1,2)<0) then !all flx_mod(:) same sign if(up_tvd) then !neither can be upwind any more do jj=1,ntr psumtr(jj)=psumtr(jj)+abs(flx_mod(i,k,jj,2)) delta_tr(jj)=delta_tr(jj)+abs(flx_mod(i,k,jj,2))*trel_tmp(k+1,i,jj) adv_tr(jj)=adv_tr(jj)+dtb/bigv*abs(flx_adv(i,k,2))*(trel_tmp(k+1,i,jj)-trel_tmp(k,i,jj)) enddo !jj else !upwind tmp=abs(flx_mod(i,k,1,2))*dtb/bigv !flx_mod(:) all same for upwind cupp(kin)=cupp(kin)-tmp bdia(kin)=bdia(kin)+tmp endif endif if(k-1/=kbe(i).and.flx_mod(i,k-1,1,2)>0) then if(up_tvd) then !neither can be upwind any more do jj=1,ntr psumtr(jj)=psumtr(jj)+abs(flx_mod(i,k-1,jj,2)) delta_tr(jj)=delta_tr(jj)+abs(flx_mod(i,k-1,jj,2))*trel_tmp(k-1,i,jj) adv_tr(jj)=adv_tr(jj)+dtb/bigv*abs(flx_adv(i,k-1,2))*(trel_tmp(k-1,i,jj)-trel_tmp(k,i,jj)) enddo !jj else !upwind tmp=abs(flx_mod(i,k-1,1,2))*dtb/bigv alow(kin)=alow(kin)-tmp bdia(kin)=bdia(kin)+tmp endif endif ! Additional terms in adv_tr if(up_tvd) then if(k/=nvrt) then do jj=1,ntr adv_tr(jj)=adv_tr(jj)+dtb/bigv*abs(flx_adv(i,k,2))*(trel_tmp(k,i,jj)-trel_tmp(k+1,i,jj))* & &flux_lim(up_rat(i,k,jj,2),flimiter)/2 enddo !jj endif if(k-1/=kbe(i)) then do jj=1,ntr adv_tr(jj)=adv_tr(jj)+dtb/bigv*abs(flx_adv(i,k-1,2))*(trel_tmp(k,i,jj)-trel_tmp(k-1,i,jj))* & &flux_lim(up_rat(i,k-1,jj,2),flimiter)/2 enddo !jj endif endif !TVD do j=1,3 jsj=js(i,j) iel=ic3(i,j) if(iel==0.or.idry_e(iel)==1) cycle if(ntr>1.and.flx_mod(jsj,k,1,1)*flx_mod(jsj,k,2,1)<0) then write(11,*)'Left out horizontal flux (0):',i,j,k,flx_mod(jsj,k,1:2,1) stop endif do jj=1,ntr if(flx_mod(jsj,k,jj,1)<-1.e33) then write(11,*)'Left out horizontal flux:',i,j,k,flx_mod(jsj,k,jj,1),jj stop endif enddo !jj if(ssign(i,j)*flx_mod(jsj,k,1,1)<0) then do jj=1,ntr psumtr(jj)=psumtr(jj)+abs(flx_mod(jsj,k,jj,1)) delta_tr(jj)=delta_tr(jj)+abs(flx_mod(jsj,k,jj,1))*trel_tmp(k,iel,jj) adv_tr(jj)=adv_tr(jj)+dtb/bigv*abs(flx_adv(jsj,k,1))*(trel_tmp(k,iel,jj)-trel_tmp(k,i,jj)) enddo !jj endif if(up_tvd) then do jj=1,ntr adv_tr(jj)=adv_tr(jj)+dtb/bigv*abs(flx_adv(jsj,k,1))*(trel_tmp(k,i,jj)-trel_tmp(k,iel,jj))* & &flux_lim(up_rat(jsj,k,jj,1),flimiter)/2 enddo !jj endif enddo !j=1,3 ! Check Courant number do jj=1,ntr if(1-dtb/bigv*psumtr(jj)<0) then write(11,*)'Courant # condition violated:',i,k,1-dtb/bigv**psumtr(jj),jj stop endif enddo !jj rrhs(kin,1:ntr)=adv_tr(1:ntr) !(1-dtb/bigv*qj1)*trel_tmp(k,i,1)+dtb/bigv*qjt ! Check consistency between 2 formulations in TVD ! if(up_tvd) then ! if(abs(adv_t-rrhs(kin,1))>1.e-4.or.abs(adv_s-rrhs(kin,2))>1.e-4) then ! write(11,*)'Inconsistency between 2 TVD schemes:',i,k,adv_t,rrhs(kin,1),adv_s,rrhs(kin,2) ! stop ! endif ! endif !TVD ! Body source rrhs(kin,1:ntr)=rrhs(kin,1:ntr)+dtb*bdy_frc(k,i,1:ntr) ! b.c. if(k==nvrt) rrhs(kin,1:ntr)=rrhs(kin,1:ntr)+area(i)*dtb*flx_sf(i,1:ntr)/bigv if(k==kbe(i)+1) rrhs(kin,1:ntr)=rrhs(kin,1:ntr)-area(i)*dtb*flx_bt(i,1:ntr)/bigv enddo !k=kbe(i)+1,nvrt ! if(tmin>tmax.or.tminsmax.or.smin