#define PARALLEL 2 #define PVM_IO 0 #define ANALIZE 0 #define GKS 0 #define V5D 0 #define PLOTPL 0 #define COLORPL 0 #define TURBPL 0 #define SPCTPL 0 #define VORTPL 1 #define ENERGY 0 #define ENERGY2 1 #define CRAYT3D 0 #define CRAYPVP 0 #define CRAYT3E 0 #define SGI_O2K 0 #define HP 0 #define WORKS 0 #define FUJI_VPP 0 #define IBM 0 #define LNX 0 #define CPQ 0 #define PLE 2 #define SEMILAG 0 /* 0=EULERIAN, 1=SEMI-LAGRANGIAN */ #define MOISTMOD 0 /* 0=DRY, 1=WARM MOIST, 2=ICE A+B (NOT READY YET) */ #define MHD 0 /* 0=Hydro, 1=Magnetohydrodynamics */ #define J3DIM 1 /* 0=2D MODEL, 1=3D MODEL */ #define SGS 0 /* 0=NO DIFFUSION, 1=OLD DISSIP, 2=DISSIP AMR */ #define SUMR16 0 /* 0=REAL*8, 1=REAL*16 for GLOBAL SUMS */ #define ISEND 2 /* 1=SENDRECV, 2=IRECV+SEND, 3=ISEND+IRECV */ #define PRECF 0 /* 0=PRECON_DF or PRECON_BCZ, 1=PRECON_F */ #define POLES 1 /* 0=NO FLOW OVER POLES, 1=FLOW OVER POLES ON */ #define IORFLAG 0 /* 0=tape in serial mode, 1=tape in parallel mode */ #define IOWFLAG 0 /* 0=tape in serial mode, 1=tape in parallel mode */ #define IORTAPE 2 /* 1=default, 2=single, 3=double precision */ #define IOWTAPE 2 /* 1=default, 2=single, 3=double precision */ #define TIMEPLT 0 /* 1=time counts */ c.....7..0.........0.........0.........0.........0.........0.........012 PROGRAM ANELAS c.....7..0.........0.........0.........0.........0.........0.........012 c c set grid sizes with parameter statements include 'param.nml' include 'param.ior' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" #endif real globmax,globmin,globsum parameter (nml=n*m*l,nm=n*m,ml=m*l,nmp=np*mp) parameter (nmsgs=n*m,nmmsgs=nms*mms) parameter(nmsgsp=(np+2*ih)*(mp+2*ih), . nmmsgsp=(nmsp+2*ih)*(mmsp+2*ih)) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/histape/ dtfil(nfil ),dtfilo(nfilo), . ntfil(nfil ),ntfilo(nfilo), . nrestr,nresto cccccccccccccccccccccccccccccccccccccccccccccccccccc #if (HP > 0 || SGI_O2K > 1) integer CRAYOPEN,CRAYCLOSE #endif common/hpcray/ ifcw,ifcr,ioptw,ioptr cccccccccccccccccccccccccccccccccccccccccccccccccccc common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check - modified c dimension of ip due to out of bound problem in routine UPDATEBTW c for n1 common/rigid/ ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/davpol/ relpol(np,mp,l),dyabp,towyp,ipolar common/znave/ uza(mp,l),vza(mp,l),wza(mp,l),thza(mp,l), . qvza(mmsp,lms),bxza(mmhdp,lmhd),byza(mmhdp,lmhd), . bzza(mmhdp,lmhd) common/vbcdg/ vbcdiag(9) ccccccccccccccccccccccccc constants for pressure solver; itp_,epp_ are max number of iterations and constraint of accuracy max|1/rho*div(rho*v)*dt| 0) check if reference conditional instability may occur if(moist.eq.1) call cndinst #endif create boundary values for velocity call velbc(ue,ve,rho) c---------------------------------------------------------- create random perturbations in initial data; see noise routine for details; corporate noise ft into desired fields, e.g., th=the+0.001*ft, etc. inoise=0 if(inoise.eq.1) then call noise(fx,fy,fz,0) c call filstr(fz) c do k=1,l c do j=1,mp c do i=1,np cc if(fz(i,j,k).gt.0.1) then c if(fz(i,j,k).gt.0.01) then c zsib(i,j,k)= 1. c else c zsib(i,j,k)=-1. c endif c enddo c enddo c enddo c call update(zsib,np,mp,l,np,mp,iup) else do k=1,l do j=1,mp do i=1,np fx(i,j,k)=0.0 fy(i,j,k)=0.0 fz(i,j,k)=0.0 enddo enddo enddo endif CCCCCCC READ DATA FROM TAPE FORT.20 C icomm=1 C if (mype.eq.0) then C call iovelread0(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), C . w(1-ih,1-ih,1,0),icomm,20) C else C call iovelreadk(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), C . w(1-ih,1-ih,1,0),icomm) C end if c call integz(u(1-ih,1-ih,1,0),fy) c call integz(v(1-ih,1-ih,1,0),fy) c call integz(w(1-ih,1-ih,1,0),fy) CCCCCCC END READ DATA FROM TAPE call noise(fx,fy,fz,0) !mod do 4 k=1,l do 4 j=1,mp do 4 i=1,np ia = (npos-1)*np + i ja = (mpos-1)*mp + j if (istab.eq.1.and.zcr(k).le.hpsl) then u(i,j,k,0)=0. v(i,j,k,0)=0. w(i,j,k,0)=0. th(i,j,k)=0. else th(i,j,k) =1.e-2*fx(i,j,k) ! introduce theta perturbation u(i,j,k,0)= 0. v(i,j,k,0)= 0. w(i,j,k,0)= 0. if (k.eq.l) th(i,j,k)=0. !mihai endif g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ox(i,j,k,0)=g11*u(i,j,k,0)+g21*v(i,j,k,0) oy(i,j,k,0)=g12*u(i,j,k,0)+g22*v(i,j,k,0) oz(i,j,k,0)=g13*u(i,j,k,0)+g23*v(i,j,k,0)+g33*w(i,j,k,0) p(i,j,k) =0. x0(i,j,k) =float(ia) y0(i,j,k) =float(ja) z0(i,j,k) =float(k) fx(i,j,k) =1. fy(i,j,k) =0. fz(i,j,k) =1. 4 ft(i,j,k) =1. if(ichm.eq.1) then do ispc=1,nspc do k=1,l do j=1,mp do i=1,np chm(i,j,k,ispc) = 0. fchm(i,j,k,ispc) = 0. pfy(i,j,k)=0. enddo enddo enddo call sumcns(chm(1-ih,1-ih,1,ispc),pfy,rho,hischm(1,ispc),1) enddo endif !ichm #if (MOISTMOD > 0) create moist initial conditions do 40 k=1,l do 40 j=1,mp do 40 i=1,np qv(i,j,k)=qve(i,j,k) qc(i,j,k)=0. qr(i,j,k)=0. thf(i,j,k)=th(i,j,k)+the(i,j,k) fqv(i,j,k)=0. fqc(i,j,k)=0. fqr(i,j,k)=0. 40 ftf(i,j,k)=0. #endif create omega force for itraj=1 trajectory (advective velocity) scheme if(itraj.eq.1) then do 41 k=1,l do 41 j=1,mp do 41 i=1,np fox(i,j,k) =0. foy(i,j,k) =0. 41 foz(i,j,k) =0. endif compute poisson equation for potential c if(ispcpr.eq.1) call spcpri call gcrk( p,pfx,pfy,pfz,ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), . fx,fy,fz,ft,ub,vb,ob,itp0,epp0,0,1) c . fx,fy,fz,ft,itp0,epp0,0) call prforc(p,pfx,pfy,pfz,ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), . fx,fy,fz,ft,ub,vb,ob,1) c . fx,fy,fz,ft) initprs=1 call mybarrier() do 5 k=1,l do 5 j=1,mp do 5 i=1,np p(i,j,k)=0. fx(i,j,k)=0. fy(i,j,k)=0. fz(i,j,k)=0. ft(i,j,k)=0. ox(i,j,k,0)=pfx(i,j,k) oy(i,j,k,0)=pfy(i,j,k) oz(i,j,k,0)=pfz(i,j,k) g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) u(i,j,k,0)= (g22*ox(i,j,k,0)-g21*oy(i,j,k,0))/(g22*g11-g12*g21) v(i,j,k,0)=-(g12*ox(i,j,k,0)-g11*oy(i,j,k,0))/(g22*g11-g12*g21) w(i,j,k,0)=(oz(i,j,k,0)-u(i,j,k,0)*g13-v(i,j,k,0)*g23)/g33 if(galu**2+galv**2.ne.0.) then u(i,j,k,0)=u(i,j,k,0)+galu v(i,j,k,0)=v(i,j,k,0)+galv ox(i,j,k,0)=g11*u(i,j,k,0)+g21*v(i,j,k,0) oy(i,j,k,0)=g12*u(i,j,k,0)+g22*v(i,j,k,0) oz(i,j,k,0)=g13*u(i,j,k,0)+g23*v(i,j,k,0)+g33*w(i,j,k,0) endif ox(i,j,k,0)=ox(i,j,k,0)+strxd(i,j) oy(i,j,k,0)=oy(i,j,k,0)+stryd(i,j) oz(i,j,k,0)=oz(i,j,k,0)-gmul(k)*zsd(i,j)/zb*g33 . +(gmul(k)/zb-1.)*zhd(i,j)*g33 ox(i,j,k,1)=ox(i,j,k,0) oy(i,j,k,1)=oy(i,j,k,0) oz(i,j,k,1)=oz(i,j,k,0) u(i,j,k,1)=u(i,j,k,0) v(i,j,k,1)=v(i,j,k,0) w(i,j,k,1)=w(i,j,k,0) 5 continue if(mhd.eq.1) then call bbc call noise(fbx,fby,fbz,1) do k=1,l do j=1,mp do i=1,np bx(i,j,k,0)=0. by(i,j,k,0)=0.0001*fbx(i,j,k) bz(i,j,k,0)=0. g110=1./(gmm(i,j,k)*cosa(i,j)) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) bx(i,j,k,1)= G11*bx(i,j,k,0)+G21*by(i,j,k,0) by(i,j,k,1)= G12*bx(i,j,k,0)+G22*by(i,j,k,0) bz(i,j,k,1)= G13*bx(i,j,k,0)+G23*by(i,j,k,0)+G33*bz(i,j,k,0) pm(i,j,k)=0. fbx(i,j,k)=1. fby(i,j,k)=0. fbz(i,j,k)=1. ccs(i,j,k)=1. enddo enddo enddo if (ibbl .eq. 0) then do j=1,mp do i=1,np bz(i,j,1,0) = 0. bz(i,j,2,0) = 0. bz(i,j,1,1) = 0. bz(i,j,2,1) = 0. enddo enddo endif if (ibbu .eq. 0) then do j=1,mp do i=1,np bz(i,j,l-1,0) = 0. bz(i,j,l,0) = 0. bz(i,j,l-1,1) = 0. bz(i,j,l,1) = 0. enddo enddo else do j=1,mp do i=1,np dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bz(i,j,l,0) = bz(i,j,l-1,0)*(gacbt/gactp) bz(i,j,l,1) = bz(i,j,l-1,1)*(gacbt/gactp) enddo enddo endif call rhoswap( 1) !mod bbc ibbc=1 if (ibbc.eq.1) then do j=1,mp do i=1,np ! Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call bbc endif initprst=initprs initprs=0 c call rhoswap( 1) call gcrk(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,itp0,epp0,mtrf,2) call prforc(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,2) call rhoswap(-1) initprs=initprst do k=1,l do j=1,mp do i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) bx(i,j,k,0)= (G22*bfx(i,j,k)-G21*bfy(i,j,k))/(G22*G11-G12*G21) by(i,j,k,0)=-(G12*bfx(i,j,k)-G11*bfy(i,j,k))/(G22*G11-G12*G21) bz(i,j,k,0)=(bfz(i,j,k)-G13*bx(i,j,k,1)-G23*by(i,j,k,1))/G33 bx(i,j,k,1)=bx(i,j,k,0) by(i,j,k,1)=by(i,j,k,0) bz(i,j,k,1)=bz(i,j,k,0) fbx(i,j,k )=0. fby(i,j,k )=0. fbz(i,j,k )=0. ccs(i,j,k)=0. enddo enddo enddo endif c if(ichm.eq.1.and.nspc.eq.5) then !lagrangian displacements c do k=1,l c do j=1,mp c do i=1,np c fchm(i,j,k,3) = u(i,j,k,0) c fchm(i,j,k,4) = v(i,j,k,0) c fchm(i,j,k,5) = w(i,j,k,0) c enddo c enddo c enddo c endif !ichm compute gallilean shift if applicable (special for translating mountains) if(galu**2+galv**2.ne.0.) then call galin(ue,galu) call galin(ve,galv) u00=u00+galu v00=v00+galv call velbc(ue,ve,rho) endif close galilean shift c call potprs(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),p) c do k=1,l c do j=1,mp c do i=1,np c pfx(i,j,k)=0.5*(u(i,j,k,0)**2+v(i,j,k,0)**2+w(i,j,k,0)**2) c pfy(i,j,k)=0. c enddo c enddo c enddo c call sumcns(pfx,pfy,rho,hise(1,1),1) c hise(1,2)=0. c if(mhd.eq.1) then c ben0=0.125/pi c do k=1,l c do j=1,mp c do i=1,np c pfx(i,j,k)=bx(i,j,k,0)**2+by(i,j,k,0)**2+bz(i,j,k,0)**2 c pfx(i,j,k)=ben0*pfx(i,j,k) c enddo c enddo c enddo c call sumcnsB(pfx,hise(1,2)) c endif c---> time averaged fields, special (reinitilisation) do k=1,l do j=1-ih,mp+ih do i=1-ih,np+ih utav(i,j,k)=0. vtav(i,j,k)=0. wtav(i,j,k)=0. thtav(i,j,k)=0. ptav(i,j,k)=0. if(mhd.eq.1) then bxtav(i,j,k)=0. bytav(i,j,k)=0. bztav(i,j,k)=0. endif enddo enddo enddo if(iwrite.eq.1) then call iowrite(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), . ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,hise,hischm,epp1,0) call iowrsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),th,p, . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0)) endif nitsm=0 icount=0 close potential flow initialisation c---------------------------------------------------------- do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=0.5*(u(i,j,k,0)**2+v(i,j,k,0)**2+w(i,j,k,0)**2) pfy(i,j,k)=0. enddo enddo enddo call sumcns(pfx,pfy,rho,hise(1,1),1) hise(1,2)=0. create initial advective courant numbers for eulerian integrations if(ieul.eq.1) then do k=1,l do j=1,mp do i=1,np ox(i,j,k,2)=ox(i,j,k,0)*(lagr+rho(i,j,k)*ieul) oy(i,j,k,2)=oy(i,j,k,0)*(lagr+rho(i,j,k)*ieul) oz(i,j,k,2)=oz(i,j,k,0)*(lagr+rho(i,j,k)*ieul) u(i,j,k,1)=0. v(i,j,k,1)=0. w(i,j,k,1)=0. ox(i,j,k,1)=0. oy(i,j,k,1)=0. oz(i,j,k,1)=0. enddo enddo enddo c ---- determine staggered velocities and fluxes call velprd(u,v,w,ox,oy,oz,fox,foy,foz,p,gc1,gc2,gc3,0,epp0,itp0) endif else ! irst else clause ccccccccccccccccccccccccccccccccccccccccccc c --- read history tape ccccccccccccccccccccccccccccccccccccccccccc tt0=0. ! set the initial time in secs itstart=0 ! set the initial timestep c -------------------------------------------------------- niter=0 ! don't touch these nitsm=0 icount=0 initprs=1 tt=tt0 time=tt0/timescale do 1200 kf=1,nrestr ! read stored files from 1st to nrestr icomm=max0(iwrite0,kf/nrestr) call ioread(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), . ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,icomm) if(iwrite.eq.1 .and. iwrite0.eq.1) *call iowrite(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), . ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,hise,hischm,epp1,0) time=time+dtfil(kf)*ntfil(kf)/timescale tt=tt+dtfil(kf)*ntfil(kf) if (mype.eq.0) print 209, itstart,kf,time,tt 1200 continue 209 format(4x,' read tape; itstrt,kf,time,tt:',2i5,f7.2,e11.4) if(iwrite.eq.1 .and. iwrite0.eq.0) *call iowrite(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), . ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,hise,hischm,epp1,0) ! time=tt0/timescale ! do 1201 kfo=1,nresto ! icomo=max0(iwrite0,kfo/nresto) ! call iorsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), ! . w(1-ih,1-ih,1,0),th,p, ! . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), ! . icomo) !c call iorsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),chm, !c . icomo) ! if(iwrite.eq.1 .and. iwrite0.eq.1) ! . call iowrsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), ! . w(1-ih,1-ih,1,0),th,p, ! . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0)) !c if(iwrite.eq.1 .and. iwrite0.eq.1) call iowrsh(u(1-ih,1-ih,1,0), !c . v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),chm) ! time=time+dtfilo(kfo)*ntfilo(kfo)/timescale ! if (mype.eq.0) print 2091, kfo,time ! 1201 continue ! 2091 format(4x,' read short tape; kfo, time,:',i5,f7.2) ! if(iwrite.eq.1 .and. iwrite0.eq.0) ! . call iowrsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), !! . w(1-ih,1-ih,1,0),th,p, ! . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0)) !c if(iwrite.eq.1 .and. iwrite0.eq.0) call iowrsh(u(1-ih,1-ih,1,0), !c . v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),chm) c -------------------------------------------------------- c --- initialize other fields based upon the history tape c -------------------------------------------------------- compute coordinate transformation related matrices call topolog(x,y) call metryc(x,y,z) compute base state, environmental, and absorber profiles call tinit(z,x,y,tau,lipps,initi) !mod bbc ibbc=1 if(mhd.eq.1.and.ibbc.eq.1) then do j=1,mp do i=1,np !Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call rhoswap( 1) call bbc call rhoswap(-1) endif check if reference density nonnegative; if yes increase th00 call rhngck(rho) #if (MOISTMOD > 0) check if reference conditional instability may occur if(moist.eq.1) call cndinst #endif create boundary values for velocity call velbc(ue,ve,rho) c if(mhd.eq.1) call bbc c---------------------------------------------------------- c epp1=1.e-5 do 1203 k=1,l do 1203 j=1,mp do 1203 i=1,np ia = (npos-1)*np + i ja = (mpos-1)*mp + j c **** NOTE: stored "p" is actually multiplied by dt **** c c * So when dt is changed, need to premulitply read in c c * p field by ratio (new dt)/(old dt) c c **** ------- This is a ONE-TIME adjustment --------- **** c !GM p(i,j,k)=p(i,j,k)*(dt/dtfil(nrestr)) x0(i,j,k) =float(ia) y0(i,j,k) =float(ja) z0(i,j,k) =float(k) c mod-restart c ox(i,j,k,2)=ox(i,j,k,0)*(lagr+rho(i,j,k)*ieul) c oy(i,j,k,2)=oy(i,j,k,0)*(lagr+rho(i,j,k)*ieul) c oz(i,j,k,2)=oz(i,j,k,0)*(lagr+rho(i,j,k)*ieul) ox(i,j,k,1)=0. oy(i,j,k,1)=0. oz(i,j,k,1)=0. u(i,j,k,1)=0. v(i,j,k,1)=0. w(i,j,k,1)=0. itayler = 0 if(itayler.eq.1) then call noise(ptay,ptay,ptay) call filstr(ptay) ft(i,j,k)=ft(i,j,k) + 1.e-1*ptay(i,j,k) endif 1203 continue if(mhd.eq.1) then ibzero = 0 !GG: initializing from tape without imposing new initial field if (ibzero.eq.1) then ! do k=1,l ! do j=1,mp ! do i=1,np ! bx(i,j,k,1)=bx(i,j,k,0) ! by(i,j,k,1)=by(i,j,k,0) ! bz(i,j,k,1)=bz(i,j,k,0) ! enddo ! enddo ! enddo !! GG: initializing from tape with Bfield=0, and imposing new initial !! GG: condition ! else call noise(fbx,fby,fbz,1) do k=1,l do j=1,mp do i=1,np bx(i,j,k,0)=0. by(i,j,k,0)=0. bz(i,j,k,0)=1.e-3*fbx(i,j,k) g110=1./(gmm(i,j,k)*cosa(i,j)) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) bx(i,j,k,1)= G11*bx(i,j,k,0)+G21*by(i,j,k,0) by(i,j,k,1)= G12*bx(i,j,k,0)+G22*by(i,j,k,0) bz(i,j,k,1)= G13*bx(i,j,k,0)+G23*by(i,j,k,0)+G33*bz(i,j,k,0) pm(i,j,k)=0. fbx(i,j,k)=0. fby(i,j,k)=0. fbz(i,j,k)=1. ccs(i,j,k)=1. enddo enddo enddo !mod bbc if (ibbl .eq. 0) then do j=1,mp do i=1,np bz(i,j,1,0) = 0. bz(i,j,2,0) = 0. bz(i,j,1,1) = 0. bz(i,j,2,1) = 0. enddo enddo endif if (ibbu .eq. 0) then do j=1,mp do i=1,np bz(i,j,l-1,0) = 0. bz(i,j,l,0) = 0. bz(i,j,l-1,1) = 0. bz(i,j,l,1) = 0. enddo enddo else do j=1,mp do i=1,np dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bz(i,j,l,0) = bz(i,j,l-1,0)*(gacbt/gactp) bz(i,j,l,1) = bz(i,j,l-1,1)*(gacbt/gactp) enddo enddo endif call rhoswap( 1) !mod bbc ibbc=1 if (ibbc.eq.1) then do j=1,mp do i=1,np ! Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call bbc endif initprst=initprs initprs=0 c call rhoswap( 1) call gcrk(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,itp0,epp0,mtrf,2) call prforc(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,2) call rhoswap(-1) initprs=initprst do k=1,l do j=1,mp do i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) bx(i,j,k,0)= (G22*bfx(i,j,k)-G21*bfy(i,j,k))/(G22*G11-G12*G21) by(i,j,k,0)=-(G12*bfx(i,j,k)-G11*bfy(i,j,k))/(G22*G11-G12*G21) bz(i,j,k,0)=(bfz(i,j,k)-G13*bx(i,j,k,1)-G23*by(i,j,k,1))/G33 bx(i,j,k,1)=bx(i,j,k,0) by(i,j,k,1)=by(i,j,k,0) bz(i,j,k,1)=bz(i,j,k,0) fbx(i,j,k )=0. fby(i,j,k )=0. fbz(i,j,k )=0. ccs(i,j,k)=0. enddo enddo enddo endif !GG: end of condition for initialization of Bfield endif !GG: imhd clause #if (MOISTMOD > 0) do k=1,l do j=1,mp do i=1,np thf(i,j,k)=th(i,j,k)+the(i,j,k) ftf(i,j,k)=ft(i,j,k) enddo enddo enddo #endif c ---- determine staggered velocities and fluxes call velprd(u,v,w,ox,oy,oz,fox,foy,foz,p,gc1,gc2,gc3,0,epp1,itp1) endif ! end irst if ccccccccccccccccccccccccccccccccccccccccccc c --- compute initial diagnostics and plots ccccccccccccccccccccccccccccccccccccccccccc call sumcns(th,the,rho,thsum0,0) if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0), 1) call rhsdiv(ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),rho,pfy,1) if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),-1) if(mhd.eq.1) then do k=1,l do j=1,mp do i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) ox(i,j,k,1)= G11*bx(i,j,k,0)+G21*by(i,j,k,0) oy(i,j,k,1)= G12*bx(i,j,k,0)+G22*by(i,j,k,0) oz(i,j,k,1)= G13*bx(i,j,k,0)+G23*by(i,j,k,0)+G33*bz(i,j,k,0) enddo enddo enddo call rhsdiv(ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1), . oz(1-ih,1-ih,1,1),rh0,pfz,1) do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)= 0. oy(i,j,k,1)= 0. oz(i,j,k,1)= 0. enddo enddo enddo endif #if (MOISTMOD > 0) c total water: call totwtr(qv,qc,qr,rho,qws0) c initial rainfall distribution do j=1,mp do i=1,np prec_dis(i,j)=0. enddo enddo #endif call diagnos(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,x0,y0,z0,rho,the,pfx,pfy,thsum0,chm,gc1,gc2,gc3, * tt,tend,qv,qc,qr,qia,qib,qws0,pfz,dtm,0.,0.,zs,zh, * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),pfz) if(nslice.gt.0) then call slices(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,tke,chm,qv,qc,qr,qia,qib,0) endif if(nxaver.gt.0) then call xaver(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), * th,p,tau(1,1-ih,1-ih,1),0,irst) endif #if (GKS == 1) #if (PLOTPL == 1) call plot(th,u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), * p,pfy,chm,qv,qc,qr,qia,qib,lipps,tke,pfz,tau(1,1-ih,1-ih,1)) #endif #if (TURBPL == 1) call turban(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), * th,p,qv,qc,qr,lipps,tke,ivis) #endif #if (VORTPL == 1) call vort(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), * pfx,pfy,pfz,1) call plov(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,pfx,pfy,pfz) #endif #endif #if (V5D == 1) inbr=0 call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,pfy,qv,qc,qr,qia,qib,tke,pfz,inbr) #endif close initial conditions ************************************* c************************************************************* call ttend(2) ! initial c************************************************************* compute solution in time ************************************* c------ advance a timestep do 10 it=1+itstart,nt+itstart call ttbeg(3) ! timestep c if(mype.eq.0) print *,'TIMESTEP:',it,' time',time c ------ reducing order of numerics for HF filtering if(it/mpfl*mpfl.eq.it) then liner=1 else liner=0 endif #if (SEMILAG == 1) compute semi-Lagrangian origination pts if(lagr.eq.1) call traject(ox,oy,oz,n,m,l,gc1,gc2,gc3,1) #endif c------------------------------------------------------------- c------------------------------------------------------------- compute fields + 1st half of the trapezoidal forcing do 290 k=1,l do 290 j=1,mp do 290 i=1,np ox(i,j,k,2)=ox(i,j,k,0)*(lagr+rho(i,j,k)*ieul) oy(i,j,k,2)=oy(i,j,k,0)*(lagr+rho(i,j,k)*ieul) oz(i,j,k,2)=oz(i,j,k,0)*(lagr+rho(i,j,k)*ieul) u(i,j,k,0)= u(i,j,k,0)+fx(i,j,k)*dth v(i,j,k,0)= v(i,j,k,0)+fy(i,j,k)*dth w(i,j,k,0)= w(i,j,k,0)+fz(i,j,k)*dth th(i,j,k) =th(i,j,k) +ft(i,j,k)*dth 290 continue if(implgw.eq.0) call pertth(th, 1) ! advect full theta call ttend(3) ! timestep c ----- advect fields for first order estimate at (n+1) call advec(th,x0,y0,z0,1,1) call advec(u(1-ih,1-ih,1,0),x0,y0,z0,2,0) if(j3.eq.1.or.icorio.eq.1) *call advec(v(1-ih,1-ih,1,0),x0,y0,z0,3,0) call advec(w(1-ih,1-ih,1,0),x0,y0,z0,4,0) c------------------------------------------------------------- if(itraj.eq.1) then ! Runge-Kutta time integration call ttbeg(3) ! timestep do 291 k=1,l do 291 j=1,mp do 291 i=1,np fox(i,j,k)=ox(i,j,k,0)+fox(i,j,k)*dth foy(i,j,k)=oy(i,j,k,0)+foy(i,j,k)*dth 291 foz(i,j,k)=oz(i,j,k,0)+foz(i,j,k)*dth call ttend(3) ! timestep call advec(fox,x0,y0,z0,51,0) call advec(foy,x0,y0,z0,52,0) call advec(foz,x0,y0,z0,53,0) endif if(mhd.eq.1) then do k=1,l do j=1,mp do i=1,np bx(i,j,k,0)=bx(i,j,k,0)+fbx(i,j,k)*dth by(i,j,k,0)=by(i,j,k,0)+fby(i,j,k)*dth bz(i,j,k,0)=bz(i,j,k,0)+fbz(i,j,k)*dth enddo enddo enddo call advec(bx(1-ih,1-ih,1,0),x0,y0,z0,31,0) call advec(by(1-ih,1-ih,1,0),x0,y0,z0,32,0) call advec(bz(1-ih,1-ih,1,0),x0,y0,z0,33,0) endif if(itke.eq.1) then call ttbeg(3) ! timestep do k=1,l do j=1,mp do i=1,np tke(i,j,k)=tke(i,j,k)+ftke(i,j,k)*dth enddo enddo enddo call ttend(3) ! timestep call advec(tke,x0,y0,z0,9,0) endif if(ichm.eq.1) then call ttbeg(3) ! timestep do ispc=1,nspc do k=1,l do j=1,mp do i=1,np chm(i,j,k,ispc)=chm(i,j,k,ispc)+fchm(i,j,k,ispc)*dth enddo enddo enddo ispca=ispc+20 call advec(chm(1-ih,1-ih,1,ispc),x0,y0,z0,ispca,0) call sumcns(chm(1-ih,1-ih,1,ispc),pfy,rho,hischm(it+1,ispc),1) enddo call ttend(3) ! timestep endif !ichm c------------------------------------------------------------- #if (MOISTMOD > 0) IF(MOIST.EQ.1) THEN call ttbeg(4) ! moist cc moist forces: ftf,fqv,fqc,fqr - condensation + absorbers cc ftfa,fqva,fqca,fqra - precipitation ccc get fields and condensation forces at the departure point: call advec(thf,x0,y0,z0,11,0) call advec( qv,x0,y0,z0,6,0) call advec( qc,x0,y0,z0,7,0) call advec( qr,x0,y0,z0,8,0) call advec(ftf,x0,y0,z0,12,0) call advec(fqv,x0,y0,z0,12,0) call advec(fqc,x0,y0,z0,12,0) call advec(fqr,x0,y0,z0,12,0) do k=1,l do j=1,mp do i=1,np ftfa(i,j,k)=ftf(i,j,k) fqva(i,j,k)=fqv(i,j,k) fqca(i,j,k)=fqc(i,j,k) fqra(i,j,k)=fqr(i,j,k) enddo enddo enddo cc routine precip proceeds with small time step in columns cc with condensate; estimates of sources due to precip cc processes are brought back in ftfa, fqva, etc. call precip(thf,qv,qc,qr,ftfa,fqva,fqca,fqra,n,m,l,ndtm,dtm,it) cc routine adj_prec completes model time step for thermodynamic cc fields using averged tendencies brought back from precip and cc departure point values of model fields; cc NOTE: mean temperature tendency due to precipitation is brought back cc in ftfa to be applied to th after condensation call adj_prec(thf,qv,qc,qr,ftf,fqv,fqc,fqr, . ftfa,fqva,fqca,fqra,n,m,l) call ttend(4) ! moist ENDIF #endif /* MOISTMOD > 0 */ close 1st half of the trapezoidal forcing c------------------------------------------------------------- c------------------------------------------------------------- compute time dependent metric terms and related quantities tt=tt+dt time=tt/timescale if(tt.le.tend) then call ttbeg(5) ! timedtransf #if (SEMILAG == 0) if(lagr.eq.0) then c --- calls to rhotad correct anelastic mpdata to full c --- 2nd order time accuracy with time variable density call rhotad(th,rho, 1) call rhotad(u(1-ih,1-ih,1,0),rho, 1) call rhotad(v(1-ih,1-ih,1,0),rho, 1) call rhotad(w(1-ih,1-ih,1,0),rho, 1) if(mhd.eq.1) then call rhotad(bx(1-ih,1-ih,1,0),rho, 1) call rhotad(by(1-ih,1-ih,1,0),rho, 1) call rhotad(bz(1-ih,1-ih,1,0),rho, 1) endif #if (MOISTMOD > 0) call rhotad(thf,rho, 1) call rhotad( qv,rho, 1) call rhotad( qc,rho, 1) call rhotad( qr,rho, 1) #endif endif #endif compute coordinate transformation related matrices call topolog(x,y) c call shallow(it,rho,x,y) call metryc(x,y,z) compute base state, environmental, and absorber profiles !GG call tinit(z,x,y,tau,lipps,initi) !mod bbc ibbc=1 if(mhd.eq.1.and.ibbc.eq.1) then do j=1,mp do i=1,np !Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call rhoswap( 1) call bbc call rhoswap(-1) endif create boundary values for velocity call velbc(ue,ve,rho) c if(mhd.eq.1) call bbc #if (SEMILAG == 0) if(lagr.eq.0) then call rhotad(th,rho,-1) call rhotad(u(1-ih,1-ih,1,0),rho,-1) call rhotad(v(1-ih,1-ih,1,0),rho,-1) call rhotad(w(1-ih,1-ih,1,0),rho,-1) if(mhd.eq.1) then call rhotad(bx(1-ih,1-ih,1,0),rho,-1) call rhotad(by(1-ih,1-ih,1,0),rho,-1) call rhotad(bz(1-ih,1-ih,1,0),rho,-1) endif #if (MOISTMOD > 0) call rhotad(thf,rho,-1) call rhotad( qv,rho,-1) call rhotad( qc,rho,-1) call rhotad( qr,rho,-1) #endif endif #endif call ttend(5) ! timetransf endif close time dependent metrics c------------------------------------------------------------- c 1 2 3 4 5 6 7 c123456789012345678901234567890123456789012345678901234567890123456789012 c------------------------------------------------------------- call ttbeg(3) ! timestep if(implgw.eq.0) call pertth(th,-1) ! return to theta perturbation COMPUTE SPECIAL PROFILES FOR GW ABSORBERS c--------> special zonal averages for GW absorbers izonal=0 if(izonal.eq.1) then call zonav(u(1-ih,1-ih,1,0),uza,tau(1,1-ih,1-ih,1),1) call zonav(v(1-ih,1-ih,1,0),vza,tau(1,1-ih,1-ih,1),1) call zonav(w(1-ih,1-ih,1,0),wza,tau(1,1-ih,1-ih,1),1) call zonav(th,thza,tau(1,1-ih,1-ih,2),1) if(mhd.eq.1) then call zonav(bx(1-ih,1-ih,1,0),bxza,tau(1,1-ih,1-ih,1),1) call zonav(by(1-ih,1-ih,1,0),byza,tau(1,1-ih,1-ih,1),1) call zonav(bz(1-ih,1-ih,1,0),bzza,tau(1,1-ih,1-ih,1),1) endif if(moist.eq.1) call zonav(qv,qvza,tau(1,1-ih,1-ih,2),1) end if c------------------------------------------------------------- call ttend(3) ! timestep #if (MOISTMOD > 0) call ttbeg(4) ! moist cc finalize thermodynamics with condensation at the arrival point: call cond(thf,qv,qc,qr,ftf,fqv,fqc,fqr,tau(1,1-ih,1-ih,2)) cc apply forces to the model temperature do k=1,l do j=1,mp do i=1,np th(i,j,k)=th(i,j,k)+dth*(ftf(i,j,k)+2.*ftfa(i,j,k)) enddo enddo enddo call totwtr(qv,qc,qr,rho,qws) totw(it)=qws*dx*dy*dz call ttend(4) ! moist #endif c------------------------------------------------------------- c------------------------------------------------------------- c------ add new buoyancy, coriolis, metric and absorber forces c-------into auxiliary velocities (at grid points) if(intz.eq.1.and.igrid.eq.0) then do k=1,l do j=1,mp do i=1,np bu(i,j,k)=th(i,j,k) enddo enddo enddo call integz(bu,fy) endif do 292 mtri=1,mtrimx !outer iterations (for quadratic terms) if(mhd.eq.1) then if(mtrord.eq.2) then if(isphere.eq.1) then do k=1,l do j=1,mp do i=1,np gmri=1./(gmm(i,j,k)*rds) ifrm1=gmri*(tnga(i,j)*( by(i,j,k,1)*u(i,j,k,1) & -bx(i,j,k,1)*v(i,j,k,1)) & + bx(i,j,k,1)*w(i,j,k,1) - bz(i,j,k,1)*u(i,j,k,1)) ifrm2 = gmri*(by(i,j,k,1)*w(i,j,k,1)-bz(i,j,k,1)*v(i,j,k,1)) ifrm3=0. bx(i,j,k,1)=bx(i,j,k,0)+dth*ifrm1 by(i,j,k,1)=by(i,j,k,0)+dth*ifrm2 c bz(i,j,k,1)=bz(i,j,k,0)+dth*ifrm1 bz(i,j,k,1)=bz(i,j,k,0)+dth*ifrm3 !mod new enddo enddo enddo else do k=1,l do j=1,mp do i=1,np bx(i,j,k,1)=bx(i,j,k,0) by(i,j,k,1)=by(i,j,k,0) bz(i,j,k,1)=bz(i,j,k,0) enddo enddo enddo endif call rBVi(bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1) & ,u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1),w(1-ih,1-ih,1,1)) call rBB(bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), & ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), & rho,bfx,bfy,bfz,xmiui) endif endif call ttbeg(3) ! timestep do 295 k=1,l ! compute forcings due to absorbers do 295 j=1,mp ! and spherical Christoffel symbols do 295 i=1,np uexpl=u(i,j,k,0) vexpl=v(i,j,k,0) wexpl=w(i,j,k,0) if(mtrord.eq.2 .and. (isphere.eq.1.or.icylind.eq.1)) then if( isphere.eq.1) then if(mhd.eq.1) then we=0. gmri=1./(gmm(i,j,k)*rds) lfrm1= gmri*( & -tnga(i,j)*(bx(i,j,k,1)*by(i,j,k,1)-bxe(i,j,k)*bye(i,j,k)) & +(bx(i,j,k,1)*bz(i,j,k,1)-bxe(i,j,k)*bze(i,j,k)) ) lfrm2= gmri*( & tnga(i,j)*(bx(i,j,k,1)*bx(i,j,k,1)-bxe(i,j,k)*bxe(i,j,k)) & +(by(i,j,k,1)*bz(i,j,k,1)-bye(i,j,k)*bze(i,j,k)) ) lfrm3=-gmri*( (bx(i,j,k,1)*bx(i,j,k,1)-bxe(i,j,k)*bxe(i,j,k)) & +(by(i,j,k,1)*by(i,j,k,1)-bye(i,j,k)*bye(i,j,k)) ) bfx(i,j,k)=bfx(i,j,k)+lfrm1*xmiui*rh0(i,j,k)/rho(i,j,k) bfy(i,j,k)=bfy(i,j,k)+lfrm2*xmiui*rh0(i,j,k)/rho(i,j,k) bfz(i,j,k)=bfz(i,j,k)+lfrm3*xmiui*rh0(i,j,k)/rho(i,j,k) endif gmri=1./(gmm(i,j,k)*rds) frm1= gmri*tnga(i,j)*(u(i,j,k,1)*v(i,j,k,1)-ue(i,j,k)*ve(i,j,k)) . -gmri*(u(i,j,k,1)*w(i,j,k,1)) frm2=-gmri*tnga(i,j)*(u(i,j,k,1)*u(i,j,k,1)-ue(i,j,k)*ue(i,j,k)) . -gmri*(v(i,j,k,1)*w(i,j,k,1)) frm3= gmri* ( (u(i,j,k,1)*u(i,j,k,1)-ue(i,j,k)*ue(i,j,k)) 1 +(v(i,j,k,1)*v(i,j,k,1)-ve(i,j,k)*ve(i,j,k)) ) else gmri=1./gmm(i,j,k) frm1= gmri*(v(i,j,k,1)*v(i,j,k,1)-ve(i,j,k)*ve(i,j,k)) frm2=-gmri*(u(i,j,k,1)*v(i,j,k,1)-ue(i,j,k)*ve(i,j,k)) frm3=0. endif if(mhd.eq.1) then uexpl= uexpl+dth*bfx(i,j,k) vexpl= vexpl+dth*bfy(i,j,k) wexpl= wexpl+dth*bfz(i,j,k) endif uexpl=uexpl+dth*frm1 vexpl=vexpl+dth*frm2 wexpl=wexpl+dth*frm3 C original code commented out to accomodate mihai change to bypass C mhd=1 icylind=1 compare with sun_mhdN.src c uexpl=u(i,j,k,0)+dth*frm1 c vexpl=v(i,j,k,0)+dth*frm2 c wexpl=w(i,j,k,0)+dth*frm3 c else c uexpl=u(i,j,k,0) c vexpl=v(i,j,k,0) c wexpl=w(i,j,k,0) endif if(mtri.eq.mtrimx) then u(i,j,k,0)=uexpl v(i,j,k,0)=vexpl w(i,j,k,0)=wexpl endif c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) c astr =dth*(tau(k,i,j,1)*(1.-relt)+relt) c astrt=dth*(tau(k,i,j,2)*(1.-relt)+relt) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) astr =dth*(tau(k,i,j,1)**2+relt**2) & /(tau(k,i,j,1)+relt+1.e-13) astrt=dth*(tau(k,i,j,2)**2+relt**2) & /(tau(k,i,j,2)+relt+1.e-13) astri =1./(1.+astr ) astrti=1./(1.+astrt) f2str=dth*fcr2(i,j) f3str=dth*fcr3(i,j) c density stratified, th means rho !incompress Euler ! rhoinc=th(i,j,k)+the(i,j,k) !--------------------------------------- ! Anelastic/Boussinesq in theta rhoinc=-th0(i,j,k) !--------------------------------------- ! Boussinesq in rho c rhoinc=rh00 ! Gmod =-dth*g/rhoinc*astri ! & /gmm(i,j,k)**2 !Sun ! Gmodt=-dth*g/rhoinc*astrti ! & /gmm(i,j,k)**2 !Sun Gmod =-dth/rhoinc*astri & *(3694.34945199-1.26840190398e-05*rds*gmm(i,j,k) & +1.65029739402e-14*(rds*gmm(i,j,k))**2 & -7.67624479849e-24*(rds*gmm(i,j,k))**3) ! Rafaella, sun Gmodt=-dth/rhoinc*astrti & *(3694.34945199-1.26840190398e-05*rds*gmm(i,j,k) & +1.65029739402e-14*(rds*gmm(i,j,k))**2 & -7.67624479849e-24*(rds*gmm(i,j,k))**3) ! Rafaella, sun Rt=(1.+astrt)*astri we=0. ustr=uexpl+ astr*ue(i,j,k)-f3str*ve(i,j,k) +f2str*we vstr=vexpl+ astr*ve(i,j,k)+f3str*ue(i,j,k) if(intz.eq.1.and.igrid.eq.0) then wstr=wexpl+Gmodt*bu(i,j,k)-f2str*ue(i,j,k) + astr*we else wstr=wexpl+Gmodt*th(i,j,k)-f2str*ue(i,j,k) + astr*we endif if(izonal.eq.1) then c------> special damp to zonal averages (implicit GW absorption) ustr=ustr+ astr*(uza(j,k)-ue(i,j,k)) vstr=vstr+ astr*(vza(j,k)-ve(i,j,k)) wstr=wstr+Gmodt*astrt*thza(j,k)+astr*(wza(j,k)-we) end if #if (MOISTMOD > 0) wstr=wstr+Gmodt*th0(i,j,k)*(epsb*(qv(i,j,k)-qve(i,j,k)) . -(qc(i,j,k)+ qr(i,j,k))) #endif F2str=f2str*astri F3str=f3str*astri niu1= (Rt+Gmod*dthe(i,j,k,3))*ustr - Rt*F2str*wstr .+(Rt*F3str+Gmod*(F2str*dthe(i,j,k,2)+F3str*dthe(i,j,k,3)))*vstr niu2=-F3str*(Rt+Gmod*dthe(i,j,k,3))*ustr + Rt*F2str*F3str*wstr .+(Rt*(1.+F2str**2)+Gmod*(-F2str*dthe(i,j,k,1)+dthe(i,j,k,3)))*vstr niu3= (Rt*F2str+Gmod*(-dthe(i,j,k,1)+F3str*dthe(i,j,k,2)))*ustr . +(Rt*F2str*F3str-Gmod*(F3str*dthe(i,j,k,1)+dthe(i,j,k,2)))*vstr . +Rt*(1.+F3str*F3str)*wstr G110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) ox(i,j,k,1)= G11*niu1 + G21*niu2 oy(i,j,k,1)= G12*niu1 + G22*niu2 oz(i,j,k,1)= G13*niu1 + G23*niu2 + G33*niu3 c incompress Euler c ox(i,j,k,1)=ox(i,j,k,1)*rhoinc c oy(i,j,k,1)=oy(i,j,k,1)*rhoinc c oz(i,j,k,1)=oz(i,j,k,1)*rhoinc etainv=( -Gmod*dthe(i,j,k,1)*F2str . +Gmod*dthe(i,j,k,2)*F2str*F3str . +Gmod*dthe(i,j,k,3)*(1.+F3str*F3str) . +Rt*(1.+F2str*F2str+F3str*F3str) )*(1.+astr) c incompress Euler c . *rhoinc fx(i,j,k)=astri fy(i,j,k)=Gmod fz(i,j,k)=1./etainv ft(i,j,k)=Rt 295 continue call ttend(3) ! timestep compute pressure equation c here fx,fy,fz and ft contain coefficients defined in 295; c we still need u0,v0,w0,t0 for new forces c upon return, pfx, pfy, and pfz contain updated solenoidal vel''s mtrf=mtri-1 call gcrk(p,pfx,pfy,pfz,ox(1-ih,1-ih,1,1), . oy(1-ih,1-ih,1,1), . oz(1-ih,1-ih,1,1), . fx,fy,fz,ft,ub,vb,ob,itp1,epp1,mtrf,1) !if (V5D == 1) ! inbr=inbr+1 ! if(mype.eq.0) print *,'gcrk=',mtri,mtrimx,inbr ! call vis5d_out(pfx,pfy,pfz,pfz,pfz,ft, ! * fx,p,fy,qv,qc,qr,qia,qib,tke,fz,inbr) !endif call prforc(p,pfx,pfy,pfz,ox(1-ih,1-ih,1,1), . oy(1-ih,1-ih,1,1), . oz(1-ih,1-ih,1,1),fx,fy,fz,ft,ub,vb,ob,1) !if (V5D == 1) ! inbr=inbr+1 ! if(mype.eq.0) print *,'prfo=',mtri,mtrimx,inbr ! call vis5d_out(pfx,pfy,pfz,pfz,pfz,ft, ! * fx,p,fy,qv,qc,qr,qia,qib,tke,fz,inbr) !endif call ttbeg(3) ! timestep compute velocity and forces'' update, and shift temporal levels do 34 k=1,l do 34 j=1,mp do 34 i=1,np G110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) c --- store updated solenoidal velocity at time level n ox(i,j,k,1)=pfx(i,j,k) oy(i,j,k,1)=pfy(i,j,k) oz(i,j,k,1)=pfz(i,j,k) c --- compute updated physical velocity at time level n u(i,j,k,1)= (G22*ox(i,j,k,1)-G21*oy(i,j,k,1))/(G22*G11-G12*G21) v(i,j,k,1)=-(G12*ox(i,j,k,1)-G11*oy(i,j,k,1))/(G22*G11-G12*G21) w(i,j,k,1)=(oz(i,j,k,1)-G13*u(i,j,k,1)-G23*v(i,j,k,1))/G33 IF(mtri.eq.mtrimx) THEN ! if last outer loop, then ... fz(i,j,k) =th(i,j,k) c---- absorbing to zonal averages if(izonal.eq.1) + fz(i,j,k) =fz(i,j,k)+thza(j,k)*(ft(i,j,k)/fx(i,j,k)-1.) c --- compute updated tendencies fy(i,j,k) = u(i,j,k,1)*dthe(i,j,k,1) . +v(i,j,k,1)*dthe(i,j,k,2) . +w(i,j,k,1)*dthe(i,j,k,3) c th(i,j,k)=( fz(i,j,k)*fx(i,j,k)-fy(i,j,k) )/ft(i,j,k) c ft(i,j,k)=( th(i,j,k)-fz(i,j,k) )*2.*dti fz(i,j,k)=( fz(i,j,k)*fx(i,j,k)-fy(i,j,k) )/ft(i,j,k) !mod Andii new th ft(i,j,k)=( fz(i,j,k)-th(i,j,k) )*2.*dti !new forcing th(i,j,k)=fz(i,j,k) fx(i,j,k)=( u(i,j,k,1)-u(i,j,k,0) )*2.*dti fy(i,j,k)=( v(i,j,k,1)-v(i,j,k,0) )*2.*dti fz(i,j,k)=( w(i,j,k,1)-w(i,j,k,0) )*2.*dti c --- store updated physical velocity at time level n u(i,j,k,0)= u(i,j,k,1) v(i,j,k,0)= v(i,j,k,1) w(i,j,k,0)= w(i,j,k,1) c --- compute updated advective velocity at time level n pfx(i,j,k)=ox(i,j,k,1)+strxd(i,j) pfy(i,j,k)=oy(i,j,k,1)+stryd(i,j) pfz(i,j,k)=oz(i,j,k,1)-gmul(k)*zsd(i,j)/zb*G33 . +(gmul(k)/zb-1.)*zhd(i,j)*G33 c --- reinitialize arrays ox(i,j,k,1)=0. oy(i,j,k,1)=0. oz(i,j,k,1)=0. u(i,j,k,1)= 0. v(i,j,k,1)= 0. w(i,j,k,1)= 0. c --- store updated advective velocity at time level n ox(i,j,k,0)=pfx(i,j,k) oy(i,j,k,0)=pfy(i,j,k) oz(i,j,k,0)=pfz(i,j,k) c --- Runge-Kutta force update if(itraj.eq.1) then fox(i,j,k)=( ox(i,j,k,0)-fox(i,j,k) )*2.*dti foy(i,j,k)=( oy(i,j,k,0)-foy(i,j,k) )*2.*dti foz(i,j,k)=( oz(i,j,k,0)-foz(i,j,k) )*2.*dti endif ENDIF 34 continue IF(mhd.eq.1) THEN lc=1 if(mtri.eq.mtrimx) lc=0 if(mtrord.eq.2) then if(isphere.eq.1) then do k=1,l do j=1,mp do i=1,np gmri=1./(gmm(i,j,k)*rds) ifrm1=gmri*(tnga(i,j)*( by(i,j,k,1)*u(i,j,k,lc) & -bx(i,j,k,1)*v(i,j,k,lc)) & + bx(i,j,k,1)*w(i,j,k,lc) - bz(i,j,k,1)*u(i,j,k,lc)) ifrm2=gmri*(by(i,j,k,1)*w(i,j,k,lc)-bz(i,j,k,1)*v(i,j,k,lc)) ifrm3=0. bx(i,j,k,1)=bx(i,j,k,0)+dth*ifrm1 by(i,j,k,1)=by(i,j,k,0)+dth*ifrm2 c bz(i,j,k,1)=bz(i,j,k,0)+dth*ifrm1 bz(i,j,k,1)=bz(i,j,k,0)+dth*ifrm3 !mod new enddo enddo enddo else do k=1,l do j=1,mp do i=1,np bx(i,j,k,1)=bx(i,j,k,0) by(i,j,k,1)=by(i,j,k,0) bz(i,j,k,1)=bz(i,j,k,0) enddo enddo enddo endif endif call rBVi(bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1) & ,u(1-ih,1-ih,1,lc),v(1-ih,1-ih,1,lc),w(1-ih,1-ih,1,lc)) c call rBVeO(bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1) !default c & ,u(1-ih,1-ih,1,lc),v(1-ih,1-ih,1,lc),w(1-ih,1-ih,1,lc), !default c & fbx,fby,fbz) !default call rBVeN(bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), !option & ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), !option & u(1-ih,1-ih,1,lc),v(1-ih,1-ih,1,lc),w(1-ih,1-ih,1,lc), !option & fbx,fby,fbz,1) !option do 2951 k=1,l ! compute forcings due to absorbers do 2951 j=1,mp ! and spherical Christoffel symbols do 2951 i=1,np if(mtrord.eq.2) then if(isphere.eq.1) then we=0. gmri=1./(gmm(i,j,k)*rds) ifrm1=gmri*(tnga(i,j)*( by(i,j,k,1)*u(i,j,k,lc) & -bx(i,j,k,1)*v(i,j,k,lc)) & + bx(i,j,k,1)*w(i,j,k,lc) - bz(i,j,k,1)*u(i,j,k,lc)) ifrm2=gmri*(by(i,j,k,1)*w(i,j,k,lc)-bz(i,j,k,1)*v(i,j,k,lc)) ifrm3=0. fbx(i,j,k)=fbx(i,j,k)+ifrm1 fby(i,j,k)=fby(i,j,k)+ifrm2 fbz(i,j,k)=fbz(i,j,k)+ifrm3 endif bxxpl=bx(i,j,k,0)+dth*fbx(i,j,k) byxpl=by(i,j,k,0)+dth*fby(i,j,k) bzxpl=bz(i,j,k,0)+dth*fbz(i,j,k) else bxxpl=bx(i,j,k,1) byxpl=by(i,j,k,1) bzxpl=bz(i,j,k,1) endif if(mtri.eq.mtrimx) then bx(i,j,k,0)=bxxpl by(i,j,k,0)=byxpl bz(i,j,k,0)=bzxpl endif c------> damp to environmental profiles idmpep=0 if(idmpep.eq.1) then bxstr=bxxpl+ astr*bxe(i,j,k)*iabb bystr=byxpl+ astr*bye(i,j,k)*iabb bzstr=bzxpl+ astr*bze(i,j,k)*iabb end if if(izonal.eq.1) then bxstr=bxstr+ astr*(bxza(j,k)-bxe(i,j,k))*iabb bystr=bystr+ astr*(byza(j,k)-bye(i,j,k))*iabb bzstr=bzstr+ astr*(bzza(j,k)-bze(i,j,k))*iabb end if c------> end of damping to zonal averages c------> damp bx and by to 0 at the top boundary c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) !new c astrt =dth*(tau(k,i,j,2)*(1.-relt)+relt) !new c astrti =1./(1.+astrt ) !new bxstr=bxxpl*(1.-tau(k,i,j,2)*iabb) bystr=byxpl*(1.-tau(k,i,j,2)*iabb) bzstr=bzxpl G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) bx(i,j,k,1)= G11*bxstr+G21*bystr by(i,j,k,1)= G12*bxstr+G22*bystr bz(i,j,k,1)= G13*bxstr+G23*bystr+G33*bzstr c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) !new c astr =dth*(tau(k,i,j,1)*(1.-relt)+relt) !new c astri =1./(1.+astr ) !new relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) astr =dth*(tau(k,i,j,1)**2+relt**2) & /(tau(k,i,j,1)+relt+1.e-13) astrt=dth*(tau(k,i,j,2)**2+relt**2) & /(tau(k,i,j,2)+relt+1.e-13) fbx(i,j,k)=astri*iabb+float(1-iabb) fby(i,j,k)=0. fbz(i,j,k)=1. ccs(i,j,k)=astri*iabb+float(1-iabb) 2951 continue idvcln=1 if(idvcln.eq.1) then initprst=initprs initprs=0 !mod bbc ibbc=1 if(ibbc.eq.1) then do j=1,mp do i=1,np !Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call rhoswap( 1) call bbc else call rhoswap( 1) endif call gcrk(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,itp1,epp1,mtrf,2) call prforc(pm,bfx,bfy,bfz,bx(1-ih,1-ih,1,1), . by(1-ih,1-ih,1,1), . bz(1-ih,1-ih,1,1), . fbx,fby,fbz,ccs,bbx,bby,bbz,2) call rhoswap(-1) initprs=initprst else do k=1,l do j=1,mp do i=1,np bfx(i,j,k)=bx(i,j,k,1) bfy(i,j,k)=by(i,j,k,1) bfz(i,j,k)=bz(i,j,k,1) enddo enddo enddo endif do 341 k=1,l do 341 j=1,mp do 341 i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) bx(i,j,k,1)= (G22*bfx(i,j,k)-G21*bfy(i,j,k))/(G22*G11-G12*G21) by(i,j,k,1)=-(G12*bfx(i,j,k)-G11*bfy(i,j,k))/(G22*G11-G12*G21) bz(i,j,k,1)=(bfz(i,j,k)-G13*bx(i,j,k,1)-G23*by(i,j,k,1))/G33 IF(mtri.eq.mtrimx) THEN ! if last outer loop, then ... fbx(i,j,k)=(bx(i,j,k,1)-bx(i,j,k,0))*2.*dti fby(i,j,k)=(by(i,j,k,1)-by(i,j,k,0))*2.*dti fbz(i,j,k)=(bz(i,j,k,1)-bz(i,j,k,0))*2.*dti bx(i,j,k,0)=bx(i,j,k,1) by(i,j,k,0)=by(i,j,k,1) bz(i,j,k,0)=bz(i,j,k,1) ENDIF 341 continue ENDIF call ttend(3) ! timestep 292 continue ! end outer iterations c------------------------------------------------------------- call ttbeg(3) ! timestep if(isphere.eq.1) then compute metric forces do 36 k=1,l do 36 j=1,mp do 36 i=1,np gmri=1./(gmm(i,j,k)*rds) frm1= gmri*tnga(i,j)*(u(i,j,k,0)*v(i,j,k,0)-ue(i,j,k)*ve(i,j,k)) . -gmri*(u(i,j,k,0)*w(i,j,k,0)) frm2=-gmri*tnga(i,j)*(u(i,j,k,0)*u(i,j,k,0)-ue(i,j,k)*ue(i,j,k)) . -gmri*(v(i,j,k,0)*w(i,j,k,0)) frm3= gmri* ( (u(i,j,k,0)*u(i,j,k,0)-ue(i,j,k)*ue(i,j,k)) 1 +(v(i,j,k,0)*v(i,j,k,0)-ve(i,j,k)*ve(i,j,k)) ) fx(i,j,k)=fx(i,j,k)+(3-mtrord)*frm1 fy(i,j,k)=fy(i,j,k)+(3-mtrord)*frm2 36 fz(i,j,k)=fz(i,j,k)+(3-mtrord)*frm3 endif if(icylind.eq.1) then do 336 k=1,l do 336 j=1,mp do 336 i=1,np gmri=1./gmm(i,j,k) frm1= gmri*(v(i,j,k,0)*v(i,j,k,0)-ve(i,j,k)*ve(i,j,k)) frm2=-gmri*(u(i,j,k,0)*v(i,j,k,0)-ue(i,j,k)*ve(i,j,k)) frm3=0. fx(i,j,k)=fx(i,j,k)+(3-mtrord)*frm1 fy(i,j,k)=fy(i,j,k)+(3-mtrord)*frm2 336 fz(i,j,k)=fz(i,j,k)+(3-mtrord)*frm3 endif if(mhd.eq.1) then !compute Lorentz force call rBB(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), & ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), & rho,bfx,bfy,bfz,xmiui) !compute additional metric terms for Lorentz force mg 04.05.2005 do k=1,l do j=1,mp do i=1,np if(isphere.eq.1) then gmri=1./(gmm(i,j,k)*rds) lfrm1= gmri*( & -tnga(i,j)*(bx(i,j,k,0)*by(i,j,k,0)-bxe(i,j,k)*bye(i,j,k)) & +(bx(i,j,k,0)*bz(i,j,k,0)-bxe(i,j,k)*bze(i,j,k)) ) lfrm2= gmri*( & tnga(i,j)*(bx(i,j,k,0)*bx(i,j,k,0)-bxe(i,j,k)*bxe(i,j,k)) & +(by(i,j,k,0)*bz(i,j,k,0)-bye(i,j,k)*bze(i,j,k)) ) lfrm3=-gmri*( (bx(i,j,k,0)*bx(i,j,k,0)-bxe(i,j,k)*bxe(i,j,k)) & +(by(i,j,k,0)*by(i,j,k,0)-bye(i,j,k)*bye(i,j,k)) ) bfx(i,j,k)=bfx(i,j,k)+lfrm1*xmiui*rh0(i,j,k)/rho(i,j,k) bfy(i,j,k)=bfy(i,j,k)+lfrm2*xmiui*rh0(i,j,k)/rho(i,j,k) bfz(i,j,k)=bfz(i,j,k)+lfrm3*xmiui*rh0(i,j,k)/rho(i,j,k) endif fx(i,j,k)=fx(i,j,k)+(3-mtrord)*bfx(i,j,k) fy(i,j,k)=fy(i,j,k)+(3-mtrord)*bfy(i,j,k) fz(i,j,k)=fz(i,j,k)+(3-mtrord)*bfz(i,j,k) end do end do end do !compute rhs of the induction equation c call rBVeO(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0) !option c & ,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), !option c & bfx,bfy,bfz) !option call rBVeN(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), !default & ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), !default & u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), !default & bfx,bfy,bfz,0) do k=1,l do j=1,mp do i=1,np if(isphere.eq.1) then gmri=1./(gmm(i,j,k)*rds) ifrm1 = gmri*(tnga(i,j)*(by(i,j,k,0)*u(i,j,k,0) & - bx(i,j,k,0)*v(i,j,k,0)) & + bx(i,j,k,0)*w(i,j,k,0) - bz(i,j,k,0)*u(i,j,k,0)) ifrm2 = gmri*(by(i,j,k,0)*w(i,j,k,0)-bz(i,j,k,0)*v(i,j,k,0)) ifrm3=0. bfx(i,j,k)=bfx(i,j,k)+ifrm1 bfy(i,j,k)=bfy(i,j,k)+ifrm2 bfz(i,j,k)=bfz(i,j,k)+ifrm3 endif fbx(i,j,k)=fbx(i,j,k)+(3-mtrord)*bfx(i,j,k) fby(i,j,k)=fby(i,j,k)+(3-mtrord)*bfy(i,j,k) fbz(i,j,k)=fbz(i,j,k)+(3-mtrord)*bfz(i,j,k) ox(i,j,k,1)=0. oy(i,j,k,1)=0. oz(i,j,k,1)=0. end do end do end do endif call ttend(3) ! timestep c------------------------------------------------------------- #if (MOISTMOD > 0) call ttbeg(4) ! moist if(moist.eq.1) then if(it/noutp*noutp.eq.it) then xnorf=1./float(l*m*n) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=th(i,j,k)+the(i,j,k)-thf(i,j,k) enddo enddo enddo dftmx=globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dftmn=globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dftav=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dftav=dftav*xnorf do k=1,l do j=1,mp do i=1,np temp(i,j,k)=(th(i,j,k)+the(i,j,k)-thf(i,j,k)-dftav)**2 enddo enddo enddo dftsd=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dftsd=sqrt(dftsd*xnorf) endif do 37 k=1,l do 37 j=1,mp do 37 i=1,np ft(i,j,k)=ft(i,j,k)+ftf(i,j,k) ftf(i,j,k)=ft(i,j,k) 37 thf(i,j,k)=th(i,j,k)+the(i,j,k) endif call ttend(4) ! moist #endif !if (V5D == 1) ! inbr=inbr+1 ! if(mype.eq.0) print *,'fxfy=',mtri,mtrimx,inbr ! call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), ! * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), ! * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), ! * fx,p,fy,qv,qc,qr,qia,qib,tke,fz,inbr) !endif c------------------------------------------------------------- #if (SGS == 1) if(ivis.ne.0) then itstr=it call dissip(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), 1 th, chm, qv, qc, qr, tke, 1 fx,fy,fz,ft, fchm, qia,qib,fqia,fqib, 3 fqv,fqc,fqr,ftke, fox,foy,foz,pfx,pfy,pfz, 3 u(1-ih,1-ih,1,1), v(1-ih,1-ih,1,1), w(1-ih,1-ih,1,1), 3 ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1)) endif #endif #if (SGS == 2) if(ivis.ne.0) then itstr=it call dissip(ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), 1 u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), 1 th,qv,qc,qr,tke,fx,fy,fz,ft, 3 fqv,fqc,fqr,ftke,fox,foy,foz,pfx,pfy,pfz, 3 u(1-ih,1-ih,1,1), v(1-ih,1-ih,1,1), w(1-ih,1-ih,1,1), 3 ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1)) idisb=1 if(mhd.eq.1.and.idisb.eq.1) then call rhoswap( 1) call dissipB(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0), 1 bz(1-ih,1-ih,1,0),tke,fbx,fby,fbz,bfx,bfy,bfz, 3 bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), 3 ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1)) call rhoswap(-1) endif endif #endif c------------------------------------------------------------- call ttbeg(3) ! timestep iblatt=0 if(iblatt.eq.1) then C boundary layer forcing hscl= 1.*dz tscl=500. do k=1,l zatt=2.*exp(-(k-1)*dz/hscl) do j=1,mp do i=1,np ft(i,j,k)=ft(i,j,k)+(zatt/hscl)*hfx(i,j) c fx(i,j,k)=fx(i,j,k)-(zatt/tscl)* u(i,j,k,0) c fy(i,j,k)=fy(i,j,k)-(zatt/tscl)* v(i,j,k,0) enddo enddo enddo endif c ---- held-suarez test ihs=0 if(ihs.eq.1) then do 38 k=1,l do 38 j=1,mp do 38 i=1,np dfv2=2.* hskf*dfhs(i,j,k) ! velocity boundary-layer damping dft2=2.*(hska+(hsks-hska)*dfhs(i,j,k)*cosa(i,j)**4) !theta damp. thtot=th(i,j,k)+the(i,j,k) fx(i,j,k)=fx(i,j,k)-dfv2* u(i,j,k,0) fy(i,j,k)=fy(i,j,k)-dfv2* v(i,j,k,0) fz(i,j,k)=fz(i,j,k)-dfv2* w(i,j,k,0) c --- using full HS env. theta for forcing ft(i,j,k)=ft(i,j,k)-dft2*(thtot-theq(i,j,k)) 38 continue #if (MOISTMOD > 0) if(moist.eq.1) then do 39 k=1,l do 39 j=1,mp do 39 i=1,np dft2=2.*(hska+(hsks-hska)*dfhs(i,j,k)*cosa(i,j)**4) fqv(i,j,k)=fqv(i,j,k)-dft2*(qv(i,j,k)-qveq(i,j,k)) 39 ftf(i,j,k)=ft(i,j,k) endif #endif endif c------------------------------------------------------------- isolat=1 if(isolat.eq.1) then c ---- solar forcing c tsclh=3600.*24.*30.*5. !time scale for HS forcing, 5 Sdays c tsclh=3600.*24.*30.*10. !time scale for HS forcing, 20 Sdays c tsclh=3600.*24.*30.*16. !time scale for HS forcing, 20 Sdays c tsclh=3600.*24.*30.*20. !time scale for HS forcing, 20 Sdays tsclh=3600.*24.*30.*40. !sun tshear=3600.*24*365.*2. ! 2 yr shear timescale ! call rhprof(tim,zcr,l,lipps) ! do k=1,l ! tim(k)=tsclh*tim(k)**(0.5) ! enddo tscli=1./tsclh do k=1,l do j=1,mp do i=1,np C renom= (stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) C + / (gmm(i,j,k)**2*cosa(i,j)) C rhop=rho(i,j,k)*(gi(i,j)*gmus(k))*renom C fctr=(rh00*tt00/(rhop*th0(i,j,k)))**wykl C ft(i,j,k)=ft(i,j,k) C . +2.*cnsh*fctr*(hflx(k+1)-hflx(k)) C . *(rho(i,j,1)/rho(i,j,k)) c ft(i,j,k)=ft(i,j,k)-2.*tscli*(th(i,j,k)-the(i,j,k)) !held-suarez forcing ft(i,j,k)=ft(i,j,k)-2.*tscli*th(i,j,k) !held-suarez forcing fx(i,j,k)=fx(i,j,k)-2.*(u(i,j,k,0)-u0_char(i,j,k))/tshear !Miesch Forcing enddo enddo enddo !if(mype.eq.0) print*, "u0_char=", u0_char(10, 10, 60), "Values" endif c------------------------------------------------------------- c special EXPLICIT polar damping c --- see definition of relpol in subroutine absorber c --- define special explicit absorber parameters in blanelas if(ipolar.eq.1) then call zonav(u(1-ih,1-ih,1,0),uza,tau(1,1-ih,1-ih,1),1) call zonav(v(1-ih,1-ih,1,0),vza,tau(1,1-ih,1-ih,1),1) call zonav(w(1-ih,1-ih,1,0),wza,tau(1,1-ih,1-ih,1),1) if(iabth.eq.1) . call zonav(th,thza,tau(1,1-ih,1-ih,2),1) do k=1,l do j=1,mp do i=1,np yatt=amax1(0.,2.*relpol(i,j,k)) ! additive c yatt=amax1(0.,2.*relpol(i,j)) ! additive c yatt=amax1(0.,2.*(relpol(i,j)-irly*rely(i,j))) ! nonadditive c yatt=(tau(k,i,j,1)**2+yatt**2)/(tau(k,i,j,1)+yatt+1.e-13) fx(i,j,k)=fx(i,j,k)+yatt*(uza(j,k)-u(i,j,k,0)) fy(i,j,k)=fy(i,j,k)+yatt*(vza(j,k)-v(i,j,k,0)) fz(i,j,k)=fz(i,j,k)+yatt*(wza(j,k)-w(i,j,k,0)) if(iabth.eq.1) . ft(i,j,k)=ft(i,j,k)+yatt*(thza(j,k)-th(i,j,k)) enddo enddo enddo endif c------------------------------------------------------------- call ttend(3) ! timestep compute velocity predictor for the first guess of the trajectory scheme call velprd(u,v,w,ox,oy,oz,fox,foy,foz,p, * gc1,gc2,gc3,itraj,epp1,itp1) 1001 continue call ttbeg(3) ! timestep c --- calculate drag force ------------------------ itd=it if(idrag.eq.1) then call drag(p,dragx,dragy,n,m,L) do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=0.5*(u(i,j,k,0)**2+v(i,j,k,0)**2+w(i,j,k,0)**2) pfy(i,j,k)=0. enddo enddo enddo call sumcns(pfx,pfy,rho,hise(it+1,1),1) hise(it+1,2)=0. endif if(mhd.eq.1) then ben0=0.125/pi do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=bx(i,j,k,0)**2+by(i,j,k,0)**2+bz(i,j,k,0)**2 pfx(i,j,k)=ben0*pfx(i,j,k) enddo enddo enddo call sumcnsB(pfx,hise(it+1,2)) endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc compute diagnostics and output fields ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call lipsch(ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), . rho,gc1,gc2,gc3,cr1,cr2,lagr,0) call courB(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), . rho,xmiu,crb,0) c epp1=amax1(1.e-6, 1.e-4*amin1(cr1,cr2)) C epp1=amax1(1.e-6, 1.e-4*cr1) epp1=amax1(1.e-5, 1.e-3*cr1) call ttend(3) ! timestep ! GG slices and xaverages output if(nslice.gt.0) then if((it-itstart)/nslice*nslice.eq.(it-itstart)) *call slices(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,tke,chm,qv,qc,qr,qia,qib,it) endif if(nxaver.gt.0) then if((it-itstart)/nxaver*nxaver.eq.(it-itstart)) then call xaver(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), * th,p,tau(1,1-ih,1-ih,1),it,irst) if(mype.eq.0) print*, "it=", it, "computing zonal averages" endif endif ! ! GG if(iwrite.eq.1.and.(it-itstart)/nplot*nplot.eq.(it-itstart)) then call iowrsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),th,p, . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0)) endif !GM:Condition to initiate the bridge !print *, 'EULAG - BEFORE CALL SEND' if(iwrite.eq.1.and.(it-itstart)/nbridge*nbridge.eq.(it-itstart)) . then if(tag_frn>0) . call bridge_velo_send(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0)) endif ! print *, 'Eulag Barrier' ! call MPI_BARRIER(MPI_COMM_WORLD, ierr) ! ! call MPI_FINALIZE(ierr) ! stop if(iwrite.eq.1.and. . (it-itstart)/nstore*nstore.eq.(it-itstart)) then if(it.eq.nt) ihis=1 call iowrite(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), . ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,hise,hischm,epp1,ihis) ! GG: here a new output file is written with the numer of steps ! GG: stored in the history tape ipulse = ipulse+1 if(mype.eq.0) then print*, 'NUMBER FILES IN TAPE=',ipulse open(21,file="pulses.dat",form='formatted') write(21,'(i5)'), ipulse close(21) endif ! GG endif itav=0 if (itav.eq.1) then c---> time averaged fields do k=1,l do j=1-ih,mp+ih do i=1-ih,np+ih utav(i,j,k)=utav(i,j,k) + u(i,j,k,0)/nplot vtav(i,j,k)=vtav(i,j,k) + v(i,j,k,0)/nplot wtav(i,j,k)=wtav(i,j,k) + w(i,j,k,0)/nplot thtav(i,j,k)=thtav(i,j,k) + th(i,j,k)/nplot ptav(i,j,k)=ptav(i,j,k) + p(i,j,k)/nplot if(mhd.eq.1) then bxtav(i,j,k)=bxtav(i,j,k) + bx(i,j,k,0)/nplot bytav(i,j,k)=bytav(i,j,k) + by(i,j,k,0)/nplot bztav(i,j,k)=bztav(i,j,k) + bz(i,j,k,0)/nplot endif enddo enddo enddo endif c if(iwrite.eq.1.and.(it-itstart)/nplot*nplot.eq.(it-itstart)) then c if (itav.eq.1) then c call iowrsh(utav,vtav,wtav,thtav,ptav,bxtav,bytav,bztav) c---> time averaged fields, special (reinitilisation) c do k=1,l c do j=1-ih,mp+ih c do i=1-ih,np+ih c utav(i,j,k)=0. c vtav(i,j,k)=0. c wtav(i,j,k)=0. c thtav(i,j,k)=0. c ptav(i,j,k)=0. c if(mhd.eq.1) then c bxtav(i,j,k)=0. c bytav(i,j,k)=0. c bztav(i,j,k)=0. c endif c enddo c enddo c enddo c else c call iowrsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), c . w(1-ih,1-ih,1,0),th,p, c . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0)) c . w(1-ih,1-ih,1,0),chm) c endif !itav c endif if((it-itstart)/noutp*noutp.eq.(it-itstart)) then if (mype.eq.0) print 210,it,dt,time, u(15,15,1,0) if (mype.eq.0) print 211,cr1,cr2,crb 210 format(/,10x,' it=',i9,' dt(sec)=',f7.2, & ' time(solar days)=',f7.2,/,' u=', e23.16) c 210 format(/,8x,' it=',i5,' dt(sec)=',f7.2,' time(min)=',f7.2) 211 format(1x,'cour,lipsh,courB:',3e11.4,5x,e11.3) do 250 k=1,l do 250 j=1,mp do 250 i=1,np 250 pfx(i,j,k)=rho(i,j,k) #if (SEMILAG == 1) if(lagr.eq.1) call interp(pfx,x0,y0,z0,1) #endif if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0), 1) !if (V5D == 1) ! inbr=inbr+1 ! =6 ! if (mype.eq.0) print * ! if (mype.eq.0) print *,'RHSDIV START' ! call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), ! * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), ! * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), ! * th,p,pfy,qv,qc,qr,qia,qib,tke,pfz,inbr) !endif call rhsdiv(ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),rho,pfy,1) !if (V5D == 1) ! inbr=inbr+1 !=7 ! if (mype.eq.0) print *,'RHSDIV DONE' ! call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), ! * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), ! * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), ! * th,p,pfy,qv,qc,qr,qia,qib,tke,pfz,inbr) !endif if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),-1) if(mhd.eq.1) then do k=1,l do j=1,mp do i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) ox(i,j,k,2)= G11*bx(i,j,k,0)+G21*by(i,j,k,0) oy(i,j,k,2)= G12*bx(i,j,k,0)+G22*by(i,j,k,0) oz(i,j,k,2)= G13*bx(i,j,k,0)+G23*by(i,j,k,0)+G33*bz(i,j,k,0) enddo enddo enddo call rhsdiv(ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2), . oz(1-ih,1-ih,1,2),rh0,pfz,1) endif c call diagnos( u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), c * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), c * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c * th,p,x0,y0,z0,rho,the,pfx,pfy,thsum0,chm,gc1,gc2,gc3, c * tt,tend,qv,qc,qr,qia,qib,qws0,pfz,dtm,dragx(it),dragy(it),zs,zh, c * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),pfz) call diagnos(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), w(1-ih,1-ih,1,0), * ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,x0,y0,z0,rho,the,pfx,pfy,thsum0,chm,gc1,gc2,gc3, * tt,tend,qv,qc,qr,qia,qib,qws0,pfz,dtm,0.,0.,zs,zh, * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),pfz) #if ( ENERGY > 0) if( ianlfl.eq.1 ) then call energy(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0), oz(1-ih,1-ih,1,0), . th,p,ehise,ivis,kf) endif if( kf.eq.nfstop) then do k=1,nfstop write(21,111) k,(ehise(k,i),i=1,17) enddo endif 111 format(2x,i5,17(e15.7,1x)) #endif #if (GKS == 1) #if (PLOTPL == 1) call plot(th, u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0), * bz(1-ih,1-ih,1,0), * p,pfy,chm,qv,qc,qr,qia,qib,lipps,tke,pfz,tau(1,1-ih,1-ih,1)) if(ivis.eq.1) then call plothise(hise,it+1,nthv) call plotdrag(fmx,fmy,it) end if #endif #if (TURBPL == 1) call turban(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),th,p,qv,qc,qr,lipps,tke,ivis) #endif #if (VORTPL == 1) call vort(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),pfx,pfy,pfz,1) call plov(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0),th,pfx,pfy,pfz) #endif #endif #if (V5D == 1) inbr=inbr+1 call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,pfy,qv,qc,qr,qia,qib,tke,pfz,inbr) #endif end if ccccccccccccccccccccccccccccccccccc check for stability of computations ccccccccccccccccccccccccccccccccccc if(lagr.eq.1.and.cr2.gt.3.) then if (mype.eq.0) print 211,cr1,cr2,tt/timescale call end_code(iwr) stop 'lipshitz' endif if(lagr.eq.0.and.cr1.gt.3.) then c if(lagr.eq.0.and.cr1.gt.300.) then do 299 k=1,l do 299 j=1,mp do 299 i=1,np 299 pfx(i,j,k)=rho(i,j,k) if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0), 1) call rhsdiv(ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),rho,pfy,1) if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),-1) call diagnos( u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,x0,y0,z0,rho,the,pfx,pfy,thsum0,chm,gc1,gc2,gc3, * tt,tend,qv,qc,qr,qia,qib,qws0,pfz,dtm,dragx(it),dragy(it),zs,zh, * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),pfz) if (mype.eq.0) print 211,cr1,cr2,tt/timescale call end_code(iwr) stop 'courant' endif ccccccccccccccccccccccccccccccccccc close stability checks ccccccccccccccccccccccccccccccccccc 1000 continue 10 continue close time integration call ttend(1) call ttprt(mype,0) #endif /* ANALIZE == 0 */ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c analize old data from tape ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (ANALIZE > 0) tt=0.0 ! time (sec.) of first record in file it=0 ! timestep of first record in file ianlfl=nanlfl nfstop=ianlfl*nfil+(1-ianlfl)*nfilo icomm=1 ! don't touch c------------------------------------------------------------------ namex=4H e05 ! specials for labeling tapes chrate=2. ! visc=50.00e-3 ! c------------------------------------------------------------------ do 1000 kf=1,nfstop ! read stored files from 1st to nfstop if(ianlfl.eq.1) then tt=tt+dtfil(kf)*ntfil(kf) it=it+ntfil(kf) time=tt/timescale call ioread(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), c mod-restart . ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), . th,p,chm,fchm,fx,fy,fz,ft,fox,foy,foz,pm, .bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),fbx,fby,fbz, .bx(1-ih,1-ih,1,1),by(1-ih,1-ih,1,1),bz(1-ih,1-ih,1,1), .bxe(1-ih,1-ih,1),bye(1-ih,1-ih,1),bze(1-ih,1-ih,1), . qv,qc,qr,fqv,fqc,fqr, . qia,qib,fqia,fqib,tke,ftke,icomm) else tt=tt+dtfilo(kf)*ntfilo(kf) it=it+ntfilo(kf) time=tt/timescale call iorsh(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),th,p, . bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0), . icomm) c . w(1-ih,1-ih,1,0),chm,icomm) endif print 309, kf,time,tt 309 format(4x,' read tape; kf, time, tt:',i5,f7.2,e11.4) print 310,it,dt,time 310 format(8x,' it=',i5,' dt(sec)=',f7.2,' time(days)=',f7.2, & 'u=',e23.16) c------------------- if(kf.ge.nfstart) then ! begin analysis if(((kf-nfstart)/nplo*nplo.eq.(kf-nfstart)).or. . (kf.eq.nfstart)) then call topolog(x,y) call metryc(x,y,z) call tinit(z,x,y,tau,lipps,initi) !mod bbc ibbc=1 if(mhd.eq.1.and.ibbc.eq.1) then do j=1,mp do i=1,np dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = bz(i,j,2,0) bze(i,j,1) = bz(i,j,2,0)*(gactp/gacbt) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi * dt*dzi bze(i,j,l-1) = bz(i,j,l-1,0) bze(i,j,l) = bz(i,j,l-1,0)*(gacbt/gactp) enddo enddo call update(bze,np,mp,l,np,mp,1) call rhoswap( 1) call bbc call rhoswap(-1) endif if(ianlfl.eq.1) then if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0), 1) call rhsdiv(ox(1-ih,1-ih,1,0),oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),rho,pfy,1) if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,0), . oy(1-ih,1-ih,1,0), . oz(1-ih,1-ih,1,0),-1) if(irid.eq.1) . call rical(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),th,qv,qc,0) if(mhd.eq.1) . call rhsdiv(bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0), . bz(1-ih,1-ih,1,0),rh0,pfz,1) if(idia.eq.1) then call diagnos(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,x0,y0,z0,rho,the,pfx,pfy,thsum0,chm,gc1,gc2,gc3, * tt,tend,qv,qc,qr,qia,qib,qws0,pfz,dtm,0.,0.,zs,zh, * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0),bz(1-ih,1-ih,1,0),pfz) endif endif c call sumcns(chm(1-ih,1-ih,1,ichm1),pfy,rho,chemh(kf,ichm1),1) c call sumcns(chm(1-ih,1-ih,1,ichm2),pfy,rho,chemh(kf,ichm2),1) c call sumcns(chm(1-ih,1-ih,1,ichm3),pfy,rho,chemh(kf,ichm3),1) #if (GKS == 1) #if (PLOTPL == 1) call plot(th,u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * bx(1-ih,1-ih,1,0),by(1-ih,1-ih,1,0), * bz(1-ih,1-ih,1,0),p,pfy,chm,qv,qc,qr,qia,qib,lipps, * tke,pfz,tau(1,1-ih,1-ih,1)) #endif #if (TURBPL == 1) call turban(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),th,p,qv,qc,qr,lipps,tke,ivis) #endif #if (VORTPL == 1) call vort(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),pfx,pfy,pfz,1) if(kf.ne.1 .or. time.gt.0.) then call plov(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0),th, * pfx,pfy,pfz) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C itpwr=0 C if(itpwr.eq.1) then C iun=39+kf C write(iun) namex,chrate,visc,time C do k=1,l C do j=1,mp C do i=1,np C write(iun) u(i,j,k,0), v(i,j,k,0), w(i,j,k,0), C * chm(i,j,k,1),chm(i,j,k,2),chm(i,j,k,3), C * pfx(i,j,k) ,pfy(i,j,k) ,pfz(i,j,k) C enddo C enddo C enddo C endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC #endif #endif #if (V5D == 1) call vis5d_out(u(1-ih,1-ih,1,0), v(1-ih,1-ih,1,0), * w(1-ih,1-ih,1,0),ox(1-ih,1-ih,1,0), * oy(1-ih,1-ih,1,0),oz(1-ih,1-ih,1,0), * th,p,pfy,qv,qc,qr,qia,qib,tke,pfz,kf) #endif end if endif ! end analysis c------------------- 1000 continue ! end reading of records c------------------------------------------------------------------ if(ichm.eq.1) then do ispc=1,nspc print 789, (chemh(kf,ispc), kf=1,nfstop) enddo 789 format(4x,5e11.4) endif #endif /* ANALIZE == 1 */ call end_code(iwr) stop 'main' end c.....7..0.........0.........0.........0.........0.........0.........012 block data blanelas c set grid sizes with parameter statements include 'param.nml' include 'param.ior' include 'msg.inc' parameter (nml=n*m*l,nm=n*m,ml=m*l,nmp=np*mp) parameter (nmsgs=n*m,nmmsgs=nms*mms) parameter(nmsgsp=(np+2*ih)*(mp+2*ih), . nmmsgsp=(nmsp+2*ih)*(mmsp+2*ih)) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create basic setups c c-----------------------------------------------------------------c c---> dx,dy,dz - domain grid increments/dimensions c c If isphere=1 only need to specify dz c c If lxyz=1 do not specify ANY of dx,dy,dz c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c---> igrid=0 for A grid (default); c c---> igrid=1 for B grid (special option) c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc data igrid/0/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c I/O OPTIONS for different types of binary formats c c-----------------------------------------------------------------c c---> ioptr=0 read data from HP/Convex format c C on Cray set correct assign options c c---> ioptr=1 read data from Cray MPP (T3D,T3E) format c c---> ioptr=2 read data from Cray PVP (C90,J90,Y-MP) format c c c c---> ioptw=0 write data to HP/Convex format c C on Cray set correct assign options c c---> ioptw=1 write data to Cray MPP (T3D,T3E) format c c---> ioptw=2 write data to Cray PVP (C90,J90,Y-MP) format c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/hpcray/ ifcw,ifcr,ioptw,ioptr data ioptw,ioptr/0,0/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc CREATE/READ HISTORY (fort.9) AND ANLYSIS (fort.11) TAPE OF THE JOB c-----------------------------------------------------------------c c---> nrestr: restart file from the history tape (fort.10) c---> dtfil: dt in every file; c---> ntfil: number of dt in every file c---> nrestro: read file from the analysis tape (fort.12) c---> dtfilo: dt in every file; c---> ntfilo: number of dt in every file ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/histape/ dtfil(nfil ),dtfilo(nfilo), . ntfil(nfil ),ntfilo(nfilo), . nrestr,nresto data dtfil /nfil *dt_fil /,ntfil /nt_fil0 ,nfilm *nt_film0 / data dtfilo/nfilo*dt_filo/,ntfilo/nt_filo0,nfilom*nt_filom0/ data nrestr/nfil/,nresto/nfilo/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create initialization of environmental state, c see comments in subroutine tinit_i or tinit_r c-----------------------------------------------------------------c c--> initi=1 idealized initialization (tinit_i) c--> initi=0 realistic initialization from sounding (tinit_r) c--> lipps=0 Boussinesq c--> lipps=1 Anelastic, isentropic c--> lipps=2 Anelastic, Clark-Farley c--> lipps=3 Anelastic, isothermal ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/tinits/ initi,lipps data initi/1/ data lipps/1/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create model boundaries c c-----------------------------------------------------------------c c---> iab,iabth,iabqw - absorber flags for velocity, theta, water c c---> ipolar - EXPLICIT polar absorber flag c c ( can be nonzero ONLY if isphere = 1) c c---> dxabL- thickensses of left lateral absorbers in x [m] c c---> dxabR- thickensses of right lateral absorbers in x [m] c c---> dyab - thickensses of lateral absorbers in y [m] c c---> dyabp- thickensses of EXPL. lateral absorbers in y [m] c c---> zab - base of sponge in vertical (z) [m] c c---> towxL- absorber time scale in x (left side) [s] c c---> towxR- absorber time scale in x (right side) [s] c c---> towy - absorber time scale in y [s] c c---> towyp- explicit absorber time scale in y [s] c c---> towz - absorber time scale in z [s] c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/davpol/ relpol(np,mp,l),dyabp,towyp,ipolar data relx/nmp*0./,rely/nmp*0./ ! initializes arrays c data iab,iabth,iabqw/0,0,0/ c data iab,iabb,iabth,iabqw/1,1,0,0/ data iab,iabb,iabth,iabqw/0,0,0,0/ data dxabL,towxL/2800.,1.e10/ data dxabR,towxR/2800.,1.e10/ c ---- IMPLICIT lateral sponge parameters: regular - affect ALL vel. fields c data dyab ,towy /2800.e3,86400./ data dyab ,towy /2800.,86400./ c ---- special EXPLICIT POLAR sponge parameters (set up any of u,v,w,th in main) c ---- (see MAIN code to choose which fields to damp -- search on "ipolar") c ---- (see routine absorber for type of absorber, eg, "linear", ...) c --- RECOMMENDED HS SETTINGS: towyp such that ONLY 1 POINT is in absorber c Strongly Damp ONLY u & v (towyp/dt < 100) c iabth = 0 (eg, do NOT damp theta field) data ipolar/0/ ! flag for use of scalar sponge c data dyabp,towyp/0.278e6, 1000./ ! 2.5 degrees of latitude: Earth c data dyabp,towyp/0.278e6, 2400./ ! 2.5 degrees of latitude: Earth c data dyabp,towyp/0.278e6, 4500./ ! 2.5 degrees of latitude: Earth c data dyabp,towyp/0.278e6, 8600./ ! 2.5 degrees of latitude: Earth c data dyabp,towyp/0.278e6,13300./ ! 2.5 degrees of latitude: Earth c data dyabp,towyp/0.500e6, 8600./ ! 4.5 degrees of latitude: Earth c data dyabp,towyp/0.834e6, 8600./ ! 7.5 degrees of latitude: Earth c data dyabp,towyp/1.668e6,13300./ ! 15 degrees of latitude: Earth c data dyabp,towyp/2.222e8,8600./ ! 30 degrees of latitude: Sun c data dyabp,towyp/2.222e8,864000./ ! 15 degrees of latitude: Sun data dyabp,towyp/1.042e8,86400./ c ---- vertical sponge parameters cc data zab ,towz / 2.365e8,0.2592E+06/ !zab=(l-3)*dz00 cc data zab ,towz /-2.4053125e8,0.2592E+06/ !zab=(l-6)*dz00 data zab ,towz /0.e3,1.555e8/ !60 solar days 864000. c data zab ,towz /12.e3,864000./ c data zab ,towz / 2.365e8,0.2592E+06/ !zab=(l-3)*dz00 ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common block for pressure boundary treatment ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/indx/ e1,e2,e3 c data e1,e2,e3/1.,0.,0./ ! 0_th order cc data e1,e2,e3/1.5,-0.5,0./ ! 1_th order data e1,e2,e3/1.875,-1.250,0.375/ ! 2_nd order; default ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common block for inflow/outflow velocity dignostics c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/vbcdg/ vbcdiag(9) data vbcdiag/9*0./ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common block for grag coefficients ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/dragc/ dragx(nth),dragy(nth),drgnorm, itd, idrag data dragx/nth*0./,dragy/nth*0./ data idrag/0/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc constants for pressure solver; c c-----------------------------------------------------------------c c---> itp_,epp_ are max number of iterations and constraint of c c---> accuracy max|1/rho*div(rho*v)*dt| and run, correspondingly for itp0,epp0 and itp1,epp1; c c---> see string "epp1=" for other opt. c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/itero0/ epp0,epp1,itp0,itp1 data itp0,epp0,itp1,epp1/600,1.e-6,300,1.e-5/ c --- niter,nitav are number/average number of pressure c iterations at/up to a given timestep c --- miter,mitav are number/average number of pressure c iterations at/up to a given timestep in the outer c mtri loop if mtrord=2. common/itero/ niter,nitsm,icount,miter,mitsm,jcount,eer,eem data niter,nitsm,icount,miter,mitsm,jcount,eer,eem/6*0,2*0./ common/iterb/ niteb,nitsb,icounb,miteb,mitsb,jcounb,erb,emb data niteb,nitsb,icounb,miteb,mitsb,jcounb,erb,emb/6*0,2*0./ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create basic constants (tt00,th00,pr00,rh00 must be consistent): c c-----------------------------------------------------------------c c---> g - gravity (m/s^2) c c---> rg - dry gas constant (J/kgK) c c---> tt00 - ground level temperature (K) c c---> th00 - ground level potential temperature (K) c c---> pr00 - ground level pressure (Pa) c c---> rh00 - ground level density (kg/m^3) c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z data g,rg,tt00,th00,pr00,rh00 ! 1 /182.03,13732.,1.79e6,1.79e6,8.90e11,36.2/ !Rafaella Yoda 1 /717.3286,13732.,3621558.24986,2.3222e6,2.01379e13,404.9355/ !sun - ambient values cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create environmental profiles (use subroutine tinit_i) c c-----------------------------------------------------------------c c---> u00 - wind constant; x component, profile U (m/s) c c---> v00 - wind constant; y component, profile V (m/s) c c---> st - stability parameter; inverse scale height (m^-1) c c---> u0z - vertical wind shear dU/dz (s^-1) c c---> v0z - vertical wind shear dV/dz (s^-1) c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc data u00, v00, st, u0z, v0z c $ /20., 0., 1.02e-5, 0.e-3, 0.e-3/ $ /0.0, 0.0, 0.000, 0.e-3, 0.e-3/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create time-dependent lower boundary; specifics in topolog routine ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) data zs,zh,gi,s13,s23,h13,h23/nmsgsp*0.,nmsgsp*0.,nmsgsp*0., . nmsgsp*0.,nmsgsp*0.,nmsgsp*0.,nmsgsp*0./ common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) data zsd,zhd,strxd,stryd/nmsgsp*0.,nmsgsp*0.,nmsgsp*0.,nmsgsp*0./ data strxx,strxy,stryx,stryy . /nmsgsp*1.,nmsgsp*0.,nmsgsp*0.,nmsgsp*1./ data xcr,ycr/nmsgsp*0.,nmsgsp*0./ data xr1,xr2,xc1,xc2/mp*0.,mp*0.,mp*0.,mp*0./ data tt,tend/0.,-1.e10/ data time/0./ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc coriolis force specification c c-----------------------------------------------------------------c c---> fcr0 - coriolis parameter (s^-1) c c---> ang - f=fcr0*sin(ang) for f- or beta-plane approximation c c---> btpl - beta-plane approximation on or off c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs c data fcr0,ang,initprs/0.,0.,0/ ! tank c data fcr0,ang,initprs/20.76e-6,30.,0/ ! BPTau - 7 days c data fcr0,ang,initprs/1.4532e-5,30.,0/ ! BPTau - 10 days c data fcr0,ang,initprs/10.3888e-6,30.,0/ ! BPTau - 14 days c data fcr0,ang,initprs/6.6111e-6,0.,0/ ! Sun - 22 days data fcr0,ang,initprs/6.060171e-6,0.,0/ ! Sun - 24 days c data fcr0,ang,initprs/4.55104e-6,0.,0/ ! BPTau - 28 days c data fcr0,ang,initprs/5.0153e-6,0.,0/ ! sun - 29 days data btpl/0./ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c---> rd - sphere radius bottom domain (m) c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) data rds/ 4.17594e8/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create algorithm for sperical metric forces c c-----------------------------------------------------------------c c---> mtrord - order of approximation (1 or 2), mtrord=3 beta plane c---> mtrimx - No of iterations (ge.2) for mtrord=2 c c---> mtrord=mtrord*isphere+1-isphere c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/metrif/ mtrord,mtrimx data mtrord,mtrimx/2,2/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create variables for SGS model c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes data hfx/nmsgsp*0./,qfx/nmmsgsp*0./ c-----------------------------------------------------------------c c turbulent scaling parameters as given by Schumann in c c Theor. Comp. Fluid Dyn (1991) 2:279-290; note that Prndt=cm/ch c c-----------------------------------------------------------------c common/sgscnst/ ceps,cL,cm,css,prndt c salt in water c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/685.3973/ !Gill c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/1.00/ !Gill c salty water + heat c (salt diffusivity neglected, added viscosity taken into account) c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/7.458/ !Schumann c atmospheric air c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/.42/ !Schumann c data ceps/.930/,cL/1.e15/,cm/.1000/,css/.180/,prndt/.33/ !Moeng-Nieuwstadt c solar convection c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/0.5/ !SUN c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/0.1/ !SUN data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/1.0/ !SUN c data ceps/.845/,cL/0.845/,cm/.0856/,css/.165/,prndt/100.0/ !SUN c-----------------------------------------------------------------c common/stresd/ diagstr(8),ivis,irid,itstr common/strese/ diagste(12) data diagstr/8*0./,diagste/12*0./ data ivis,itkes/ivs0,itke/ common/slip/ noslip !mod bbc common/slipb/ noslipb data noslip/0/ data noslipb/1/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c surface layer fluxes for heat/moisture/momentum c c-----------------------------------------------------------------c c---> hf00 - sensible heat flux [K m/s] c c---> qf00 - latent heat flux [kg/kg m/s] c c---> cdrg - drag coefficient c c---> inorm- normalization switch c c---> zi - height of lowest inversion (min Richardson number) c c---> wstr - scaling vertical velocity in mixin-layer theory c c---> tstr - sclaing temperature in mixin-layer theory c c---> qstr - scaling water-vapor mixing ratio in mixin-layer theory ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm data inorm/0/,zi,wstr,tstr,qstr/4*1./ c Sun - hf00=sls/(cp*4*pi*rds**2) data hf00/4.959e3/,qf00/0.e-3/,cdrg/0.000/ !Sun rds=424.75Mm c data hf00/3.579e3/,qf00/0.e-3/,cdrg/0.000/ !Sun rds=500Mm c data hf00/1.7895e3/,qf00/0.e-3/,cdrg/0.000/ c data hf00/0.89475e3/,qf00/0.e-3/,cdrg/0.000/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create HF filter from the upwind option in transport schemes c c-----------------------------------------------------------------c c---> liner - flag for activating mpfl'th smoothing c---> mpfl - decrease to first order every mpfl'th timestep c---> ampd - advection order operator for mpflth smoothing ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) data mpfl,kampd/nth,3*0/ !default c data mpfl,kampd/1,3*0/ !default ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc construct moist model c-----------------------------------------------------------------c create condensation/evaporation constants common/cmoist/ rv,t00,ee0,hlat data rv,t00,ee0,hlat/461.,273.16,611.,2.53e6/ create rain constants (ice=0 case) common/rain/ rac,qctr,rc data rac,qctr,rc/1.e-3, .005e-3, 2.2/ c data rac,qctr,rc/1.e-3, .5e-1, 2.2/ common/dftemp/dftmx,dftmn,dftav,dftsd data dftmx,dftmn,dftav,dftsd/4*0./ c time step of microphysical model (no more than 30s for explicit) common/tmoist/ dtm data dtm/30./ ! Wojtek recommends dtm < 300 s cc initialization for ice=1 case common/rain_p0/ ar,br,cr,dr,er,alphr,betr,gamb1r,gambd1r,anor common/rain_p1/ dconc,ddisp common/snow_p0/ as,bs,cs,ds,es,alphs,bets,gamb1s,gambd1s,anos common/temp_p/ tup,tdn common/latent/ hlatv,hlats create parametrs for general precip formulation: cc mass, terminal velocity, diameter data ar,br,cr,dr /5.2e2,3.,130.,0.5/ data as,bs,cs,ds /2.5e-2,2.,4.,0.25/ cc collection ef., alpha, beta data er,alphr,betr /0.8, 1., 2./ data es,alphs,bets /0.2, .3, 3./ cc No data anor,anos /2*1.e7/ cc latent heats: data hlatv,hlats /2.53e6,2.84e6/ cc cloud droplet concentration (per cc) data dconc /200./ ! must be between 50 and 2000 cc limiting temperatures data tup,tdn /273.,263./ cc gammas: data gamb1r,gambd1r /6.0,11.7/ data gamb1s,gambd1s /2.0,2.56/ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create mountain c-----------------------------------------------------------------c c amp - maximum height of mountain [m] c xml - zonal scale of mountain [m] or [radians] c xml0 - zonal shift from the domain center [m] or [radians] c yml - meridional scale of mountain [m] or [radians] c yml0 - meridional shift from the domain center [m] or [radians] c angle- angle to skew the mountain ridge [radians] ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc common/gora/ xml,yml,amp,xml0,yml0,angle data amp,xml,yml,xml0,yml0,angle/0.,0.e0,0.,3*0./ c data amp,xml,yml,xml0,yml0,angle/2.e3,2*.34906585,3*0./ end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c c SUBROUTINES INIT / FINALIZE / CHECK SETUP CONSISTENCY c c c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine check_error(lipps) include 'param.nml' include 'msg.inc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z c---------------------------------------------------------- c --- check basic computational setup if (nth.lt.nt) then write(*,7) 7 format('+++error: nth < nt. nth =',i8,' nt=',i8) stop end if #if (SEMILAG == 0) if(lagr.eq.1) then print *,'+++error: lagr=1 but SEMILAG=0' stop endif #else if(lagr.eq.0) then print *,'+++error: lagr=0 but SEMILAG=1' stop endif #endif #if (J3DIM == 0) if(m.ne.1) then print *,'+++error: m=/=1 but J3DIM=0' stop endif #else if(m.eq.1) then print *,'+++error: m=1 but J3DIM=1' stop endif #endif if (icyz.eq.1) then c if (lipps.ne.-1) then c print *,'+++error: with icyz=1 lipps must be -1' if (lipps.ne.0) then print *,'+++error: with icyz=1 lipps must be 0' stop endif if (st.ne.0.) then print *,'+++error: with icyz=1 st must be 0.' stop endif endif check absorber thickness c if(dxab.gt.((n-1)*dx).or.(dyab*j3).gt.((m-1)*dy)) c . stop 'absorber thicker than doMAin' c---------------------------------------------------------- c --- check basic physical setup c---------------------------------------------------------- check moisture parameters #if (MOISTMOD == 0) if(moist.eq.1) then print *,'+++error: moist=1 but MOISTMOD=0' stop endif #endif #if (MOISTMOD > 0) if(moist.eq.0) then print *,'+++error: moist=0 but MOISTMOD=/=0' stop endif #if (MOISTMOD == 1) if(iceab.eq.1) then print *,'+++warning: iceab=1 but MOISTMOD=1' print *,'+++set iceab=0 for degrading qia,qib,fqia,fqib' print *,'+++or comment following "stop" command' stop endif #endif #endif check equation of state at surface perr=(1.-rh00*rg*tt00/pr00)*100. if(abs(perr).gt.5.) then print*,'+++warning: eq. of state is', . ' in error by',perr,'% at surface' c special c stop else print*,' eq. of state is in error by',perr,'% at surface' end if check domain depth if(lipps.eq.0) then zmax=pr00/(rh00*g) if(zmax.gt.zb) then print*,' maximum profile alt. =',zmax/1000,'kms' else print*,'+++warning: maximum profile alt. =', . zmax/1000.,'kms' print*,' but zb =', . zb/1000.,'kms' c stop end if end if if(lipps.eq.1) then capi=1./cap sdi=1./7000. ! density scale height (m^-1) zmax=capi/sdi if(zmax.gt.zb) then print*,' maximum profile alt. =',zmax/1000,'kms' else print*,'+++warning: maximum profile alt. =', . zmax/1000.,'kms' print*,' but zb =', . zb/1000.,'kms' stop end if end if if(lipps.eq.2) then cs=g/(cp*tt00*st) zmax=-alog(1.-1./cs)/st if(zmax.gt.zb) then print*,' maximum profile alt. =',zmax/1000,'kms' else print*,'+++warning: maximum profile alt. =', . zmax/1000.,'kms' print*,' but zb =', . zb/1000.,'kms' c special c stop end if end if return end subroutine init_code(ioptwr) include 'param.nml' include 'msg.inc' common /hpcray/ ifcw,ifcr,ioptw,ioptr #if (PARALLEL == 1) #if (SGI_O2K > 0) call start_pes(0) #endif #endif #if (PARALLEL == 2) call MPI_Init(ierr) COLD if (mype.eq.0) call time_comp(0) #endif c set geometry information for each processor, i.e., c where it is, who its neighbors are, etc. call geomset() c test updates configuration, go to 'test' for details c call test c call testreal #if (GKS == 1) call opngks call gsclip(0) call ncargdef #endif if (mype.eq.0) then print *,'*** STARTING TIME ***' call timefun() end if call ttini() #if (HP > 0 || SGI_O2K > 1 ) if (mype.eq.0) then if(ioptwr.gt.0) then #if (HP > 0) ifcr = CRAYOPEN ("./ftn09", 0, o'644') #endif #if (SGI_O2K > 1) ifcw = CRAYOPEN ("./fort.9", 1, o'644') #endif endif if(ioptr.gt.0) then #if (HP > 0) ifcr = CRAYOPEN ("./ftn10", 0, o'644') #endif #if (SGI_O2K > 1) ifcr = CRAYOPEN ("./fort.10", 0, o'644') #endif endif endif #endif return end subroutine end_code(ioptwr) include 'param.nml' include 'msg.inc' common /hpcray/ ifcw,ifcr,ioptw,ioptr #if (GKS == 1) call clsgks #endif #if (HP > 0 || SGI_O2K > 1 ) if(ioptwr.gt.0) then if (mype.eq.0) then ierr = CRAYCLOSE (ifcw) endif endif #endif if (mype.eq.0) then print *,'*** ENDING TIME ***' call timefun() end if #if (PARALLEL == 2) COLD if (mype.eq.0) call time_comp(-1) call MPI_Finalize(ierr) #endif return end #if (PARALLEL == 2) subroutine time_comp(it) include 'param.nml' include 'msg.inc' real*8 timeval,timestart,timeit,timestart0 common/timecp/ timeval,timestart,timeit,timestart0 if (mype.eq.0) then timeit = MPI_Wtime() CTEST print *,'time_comp:',it,timeit if (it.eq.0) then timestart = timeit timestart0= timestart else if (it.lt.0) then timeval = timeit - timestart0 write(*,*)'wallclock time - total =',timeval,'sec' print *,timeval,timestart,timeit,timestart0 else timeval = timeit - timestart timestart = timeit write(*,*)'wallclock time in timecount:',it,' =',timeval,'sec' endif endif endif return end #endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c c SUBROUTINES TOPOGRAPHY / MESH GEOMETRY c c c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccc subroutine topolog(x,y) ccccccccccccccccccccccccccccccccccccccccc include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif dimension x(n),y(m) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) dimension xr3(mp),xr4(mp),xc3(mp),xc4(mp), + yr3(np),yr4(np),yc3(np),yc4(np) #if (PARALLEL == 0) equivalence (xr1,xr3),(xr2,xr4),(xc1,xc3),(xc2,xc4), + (yr1,yr3),(yr2,yr4),(yc1,yc3),(yc2,yc4) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/mihaistr/ acns,beta,dzb,hpsl,kst common/gora/ xml,yml,amp,xml0,yml0,angle parameter(syfact=2., iyorder=5, + sycoef1=1./syfact,sycoef2=(syfact-1.)/syfact) parameter(sxfact=2., ixorder=5, + sxcoef1=1./sxfact,sxcoef2=(sxfact-1.)/sxfact) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c--> itopo=1 - read topo array from tape and redistribute it to pe's c--> ntop,mtop - dimension of topo array from tape c--> if (ntop.ne.n) or (mtop.ne.m) then we need interpolation ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter(itopo=0,ntop=n,mtop=m) dimension zstmp(np,mp), ! tmp array for transfer between pe's . zsfull(n,m), ! topo array on full domain (size n x m) . zstape(ntop,mtop) ! topo araay on tape (size ntop x mtop) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c MOUNTAIN SHAPE FUNCTIONS cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc construct fortran statement functions for the boundary shape create time dependence of the lower boundary; if time dependent lower boundary condition is used for initialisation make sure tend is multiple of dt construct fortran statement functions for the boundary shape c++++++++++++++++++++++++++ C Williamson et al. test case c rd(xln,ylt)=sqrt((xln/xml)**2+(ylt/yml)**2) c profm(rad)=amax1(0.,1.-rad) c profm(rad)= exp(-rad**2) c profm(rad)=.5*(1.+cos(pi*rad)) c++++++++++++++++++++++++++ c special for the conical mountain on the pole ccccc c rd(xln,ylt)=abs(ylt-y0) c profm(rad)=amax1(0., 1.-gamm*rad/rnot) c rnot = 2*acos(-1.)/128. * 10. c gamm=1. c++++++++++++++++++++++++++ c rd(xx,yy)=sqrt((xx/xml)**2+j3*(yy/yml)**2) c fi(rad)=amp*exp(-rad**2) c fi(rad)=.5*(1.+cos(pi*rad)) c fi(rad)=amp/(1.+rad**2) ! klemp mountain c fi(rad)=amp*exp(-(rad/xml)**2)*(cos(pi*rad*.25e-3))**2 c membranas c fi(rad)=-.5*(1.+cos(pi*rad)) c fid(rad)=.5*pi*sin(pi*rad) ! hyd. jump c fi(rad)=amp/(sqrt(1.+rad**2))**3 ! cylindrical annulus c fi(rad,is,r1,r2)=(rad**2/r1**2)* c . (1.-( ( ((r2/r1)**(is+2))-1.)*((rad/r1)**(is-2)) c . +( ((r2/r1)**(is-2))-1.)*((r2/rad)**(is+2)) ) c . /(((r2/r1)**(2*is))-1.) ) c fid(rad)=0. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc construct statement functions for the horizontal coordinate mapping cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c domains are: -1 < yln < 1 and -1 < xln < 1 c and ranges are: -1 < yphy < 1 and -1 < xphy < 1 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c IDENTITY TRANSFORMATION (DEFAULT) c xphy(xln,yln,tln)=xln ! X0 c yphy(xln,yln,tln)=yln ! Y0 c++++++++++++++++++++++++++ c --- Y GRID STRETCHING c syfact - stretching factor at y00 c iyorder - order of polynomial function (odd order >= 3 required) c sycoef1 - inverse stretching factor at equator c sycoef2 - nonlinear coefficient c yphy(xln,yln,tln)=sycoef1*yln+sycoef2*yln**iyorder ! Y_[-1,1] C yphy(xln,yln,tln)=yln*(sycoef1 + (1.-sycoef1)*yln*yln* ! Y_cyc C + (10.-15.*yln+6.*yln*yln) ) ! Y_[0,1] c++++++++++++++++++++++++++ c --- X GRID STRETCHING c sxfact - stretching factor at x00 c ixorder - order of polynomial function (odd order >= 3 required) c sxcoef1 - inverse stretching factor at equator c sxcoef2 - nonlinear coefficient c xphy(xln,yln,tln)=sxcoef1*xln+sxcoef2*xln**ixorder ! X_[-1,1] cc xphy(xln,yln,tln)=xln*(sxcoef1 + (1.-sxcoef1)*xln*xln* ! X_cyc cc + (10.-15.*xln+6.*xln*xln) ) ! X_[0,1] cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (TIMEPLT == 1) call ttbeg(6) #endif c definitions for mihai vertical stretching beta = 1. if (istab.eq.1) then select case(l) case(24) kst = 8 !top of stable layer below SCZ case(47) kst = 15 !top of stable layer below SCZ case(64) kst = 19 !top of stable layer below SCZ case(93) kst = 29 !top of stable layer below SCZ case(185) kst = 57 !top of stable layer below SCZ end select endif c beta = 2.0 if (istab.eq.1) then hpsl=dz*(kst-1.) else hpsl=-1. endif acns = alog((1.+(exp(beta)-1.)*dzb)/ & (1.+(exp(-beta)-1.)*dzb))/(2.*beta) !mihai c----------------- end of mihai vertical stretching defintions pi=acos(-1.) pi2=2.*pi pih=pi/2. piho=1./pih pi2o=1./pi2 xnorm=x(n)-x(1) ynorm=y(m)-y(1) xnormi=1./xnorm ynormi=float(j3)/(float(1-j3)+j3*ynorm) xml=pi/9. yml=xml c--- compute horizontal grid point "physical" locations do j=1,mp do i=1,np ia=(npos-1)*np + i ja=(mpos-1)*mp + j c xcr(i,j)=xnorm*xphy(x(ia)*xnormi,y(ja)*ynormi,tt) c ycr(i,j)=ynorm*yphy(x(ia)*xnormi,y(ja)*ynormi,tt) xcr(i,j)=x(ia)*(rds*isphere+(1-isphere)) ycr(i,j)=y(ja)*(rds*(isphere+icylind)+(1-(isphere+icylind))) enddo enddo c do j=1,mp c ja=(mpos-1)*mp + j c if(npos.eq.1) print *,'ycr:',ja,ycr(1,j)/rds c enddo c do i=1,np c ia=(npos-1)*np + i c if(mpos.eq.1) print *,'xcr:',ia,xcr(i,1)/rds c enddo c------------------------------------------------------------------ compute topografy angep=ang-1.e-10 cang=cos(pi*angle/180.) sang=sin(pi*angle/180.) yj0=pi/180.*ang x0 = 1.5*pi*isphere+(1-isphere)*0.5*(x(1)+x(n)) y0 = pi/6. *isphere do 20 j=1,mp do 20 i=1,np ia=(npos-1)*np + i ja=(mpos-1)*mp + j c --- compute trig and coriolis functions yj=ycr(i,j)*rdsi icoord=isphere+icylind cosa(i,j)=cos(yj)*icoord+(1-icoord)*1. sina(i,j)=sin(yj)*icoord+(1-icoord)*0. tnga(i,j)=tan(yj)*icoord+(1-icoord)*0. fcr2(i,j)=icoord*fcr0*cosa(i,j) * +(1-icoord)*fcr0*(cos(yj0)-btpl*sin(yj0)*yj) fcr3(i,j)=icoord*fcr0*sina(i,j) * +(1-icoord)*fcr0*(sin(yj0)+btpl*cos(yj0)*yj) c --- compute lower boundary deflection c xx= cang*(x(ia)-x0)+sang*(y(ja)-y0) c yy=-sang*(x(ia)-x0)+cang*(y(ja)-y0) c rr=rd(xx,yy) zs(i,j)= 0. zsd(i,j)= 0. zh(i,j) = zb zhd(i,j)= 0. c zs(i,j)=amp*profm(rr) c zs(i,j)=amp*cvmgmxx(0.,profm(rr),1-rr) zs(i,j)=0. if( tt.eq. 0. ) then zh(i,j)=zb zhd(i,j)=0. endif 20 continue C nois=0 C if(nois.eq.1) then C ampns=0.5e-3*nois C call nois2(zs,zsd,1) C call nois2(zh,zhd,2) C do j=1,mp C do i=1,np C zsd(i,j)= 0. C zs(i,j)=ampns*zs(i,j) C zhd(i,j)= 0. C zh(i,j)=ampns*zh(i,j)+(l-1)*dz C enddo C enddo C endif if (itopo.eq.1) then !read topografy from tape if (mype.eq.0) then call readtopo0(zs,zstmp,zstape,zsfull,ntop,mtop) else call readtopok(zs,zstmp) end if endif call update( xcr,np,mp,1,np,mp,iup) call update( ycr,np,mp,1,np,mp,iup) call update(cosa,np,mp,1,np,mp,iup) flush(6) #if (POLES == 1) c-------------------------------------------c create values for metric terms at the boundary c-------------------------------------------c #if (PARALLEL > 0) do j=1,mp xr3(j)=0. xc3(j)=0. xr4(j)=0. xc4(j)=0. enddo do i=1,np yr3(i)=0. yc3(i)=0. yr4(i)=0. yc4(i)=0. enddo #endif if (leftedge.eq.1) then do j=1,mp xr3(j)=xcr(1,j) xc3(j)=ycr(1,j) enddo endif if (rightedge.eq.1) then do j=1,mp xr4(j)=xcr(np,j) xc4(j)=ycr(np,j) enddo endif if (botedge.eq.1) then do i=1,np yr3(i)=xcr(i,1) yc3(i)=ycr(i,1) enddo endif if (topedge.eq.1) then do i=1,np yr4(i)=xcr(i,mp) yc4(i)=ycr(i,mp) enddo endif #if (PARALLEL > 0) CALL MPI_ALLReduce(xr3,xr1,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xr4,xr2,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xc3,xc1,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xc4,xc2,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(yr3,yr1,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yr4,yr2,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yc3,yc1,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yc4,yc2,np,DC_TYPE,MPI_SUM,my_col,ier) #endif if (leftedge.eq.1) then do j=1,mp xcr(0,j)=xr2(j)-pi2*rds ycr(0,j)=xc2(j) enddo endif if (rightedge.eq.1) then do j=1,mp xcr(np+1,j)=xr1(j)+pi2*rds ycr(np+1,j)=xc1(j) enddo endif if (botedge.eq.1) then do i=1,np ia=(npos-1)*np + i ib=ip(ia) ic=ib-n/2 xcr(i,0)= xcr(i,1) ycr(i,0)= ycr(i,1) ! yc1(ic) ! if(mype.eq.2) print*,'STRA:',i,xcr(i,0),xcr(i,1),xcr(i,2), ! . ycr(i,0),ycr(i,1),ycr(i,2) enddo endif if (topedge.eq.1) then do i=1,np ia=(npos-1)*np + i ib=ip(ia) ic=ib-n/2 xcr(i,mp+1)= xcr(i,mp) ycr(i,mp+1)= ycr(i,mp) ! yc2(ic) enddo endif #endif c-------------------------------------------c create boudary values for absorber definition c-------------------------------------------c #if (PARALLEL > 0) do j=1,mp xr3(j)=0. xc3(j)=0. xr4(j)=0. xc4(j)=0. enddo do i=1,np yr3(i)=0. yc3(i)=0. yr4(i)=0. yc4(i)=0. enddo #endif if (leftedge.eq.1) then do j=1,mp xr3(j)= xcr(1,j) xc3(j)=cosa(1,j) enddo endif if (rightedge.eq.1) then do j=1,mp xr4(j)= xcr(np,j) xc4(j)=cosa(np,j) enddo endif if (botedge.eq.1) then do i=1,np yr3(i)= ycr(i,1) yc3(i)=cosa(i,1) enddo endif if (topedge.eq.1) then do i=1,np yr4(i)= ycr(i,mp) yc4(i)=cosa(i,mp) enddo endif #if (PARALLEL > 0) CALL MPI_ALLReduce(xr3,xr1,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xr4,xr2,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xc3,xc1,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(xc4,xc2,mp,DC_TYPE,MPI_SUM,my_row,ier) CALL MPI_ALLReduce(yr3,yr1,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yr4,yr2,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yc3,yc1,np,DC_TYPE,MPI_SUM,my_col,ier) CALL MPI_ALLReduce(yc4,yc2,np,DC_TYPE,MPI_SUM,my_col,ier) #endif ccccccccccccccccccccccccccccccccccccccccc compute lateral boundary conditions ccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then do j=1,mp zs(1,j)= zs(2,j) zh(1,j)= zh(2,j) enddo endif if (rightedge.eq.1) then do j=1,mp zs(np,j)= zs(np-1,j) zh(np,j)= zh(np-1,j) enddo endif endif if(ibcx.eq.1) then call updatelr(zs,np,mp,1,np,mp,1) call updatelr(zh,np,mp,1,np,mp,1) if (rightedge.eq.1) then do j=1,mp zs(np,j)= zs(np+1,j) zh(np,j)= zh(np+1,j) enddo endif endif if(ibcy.eq.0 )then if (botedge.eq.1) then do i=1,np zs(i,1)= zs(i,1+j3) zh(i,1)= zh(i,1+j3) enddo endif if (topedge.eq.1) then do i=1,np zs(i,mp)= zs(i,mp-j3) zh(i,mp)= zh(i,mp-j3) enddo endif endif if(ibcy.eq.1) then call updatebt(zs,np,mp,1,np,mp,1) call updatebt(zh,np,mp,1,np,mp,1) if (topedge.eq.1) then do i=1,np zs(i,mp)= zs(i,mp+1) zh(i,mp)= zh(i,mp+1) enddo endif endif #endif call update(zs,np,mp,1,np,mp,iup) call update(zh,np,mp,1,np,mp,iup) if(tt.le.tend) then #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then do j=1,mp zsd(1,j)= zsd(2,j) zhd(1,j)= zhd(2,j) enddo endif if (rightedge.eq.1) then do j=1,mp zsd(np,j)= zsd(np-1,j) zhd(np,j)= zhd(np-1,j) enddo endif endif if(ibcx.eq.1) then call updatelr(zsd,np,mp,1,np,mp,1) call updatelr(zhd,np,mp,1,np,mp,1) if (rightedge.eq.1) then do j=1,mp zsd(np,j)= zsd(np+1,j) zhd(np,j)= zhd(np+1,j) enddo endif endif if(ibcy.eq.0 )then if (botedge.eq.1) then do i=1,np zsd(i,1)= zsd(i,1+j3) zhd(i,1)= zhd(i,1+j3) enddo endif if (topedge.eq.1) then do i=1,np zsd(i,mp)= zsd(i,mp-j3) zhd(i,mp)= zhd(i,mp-j3) enddo endif endif if(ibcy.eq.1) then call updatebt(zsd,np,mp,1,np,mp,1) call updatebt(zhd,np,mp,1,np,mp,1) if (topedge.eq.1) then do i=1,np zsd(i,mp)= zsd(i,mp+1) zhd(i,mp)= zhd(i,mp+1) enddo endif endif #endif call update(zsd,np,mp,1,np,mp,iup) call update(zhd,np,mp,1,np,mp,iup) endif #if (PARALLEL == 0) iprint=0 if(iprint.eq.1) then if (leftedge.eq.1) then do j=1,mp ja=(mpos-1)*mp + j print *,'L:',ja,xr1(j),xc1(j) c print *,'L:',ja,xr1(j),xc1(j),yyy(j) enddo endif if (rightedge.eq.1) then do j=1,mp ja=(mpos-1)*mp + j print *,'R:',ja,xr2(j),xc2(j) enddo endif if (botedge.eq.1) then do i=1,np ia=(npos-1)*np + i print *,'B:',ia,yr1(i),yc1(i) enddo endif if (topedge.eq.1) then do i=1,np ia=(npos-1)*np + i print *,'T:',ia,yr2(i),yc2(i) enddo endif if(mype.eq.0) then print*,' zs(i,1)' write(6,990) (zs(i,1),i=1,np) print*,' zs(np,j)' write(6,990) (zs(np,j),j=1,mp) print*,' zh(i,1)' write(6,990) (zh(i,1),i=1,np) print*,' zh(np,j)' write(6,990) (zh(np,j),j=1,mp) print*,' xcr(i,1)' write(6,990) (xcr(i,1),i=1,np) print*,' xcr(np,j)' write(6,990) (xcr(np,j),j=1,mp) print*,' ycr(i,1)' write(6,990) (ycr(i,1),i=1,np) print*,' ycr(np,j)' write(6,990) (ycr(np,j),j=1,mp) print*,' cosa(i,1)' write(6,990) (cosa(i,1),i=1,np) print*,' cosa(np,j)' write(6,990) (cosa(np,j),j=1,mp) 990 format(2x,10(e15.7,1x)) end if end if #endif #if (TIMEPLT == 1) call ttend(6) #endif return end subroutine readtopo0(datarr,tmparray,tapearray,array,n1,m1) c c This subroutine reads topo from the file. c include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif dimension datarr(1-ih:np+ih,1-ih:mp+ih), ! final parallel topo . tmparray(np,mp), ! tmp parallel array . tapearray(n1,m1), ! topo on tape . array( n, m) ! topo on full domain common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 c----------------------------------- c read ascii data c----------------------------------- c do i=1,n1 c do j=1,m1 c read(13) tapearray(i,j) c end do c end do do i=1,n1 read(13,*) (tapearray(i,j), j=1,m1) enddo c------------------------------------------------------------ c interpolate topography from tape array if bad dimension c------------------------------------------------------------ if((n1.eq.n).and.(m1.eq.m)) then do j=1,m do i=1,n c array(i,j)=tapearray(i,j) array(i,j)=amin1(tapearray(i,j), zb-5*dz) end do end do else if ((n1.ne.n).or.(m1.ne.m)) then c put here interpolation procedure endif c------------------------------------------------------------ c transfer processor 0 data from big array to local array c------------------------------------------------------------ do j=1,mp do i=1,np datarr(i,j)=array(i,j) end do end do #if (PARALLEL > 0) c loop over all other processors, sending them their data do iproc=1,(nprocx*nprocy - 1) npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 do j=1,mp do i=1,np tmparray(i,j) = . array(((npos1-1)*np + i), ((mpos1-1)*mp + j)) end do end do nmp=np*mp #if (PARALLEL == 2) call MPI_Send(tmparray, nmp, DC_TYPE, iproc, 98, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif end do close #endif (PARALLEL > 0) #endif return end subroutine readtopok(datarr,tmparray) c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif dimension datarr(1-ih:np+ih,1-ih:mp+ih), . tmparray(np,mp) #if (PARALLEL > 0) c receive data from pe 0 nmp=np*mp #if (PARALLEL == 2) call MPI_Recv(tmparray, nmp, DC_TYPE, 0, 98, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readitk' stop end if #endif c transfer data to regular array do j=1,mp do i=1,np datarr(i,j)=tmparray(i,j) end do end do #endif return end ccccccccccccccccccccccccccccccccccccccccc subroutine metryc(x,y,z) ccccccccccccccccccccccccccccccccccccccccc include 'param.nml' include 'msg.inc' include 'vrtstr.mds' dimension x(n),y(m),z(l) real esxb(np,mp),esyb(np,mp),dsxb(np,mp),dsyb(np,mp) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/stretchpar/ SS common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/mihaistr/ acns,beta,dzb,hpsl,kst #include "vrtstr.fnc" c fs(zo)=(1.-exp(-zo/SD)) c fsi(zt)=-SD*alog(1.-zt/zb*fs(zb)) c fs(zo)=zo c fsi(zt)=zt #if (TIMEPLT == 1) call ttbeg(7) #endif ccccccccccccccccccccccccccccccccc c --- compute vertical stretching ccccccccccccccccccccccccccccccccc pi=acos(-1.) pirds = pi*rds pi2rds =2*pi*rds c SD=7000. SS=zb/fs(zb) SS=1. iprint=1 c if(mype.eq.0.and.iprint.eq.1) print 276,SS,zb,SD c 276 format(2x,'Stretching function parameters: ss,zb,sd:',3e11.4) do 1 j=1,mp do 1 i=1,np 1 gi(i,j)=zb/(zh(i,j)-zs(i,j)) c if(mype.eq.0.and.iprint.eq.1) print 4 do 2 k=1,l !GGstr: stretiching Chan&Sofia !next is eq (12) in the notes ! gmus(k) = SD*(rds+zb*fs(z(k)))**2/(log(1.+SD)*(SD*fs(z(k))+1.) * ! & (rds*(zb+rds))) ! zstr(k)=fs(z(k)) gmus(k)=(SS-z(k))/SD*istr+float(1-istr) zstr(k)=fsi(z(k)) gmul(k)=(zb-zstr(k)) if(icylind.eq.1) then do 333 j=1,mp do 333 i=1,np ia=(npos-1)*np + i 333 gmm(i,j,k)=rdsi*(x(ia)+rds) else do 3 j=1,mp do 3 i=1,np zcrl=zstr(k)/gi(i,j)+zs(i,j) 3 gmm(i,j,k)=1.+isphere*zcrl/rds endif !icylind c if(mype.eq.0.and.iprint.eq.1) c . print 5,k,z(k),fsi(z(k)),fs(z(k)),gmul(k),gmus(k) 2 continue 4 format(6x,'k',7x,'z',8x,'fsi',9x,'fs',9x,'gmul',9x,'gmus') 5 format(2x,i5,2x,f8.2,2x,f8.2,2x,f12.9,2x,f11.2,2x,f8.4) call update( gi,np,mp,1,np,mp,2) call update(gmm,np,mp,l,np,mp,iup) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c --- compute Jacobi and inverse Jacobi matrix elements ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge dx0=dxi*0.5 dy0=dyi*0.5 do i=illim,iulim c --- interior points do j=jllim,julim c --- compute dX/dXb esxb(i,j)=(xcr(i+1, j )-xcr(i-1, j ))*dx0 ! dx/d(xb) esyb(i,j)=(xcr( i ,j+j3)-xcr( i ,j-j3))*dy0 ! dx/d(yb) estb=0. ! dx/d(tb) dsxb(i,j)=(ycr(i+1, j )-ycr(i-1, j ))*dx0 ! dy/d(xb) dsyb(i,j)=(ycr( i ,j+j3)-ycr( i ,j-j3))*dy0 ! dy/d(yb) . +float(1-j3) dstb=0. ! dy/d(tb) c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(i,j)*esxb(i,j)-dsxb(i,j)*esyb(i,j)) strxx(i,j)= dsyb(i,j)*den ! d(xb)/dx strxy(i,j)=-esyb(i,j)*den ! d(xb)/dy strxd(i,j)=(dstb*esyb(i,j)-dsyb(i,j)*estb)*den ! d(xb)/dt stryx(i,j)=-dsxb(i,j)*den ! d(yb)/dx stryy(i,j)= esxb(i,j)*den ! d(yb)/dy stryd(i,j)=(estb*dsxb(i,j)-esxb(i,j)*dstb)*den ! d(yb)/dt ! if(stryy(i,j).lt.0) print*,'STRYY:',stryy(i,j), ! . i,j,den,dsyb,esxb,dsxb,esyb,ycr(i,j-1),ycr(i,j),ycr(i,j+1) enddo enddo #if (POLES == 0) if (botedge.eq.1) then c --- Southern boundary region j=1 c --- compute dX/dXb do 11 i=illim,iulim esxb(i,1)= (xcr(i+1,1 )-xcr(i-1, 1 ))*dx0 esyb(i,1)=(1-ibcy)*(xcr(i ,1+j3)-xcr(i , 1 ))*dyi * +ibcy *(xcr(i ,1+j3)-xcr(i ,-j3))*dy0 estb=0. dsxb(i,1)= (ycr(i+1,1 )-ycr(i-1, 1 ))*dx0 dsyb(i,1)=(1-ibcy)*(ycr(i ,1+j3)-ycr(i , 1 ))*dyi * +ibcy*(ycr(i ,1+j3)-ycr(i ,-j3)+ * ycr(i ,0 )-ycr(i , 1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(i,1)*esxb(i,1)-dsxb(i,1)*esyb(i,1)) strxx(i,1)= dsyb(i,1)*den strxy(i,1)=-esyb(i,1)*den strxd(i,1)=(dstb*esyb(i,1)-dsyb(i,1)*estb)*den stryx(i,1)=-dsxb(i,1)*den stryy(i,1)= esxb(i,1)*den 11 stryd(i,1)=(estb*dsxb(i,1)-esxb(i,1)*dstb)*den end if if (topedge.eq.1) then c --- Northern boundary region c --- compute dX/dXb do 12 i=illim,iulim esxb(i,mp)= (xcr(i+1,mp )-xcr(i-1,mp ))*dx0 esyb(i,mp)=(1-ibcy)*(xcr(i ,mp )-xcr(i ,mp-j3))*dyi * +ibcy *(xcr(i ,mp+1+j3)-xcr(i ,mp-j3))*dy0 estb=0. dsxb(i,mp)= (ycr(i+1,mp )-ycr(i-1,mp ))*dx0 dsyb(i,mp)=(1-ibcy)*(ycr(i ,mp )-ycr(i ,mp-j3))*dyi * +ibcy*(ycr(i ,mp+1+j3)-ycr(i ,mp-j3)+ * ycr(i ,mp )-ycr(i ,mp+1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(i,mp)*esxb(i,mp)-dsxb(i,mp)*esyb(i,mp)) strxx(i,mp)= dsyb(i,mp)*den strxy(i,mp)=-esyb(i,mp)*den strxd(i,mp)=(dstb*esyb(i,mp)-dsyb(i,mp)*estb)*den stryx(i,mp)=-dsxb(i,mp)*den stryy(i,mp)= esxb(i,mp)*den 12 stryd(i,mp)=(estb*dsxb(i,mp)-esxb(i,mp)*dstb)*den end if #else if (botedge.eq.1) then c --- Southern boundary region j=1, flow over the Southern Pole c --- compute dX/dXb do 11 i=illim,iulim esxb(i,1)=(xcr(i+1,1 )- xcr(i-1, 1 ))*dx0 c esyb(i,1)=(xcr(i ,1+j3)-(xcr(i ,1-j3)-pirds))*dy0 esyb(i,1)=(xcr(i ,1+j3)-xcr(i ,1-j3))*dy0 estb=0. dsxb(i,1)=(ycr(i+1,1 )-ycr(i-1, 1 ))*dx0 dsyb(i,1)=(ycr(i ,1+j3)+ycr(i ,1-j3)+pirds)*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(i,1)*esxb(i,1)-dsxb(i,1)*esyb(i,1)) strxx(i,1)= dsyb(i,1)*den strxy(i,1)=-esyb(i,1)*den strxd(i,1)=(dstb*esyb(i,1)-dsyb(i,1)*estb)*den stryx(i,1)=-dsxb(i,1)*den stryy(i,1)= esxb(i,1)*den 11 stryd(i,1)=(estb*dsxb(i,1)-esxb(i,1)*dstb)*den end if if (topedge.eq.1) then c --- Northern boundary region, flow over the Northern Pole c --- compute dX/dXb do 12 i=illim,iulim esxb(i,mp)=( xcr(i+1,mp ) -xcr(i-1,mp ))*dx0 c esyb(i,mp)=((xcr(i ,mp+j3)-pirds)-xcr(i ,mp-j3))*dy0 esyb(i,mp)=(xcr(i ,mp+j3)-xcr(i ,mp-j3))*dy0 estb=0. dsxb(i,mp)= (ycr(i+1,mp )-ycr(i-1,mp ))*dx0 dsyb(i,mp)=(pirds-ycr(i ,mp+j3)-ycr(i ,mp-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(i,mp)*esxb(i,mp)-dsxb(i,mp)*esyb(i,mp)) strxx(i,mp)= dsyb(i,mp)*den strxy(i,mp)=-esyb(i,mp)*den strxd(i,mp)=(dstb*esyb(i,mp)-dsyb(i,mp)*estb)*den stryx(i,mp)=-dsxb(i,mp)*den stryy(i,mp)= esxb(i,mp)*den 12 stryd(i,mp)=(estb*dsxb(i,mp)-esxb(i,mp)*dstb)*den end if #endif #if (POLES == 0) if (leftedge.eq.1) then do j=jllim,julim c --- Western boundary region c --- compute dX/dXb esxb(1,j)=(1-ibcx)*(xcr(2,j )-xcr( 1,j ))*dxi * +ibcx *(xcr(2,j )-xcr(-1,j )+ * xcr(0,j )-xcr( 1,j ))*dx0 esyb(1,j)= (xcr(1,j+j3)-xcr( 1,j-j3))*dy0 estb=0. dsxb(1,j)=(1-ibcx)*(ycr(2,j )-ycr( 1,j ))*dxi * +ibcx *(ycr(2,j )-ycr(-1,j ))*dx0 dsyb(1,j)= (ycr(1,j+j3)-ycr( 1,j-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,j)*esxb(1,j)-dsxb(1,j)*esyb(1,j)) strxx(1,j)= dsyb(1,j)*den strxy(1,j)=-esyb(1,j)*den strxd(1,j)=(dstb*esyb(1,j)-dsyb(1,j)*estb)*den stryx(1,j)=-dsxb(1,j)*den stryy(1,j)= esxb(1,j)*den stryd(1,j)=(estb*dsxb(1,j)-esxb(1,j)*dstb)*den enddo end if if (rightedge.eq.1) then do j=jllim,julim c --- Eastern boundary region c --- compute dX/dXb esxb(np,j)=(1-ibcx)*(xcr(np ,j )-xcr(np-1,j ))*dxi * +ibcx *(xcr(np+2,j )-xcr(np-1,j )+ * xcr(np ,j )-xcr(np+1,j ))*dx0 esyb(np,j)= (xcr(np ,j+j3)-xcr(np ,j-j3))*dy0 estb=0. dsxb(np,j)=(1-ibcx)*(ycr(np ,j )-ycr(np-1,j ))*dxi * +ibcx *(ycr(np+2,j )-ycr(np-1,j ))*dx0 dsyb(np,j)= (ycr(np ,j+j3)-ycr(np ,j-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,j)*esxb(np,j)-dsxb(np,j)*esyb(np,j)) strxx(np,j)= dsyb(np,j)*den strxy(np,j)=-esyb(np,j)*den strxd(np,j)=(dstb*esyb(np,j)-dsyb(np,j)*estb)*den stryx(np,j)=-dsxb(np,j)*den stryy(np,j)= esxb(np,j)*den stryd(np,j)=(estb*dsxb(np,j)-esxb(np,j)*dstb)*den enddo end if #else if (leftedge.eq.1) then do j=jllim,julim c --- Western boundary region c --- compute dX/dXb c esxb(1,j)=(xcr(2,j )-(xcr(0,j )-pi2rds))*dx0 esxb(1,j)=(xcr(2,j )-xcr(0,j ))*dx0 esyb(1,j)=(xcr(1,j+j3)- xcr(1,j-j3))*dy0 estb=0. dsxb(1,j)=(ycr(2,j )-ycr(0,j ))*dx0 dsyb(1,j)=(ycr(1,j+j3)-ycr(1,j-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,j)*esxb(1,j)-dsxb(1,j)*esyb(1,j)) strxx(1,j)= dsyb(1,j)*den strxy(1,j)=-esyb(1,j)*den strxd(1,j)=(dstb*esyb(1,j)-dsyb(1,j)*estb)*den stryx(1,j)=-dsxb(1,j)*den stryy(1,j)= esxb(1,j)*den stryd(1,j)=(estb*dsxb(1,j)-esxb(1,j)*dstb)*den enddo end if if (rightedge.eq.1) then do j=jllim,julim c --- Eastern boundary region c --- compute dX/dXb c esxb(np,j)=((xcr(np+1,j)+pi2rds)-xcr(np-1,j))*dx0 esxb(np,j)=(xcr(np+1,j)-xcr(np-1,j))*dx0 esyb(np,j)=(xcr(np ,j+j3)-xcr(np ,j-j3))*dy0 estb=0. dsxb(np,j)=(ycr(np+1,j )-ycr(np-1,j ))*dx0 dsyb(np,j)=(ycr(np ,j+j3)-ycr(np ,j-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,j)*esxb(np,j)-dsxb(np,j)*esyb(np,j)) strxx(np,j)= dsyb(np,j)*den strxy(np,j)=-esyb(np,j)*den strxd(np,j)=(dstb*esyb(np,j)-dsyb(np,j)*estb)*den stryx(np,j)=-dsxb(np,j)*den stryy(np,j)= esxb(np,j)*den stryd(np,j)=(estb*dsxb(np,j)-esxb(np,j)*dstb)*den enddo end if #endif #if (POLES == 0) if (botedge.eq.1) then if (leftedge.eq.1) then C --- SW corner c --- compute dX/dXb esxb(1,1)=(1-ibcx)*(xcr(2,1 )-xcr( 1, 1 ))*dxi * +ibcx *(xcr(2,1 )-xcr(-1, 1 )+ * xcr(0,1 )-xcr( 1, 1 ))*dx0 esyb(1,1)=(1-ibcy)*(xcr(1,1+j3)-xcr( 1, 1 ))*dyi * +ibcy *(xcr(1,1+j3)-xcr( 1,-j3))*dy0 estb=0. dsxb(1,1)=(1-ibcx)*(ycr(2,1 )-ycr( 1, 1 ))*dxi * +ibcx *(ycr(2,1 )-ycr(-1, 1 ))*dx0 dsyb(1,1)=(1-ibcy)*(ycr(1,1+j3)-ycr( 1, 1 ))*dyi * +ibcy *(ycr(1,1+j3)-ycr( 1,-j3)+ * ycr(1,0 )-ycr( 1, 1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,1)*esxb(1,1)-dsxb(1,1)*esyb(1,1)) strxx(1,1)= dsyb(1,1)*den strxy(1,1)=-esyb(1,1)*den strxd(1,1)=(dstb*esyb(1,1)-dsyb(1,1)*estb)*den stryx(1,1)=-dsxb(1,1)*den stryy(1,1)= esxb(1,1)*den stryd(1,1)=(estb*dsxb(1,1)-esxb(1,1)*dstb)*den endif if(rightedge.eq.1) then C --- SE corner c --- compute dX/dXb esxb(np,1)=(1-ibcx)*(xcr(np ,1 )-xcr(np-1, 1 ))*dxi * +ibcx *(xcr(np+2,1 )-xcr(np-1, 1 )+ * xcr(np ,1 )-xcr(np+1, 1 ))*dx0 esyb(np,1)=(1-ibcy)*(xcr(np ,1+j3)-xcr(np , 1 ))*dyi * +ibcy *(xcr(np ,1+j3)-xcr(np ,-j3))*dy0 estb=0. dsxb(np,1)=(1-ibcx)*(ycr(np ,1 )-ycr(np-1, 1 ))*dxi * +ibcx *(ycr(np+2,1 )-ycr(np-1, 1 ))*dx0 dsyb(np,1)=(1-ibcy)*(ycr(np ,1+j3)-ycr(np , 1 ))*dyi * +ibcy *(ycr(np ,1+j3)-ycr(np ,-j3) * +ycr(np ,0 )-ycr(np , 1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,1)*esxb(np,1)-dsxb(np,1)*esyb(np,1)) strxx(np,1)= dsyb(np,1)*den strxy(np,1)=-esyb(np,1)*den strxd(np,1)=(dstb*esyb(np,1)-dsyb(np,1)*estb)*den stryx(np,1)=-dsxb(np,1)*den stryy(np,1)= esxb(np,1)*den stryd(np,1)=(estb*dsxb(np,1)-esxb(np,1)*dstb)*den endif endif if (topedge.eq.1) then if (rightedge.eq.1) then C --- NE corner c --- compute dX/dXb esxb(np,mp)=(1-ibcx)*(xcr(np ,mp )-xcr(np-1,mp ))*dxi * +ibcx *(xcr(np+2,mp )-xcr(np-1,mp ) * +xcr(np ,mp )-xcr(np+1,mp ))*dx0 esyb(np,mp)=(1-ibcy)*(xcr(np ,mp )-xcr(np ,mp-j3))*dyi * +ibcy *(xcr(np ,mp+1+j3)-xcr(np ,mp-j3))*dy0 estb=0. dsxb(np,mp)=(1-ibcx)*(ycr(np ,mp )-ycr(np-1,mp ))*dxi * +ibcx *(ycr(np+2,mp )-ycr(np-1,mp ))*dx0 dsyb(np,mp)=(1-ibcy)*(ycr(np ,mp )-ycr(np ,mp-j3))*dyi * +ibcy *(ycr(np ,mp+1+j3)-ycr(np ,mp-j3)+ * ycr(np ,mp )-ycr(np ,mp+1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,mp)*esxb(np,mp)-dsxb(np,mp)*esyb(np,mp)) strxx(np,mp)= dsyb(np,mp)*den strxy(np,mp)=-esyb(np,mp)*den strxd(np,mp)=(dstb*esyb(np,mp)-dsyb(np,mp)*estb)*den stryx(np,mp)=-dsxb(np,mp)*den stryy(np,mp)= esxb(np,mp)*den stryd(np,mp)=(estb*dsxb(np,mp)-esxb(np,mp)*dstb)*den endif if(leftedge.eq.1) then C --- NW corner c --- compute dX/dXb esxb(1,mp)=(1-ibcx)*(xcr(2,mp )-xcr( 1,mp ))*dxi * +ibcx *(xcr(2,mp )-xcr(-1,mp )+ * xcr(0,mp )-xcr( 1,mp ))*dx0 esyb(1,mp)=(1-ibcy)*(xcr(1,mp )-xcr( 1,mp-j3))*dyi * +ibcy *(xcr(1,mp+1+j3)-xcr( 1,mp-j3))*dy0 estb=0. dsxb(1,mp)=(1-ibcx)*(ycr(2,mp )-ycr( 1,mp ))*dxi * +ibcx *(ycr(2,mp )-ycr(-1,mp ))*dx0 dsyb(1,mp)=(1-ibcy)*(ycr(1,mp )-ycr( 1,mp-j3))*dyi * +ibcy *(ycr(1,mp+1+j3)-ycr( 1,mp-j3)+ * ycr(1,mp )-ycr( 1,mp+1 ))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,mp)*esxb(1,mp)-dsxb(1,mp)*esyb(1,mp)) strxx(1,mp)= dsyb(1,mp)*den strxy(1,mp)=-esyb(1,mp)*den strxd(1,mp)=(dstb*esyb(1,mp)-dsyb(1,mp)*estb)*den stryx(1,mp)=-dsxb(1,mp)*den stryy(1,mp)= esxb(1,mp)*den stryd(1,mp)=(estb*dsxb(1,mp)-esxb(1,mp)*dstb)*den endif endif #else if (botedge.eq.1) then if (leftedge.eq.1) then C --- SW corner c --- compute dX/dXb c esxb(1,1)=(xcr(2,1 )-(xcr(0, 1 )-pi2rds))*dx0 esxb(1,1)=(xcr(2,1 )-xcr(0, 1 ))*dx0 c esyb(1,1)=(xcr(1,1+j3)-(xcr(1,1-j3)-pirds))*dy0 esyb(1,1)=(xcr(1,1+j3)-xcr(1,1-j3))*dy0 estb=0. dsxb(1,1)=(ycr(2,1 )-ycr(0, 1 ))*dx0 dsyb(1,1)=(ycr(1,1+j3)+ycr(1,1-j3)+pirds)*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,1)*esxb(1,1)-dsxb(1,1)*esyb(1,1)) strxx(1,1)= dsyb(1,1)*den strxy(1,1)=-esyb(1,1)*den strxd(1,1)=(dstb*esyb(1,1)-dsyb(1,1)*estb)*den stryx(1,1)=-dsxb(1,1)*den stryy(1,1)= esxb(1,1)*den stryd(1,1)=(estb*dsxb(1,1)-esxb(1,1)*dstb)*den endif if(rightedge.eq.1) then C --- SE corner c --- compute dX/dXb c esxb(np,1)=((xcr(np+1,1 )+pi2rds)-xcr(np-1, 1 ))*dx0 esxb(np,1)=(xcr(np+1,1)-xcr(np-1,1))*dx0 c esyb(np,1)=( xcr(np ,1+j3)-(xcr(np ,1-j3)-pirds))*dy0 esyb(np,1)=( xcr(np ,1+j3)- xcr(np ,1-j3))*dy0 estb=0. dsxb(np,1)=(ycr(np+1,1 )-ycr(np-1, 1 ))*dx0 dsyb(np,1)=(ycr(np ,1+j3)+ycr(np ,1-j3)+pirds)*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,1)*esxb(np,1)-dsxb(np,1)*esyb(np,1)) strxx(np,1)= dsyb(np,1)*den strxy(np,1)=-esyb(np,1)*den strxd(np,1)=(dstb*esyb(np,1)-dsyb(np,1)*estb)*den stryx(np,1)=-dsxb(np,1)*den stryy(np,1)= esxb(np,1)*den stryd(np,1)=(estb*dsxb(np,1)-esxb(np,1)*dstb)*den endif endif if (topedge.eq.1) then if (rightedge.eq.1) then C --- NE corner c --- compute dX/dXb c esxb(np,mp)=((xcr(np+1,mp)+pi2rds)-xcr(np-1,mp ))*dx0 esxb(np,mp)=(xcr(np+1,mp)-xcr(np-1,mp))*dx0 c esyb(np,mp)=((xcr(np,mp+j3)-pirds)-xcr(np,mp-j3))*dy0 esyb(np,mp)=( xcr(np,mp+j3)-xcr(np,mp-j3))*dy0 estb=0. dsxb(np,mp)=(ycr(np+1,mp )-ycr(np-1,mp ))*dx0 dsyb(np,mp)=(pirds-ycr(np,mp+j3)-ycr(np,mp-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(np,mp)*esxb(np,mp)-dsxb(np,mp)*esyb(np,mp)) strxx(np,mp)= dsyb(np,mp)*den strxy(np,mp)=-esyb(np,mp)*den strxd(np,mp)=(dstb*esyb(np,mp)-dsyb(np,mp)*estb)*den stryx(np,mp)=-dsxb(np,mp)*den stryy(np,mp)= esxb(np,mp)*den stryd(np,mp)=(estb*dsxb(np,mp)-esxb(np,mp)*dstb)*den endif if(leftedge.eq.1) then C --- NW corner c --- compute dX/dXb c esxb(1,mp)=( xcr(2,mp )-(xcr(0,mp )-pi2rds))*dx0 esxb(1,mp)=(xcr(2,mp )-xcr(0,mp ))*dx0 c esyb(1,mp)=((xcr(1,mp+j3)-pirds)-xcr(1,mp-j3))*dy0 esyb(1,mp)=( xcr(1,mp+j3)-xcr(1,mp-j3))*dy0 estb=0. dsxb(1,mp)=(ycr(2,mp )-ycr(0,mp ))*dx0 dsyb(1,mp)=(pirds-ycr(1,mp+j3)-ycr(1,mp-j3))*dy0 . +float(1-j3) dstb=0. c --- use KD identities to invert derivatives -> dXb/dX den=1./(dsyb(1,mp)*esxb(1,mp)-dsxb(1,mp)*esyb(1,mp)) strxx(1,mp)= dsyb(1,mp)*den strxy(1,mp)=-esyb(1,mp)*den strxd(1,mp)=(dstb*esyb(1,mp)-dsyb(1,mp)*estb)*den stryx(1,mp)=-dsxb(1,mp)*den stryy(1,mp)= esxb(1,mp)*den stryd(1,mp)=(estb*dsxb(1,mp)-esxb(1,mp)*dstb)*den endif endif #endif #if (POLES == 0) icyclfrc=0 if(icyclfrc.eq.1) then if(ibcx.eq.1) then call updatelr(strxx,np,mp,1,np,mp,1) call updatelr(strxy,np,mp,1,np,mp,1) call updatelr(stryx,np,mp,1,np,mp,1) call updatelr(stryy,np,mp,1,np,mp,1) call updatelr(strxd,np,mp,1,np,mp,1) call updatelr(stryd,np,mp,1,np,mp,1) if (rightedge.eq.1) then do j=1,mp strxx(np,j)= strxx(np+1,j) strxy(np,j)= strxy(np+1,j) stryx(np,j)= stryx(np+1,j) stryy(np,j)= stryy(np+1,j) strxd(np,j)= strxd(np+1,j) stryd(np,j)= stryd(np+1,j) enddo endif endif if(ibcy.eq.1) then call updatebt(strxx,np,mp,1,np,mp,1) call updatebt(strxy,np,mp,1,np,mp,1) call updatebt(stryx,np,mp,1,np,mp,1) call updatebt(stryy,np,mp,1,np,mp,1) call updatebt(strxd,np,mp,1,np,mp,1) call updatebt(stryd,np,mp,1,np,mp,1) if (topedge.eq.1) then do i=1,np strxx(i,mp)= strxx(i,mp+1) strxy(i,mp)= strxy(i,mp+1) stryx(i,mp)= stryx(i,mp+1) stryy(i,mp)= stryy(i,mp+1) strxd(i,mp)= strxd(i,mp+1) stryd(i,mp)= stryd(i,mp+1) enddo endif endif endif #endif call update(strxx,np,mp,1,np,mp,iup) call update(strxy,np,mp,1,np,mp,iup) call update(stryx,np,mp,1,np,mp,iup) call update(stryy,np,mp,1,np,mp,iup) call update(strxd,np,mp,1,np,mp,iup) call update(stryd,np,mp,1,np,mp,iup) cccccccccccccccccccccccccccccccccccccccccccccccccccccccc c --- compute gradients of zs for g13, g23 coefficients c --- S. polar region c --- N. polar region c --- ip(i) points are just present inside ghost array area c in the appriopriate place: update(gi,np,mp,1,np,mp) c --- periodicity in x is never enforced cccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 + j3*botedge julim = mp - j3*topedge #endif c----------------------------------------------------------------- c --- Additional vertical metric coefficients: c --- Compute gradients of zs,zh for g13, g23 coefficients. c --- NOTE: Partially satisfy GCL here and use KD identities! c----------------------------------------------------------------- do i=illim,iulim c --- interior points do j=jllim,julim zsxb=dx0*(1./gi(i+1,j )-1./gi(i-1,j ))*gi(i,j) !zsxb/(H-zs) zsyb=dy0*(1./gi(i,j+j3)-1./gi(i,j-j3))*gi(i,j) !zsyb/(H-zs) zhxb=dx0*(zh(i+1, j)-zh(i-1, j))*gi(i,j) !zhxb/G zhyb=dy0*(zh(i,j+j3)-zh(i,j-j3))*gi(i,j) !zhyb/G s13(i,j)=strxx(i,j)*zsxb+stryx(i,j)*zsyb s23(i,j)=strxy(i,j)*zsxb+stryy(i,j)*zsyb h13(i,j)=strxx(i,j)*zhxb+stryx(i,j)*zhyb 21 h23(i,j)=strxy(i,j)*zhxb+stryy(i,j)*zhyb enddo enddo #if (POLES == 0) if (botedge.eq.1) then do i=illim,iulim c --- Southern boundary region zsxb= dx0*(1./gi(i+1,1 )-1./gi(i-1,1))*gi(i,1) zsyb=ibcy*dy0*(1./gi(i,1+j3)-1./gi(i,-j3))*gi(i,1) zhxb= dx0*(zh(i+1, 1)-zh(i-1, 1))*gi(i,1) zhyb=ibcy*dy0*(zh(i,1+j3)-zh(i,-j3))*gi(i,1) s13(i,1)=strxx(i,1)*zsxb+stryx(i,1)*zsyb s23(i,1)=strxy(i,1)*zsxb+stryy(i,1)*zsyb h13(i,1)=strxx(i,1)*zhxb+stryx(i,1)*zhyb h23(i,1)=strxy(i,1)*zhxb+stryy(i,1)*zhyb enddo endif if (topedge.eq.1) then do i=illim,iulim c --- Northern boundary region zsxb= dx0*(1./gi(i+1,mp )-1./gi(i-1,mp))*gi(i,mp) zsyb=ibcy*dy0*(1./gi(i,mp+1+j3)-1./gi(i,mp-j3))*gi(i,mp) zhxb= dx0*(zh(i+1, mp)-zh(i-1, mp))*gi(i,mp) zhyb=ibcy*dy0*(zh(i,mp+1+j3)-zh(i,mp-j3))*gi(i,mp) s13(i,mp)=strxx(i,mp)*zsxb+stryx(i,mp)*zsyb s23(i,mp)=strxy(i,mp)*zsxb+stryy(i,mp)*zsyb h13(i,mp)=strxx(i,mp)*zhxb+stryx(i,mp)*zhyb h23(i,mp)=strxy(i,mp)*zhxb+stryy(i,mp)*zhyb enddo endif #else if (botedge.eq.1) then do i=1,np c --- Southern boundary region zsxb= dx0*(1./gi(i+1,1 )-1./gi(i-1,1))*gi(i,1) zsyb=ibcy*dy0*(1./gi(i,1+j3)-1./gi(i,1-j3))*gi(i,1) zhxb= dx0*(zh(i+1, 1)-zh(i-1, 1))*gi(i,1) zhyb=ibcy*dy0*(zh(i,1+j3)-zh(i,1-j3))*gi(i,1) s13(i,1)=strxx(i,1)*zsxb+stryx(i,1)*zsyb s23(i,1)=strxy(i,1)*zsxb+stryy(i,1)*zsyb h13(i,1)=strxx(i,1)*zhxb+stryx(i,1)*zhyb h23(i,1)=strxy(i,1)*zhxb+stryy(i,1)*zhyb enddo endif if (topedge.eq.1) then do i=1,np c --- Northern boundary region zsxb= dx0*(1./gi(i+1,mp )-1./gi(i-1,mp))*gi(i,mp) zsyb=ibcy*dy0*(1./gi(i,mp+j3)-1./gi(i,mp-j3))*gi(i,mp) zhxb= dx0*(zh(i+1, mp)-zh(i-1, mp))*gi(i,mp) zhyb=ibcy*dy0*(zh(i,mp+j3)-zh(i,mp-j3))*gi(i,mp) s13(i,mp)=strxx(i,mp)*zsxb+stryx(i,mp)*zsyb s23(i,mp)=strxy(i,mp)*zsxb+stryy(i,mp)*zsyb h13(i,mp)=strxx(i,mp)*zhxb+stryx(i,mp)*zhyb h23(i,mp)=strxy(i,mp)*zhxb+stryy(i,mp)*zhyb enddo endif #endif #if (POLES == 0) if (leftedge.eq.1) then do j=jllim,julim c --- Western boundary region zsxb=ibcx*dx0*(1./gi(2,j )-1./gi(-1,j ))*gi(1,j) !zsxb/(H-zs) zsyb= dy0*(1./gi(1,j+j3)-1./gi( 1,j-j3))*gi(1,j) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(2,j)-zh(-1,j))*gi(1,j) !zhxb/G zhyb= dy0*(zh(1,j+j3)-zh(1,j-j3))*gi(1,j) !zhyb/G s13(1,j)=strxx(1,j)*zsxb+stryx(1,j)*zsyb s23(1,j)=strxy(1,j)*zsxb+stryy(1,j)*zsyb h13(1,j)=strxx(1,j)*zhxb+stryx(1,j)*zhyb h23(1,j)=strxy(1,j)*zhxb+stryy(1,j)*zhyb enddo endif if (rightedge.eq.1) then do j=jllim,julim c --- Estern boundary region zsxb=ibcx*dx0*(1./gi(np+2,j )-1./gi(np-1,j ))*gi(np,j) !zsxb/(H-zs) zsyb= dy0*(1./gi(np,j+j3)-1./gi(np,j-j3))*gi(np,j) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(np+2,j)-zh(np-1,j))*gi(np,j) !zhxb/G zhyb= dy0*(zh(np,j+j3)-zh(np,j-j3))*gi(np,j) !zhyb/G s13(np,j)=strxx(np,j)*zsxb+stryx(np,j)*zsyb s23(np,j)=strxy(np,j)*zsxb+stryy(np,j)*zsyb h13(np,j)=strxx(np,j)*zhxb+stryx(np,j)*zhyb h23(np,j)=strxy(np,j)*zhxb+stryy(np,j)*zhyb enddo endif if (rightedge.eq.1) then if (botedge.eq.1) then c --- ES corner zsxb=ibcx*dx0*(1./gi(np+2,1 )-1./gi(np-1,1))*gi(np,1) ! zsxb/(H-zs) zsyb=ibcy*dy0*(1./gi(np,1+j3)-1./gi(np,-j3))*gi(np,1) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(np+2,1)-zh(np-1,1))*gi(np,1) !zhxb/G zhyb=ibcy*dy0*(zh(np,1+j3)-zh(np,-j3))*gi(np,1) !zhyb/G s13(np,1)=strxx(np,1)*zsxb+stryx(np,1)*zsyb s23(np,1)=strxy(np,1)*zsxb+stryy(np,1)*zsyb h13(np,1)=strxx(np,1)*zhxb+stryx(np,1)*zhyb h23(np,1)=strxy(np,1)*zhxb+stryy(np,1)*zhyb endif if (topedge.eq.1) then c --- EN corner zsxb=ibcx*dx0*(1./gi(np+2,mp )-1./gi(np-1,mp ))*gi(np,mp) !zsxb/(H-zs) zsyb=ibcy*dy0*(1./gi(np,mp+1+j3)-1./gi(np,mp-j3))*gi(np,mp) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(np+2,mp)-zh(np-1,mp))*gi(np,mp) !zhxb/G zhyb=ibcy*dy0*(zh(np,mp+1+j3)-zh(np,mp-j3))*gi(np,mp) !zhyb/G s13(np,mp)=strxx(np,mp)*zsxb+stryx(np,mp)*zsyb s23(np,mp)=strxy(np,mp)*zsxb+stryy(np,mp)*zsyb h13(np,mp)=strxx(np,mp)*zhxb+stryx(np,mp)*zhyb h23(np,mp)=strxy(np,mp)*zhxb+stryy(np,mp)*zhyb endif endif if (leftedge.eq.1) then if (topedge.eq.1) then c --- WN corner zsxb=ibcx*dx0*(1./gi(2,mp )-1./gi(-1,mp ))*gi(1,mp) !zsxb/(H-zs) zsyb=ibcy*dy0*(1./gi(1,mp+1+j3)-1./gi( 1,mp-j3))*gi(1,mp) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(2,mp)-zh(-1,mp))*gi(1,mp) !zhxb/G zhyb=ibcy*dy0*(zh(1,mp+1+j3)-zh(1,mp-j3))*gi(1,mp) !zhyb/G s13(1,mp)=strxx(1,mp)*zsxb+stryx(1,mp)*zsyb s23(1,mp)=strxy(1,mp)*zsxb+stryy(1,mp)*zsyb h13(1,mp)=strxx(1,mp)*zhxb+stryx(1,mp)*zhyb h23(1,mp)=strxy(1,mp)*zhxb+stryy(1,mp)*zhyb endif if (botedge.eq.1) then c --- WS corner zsxb=ibcx*dx0*(1./gi(2,1 )-1./gi(-1, 1 ))*gi(1,1) !zsxb/(H-zs) zsyb=ibcy*dy0*(1./gi(1,1+j3)-1./gi( 1,-j3))*gi(1,1) !zsyb/(H-zs) zhxb=ibcx*dx0*(zh(2,1)-zh(-1,1))*gi(1,1) !zhxb/G zhyb=ibcy*dy0*(zh(1,1+j3)-zh(1,-j3))*gi(1,1) !zhyb/G s13(1,1)=strxx(1,1)*zsxb+stryx(1,1)*zsyb s23(1,1)=strxy(1,1)*zsxb+stryy(1,1)*zsyb h13(1,1)=strxx(1,1)*zhxb+stryx(1,1)*zhyb h23(1,1)=strxy(1,1)*zhxb+stryy(1,1)*zhyb endif endif #endif call update(s13,np,mp,1,np,mp,iup) call update(s23,np,mp,1,np,mp,iup) call update(h13,np,mp,1,np,mp,iup) call update(h23,np,mp,1,np,mp,iup) #if (TIMEPLT == 1) call ttend(7) #endif return end subroutine rhoswap(ind) include 'param.nml' include 'msg.inc' common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) if(ind.eq. 1) then do 1 k=1,l do 1 j=1,mp do 1 i=1,np rhstr(i,j,k)=rho(i,j,k) 1 rho(i,j,k)=rh0(i,j,k) call update(rho,np,mp,l,np,mp,iup) endif if(ind.eq.-1) then do 11 k=1,l do 11 j=1,mp do 11 i=1,np 11 rho(i,j,k)=rhstr(i,j,k) call update(rho,np,mp,l,np,mp,iup) endif return end ccccccccccccccccccccccccccccccccccccccccc subroutine vstrhat(ox,oy,oz,ind) ccccccccccccccccccccccccccccccccccccccccc c ind -1, from solenoidal to contravariant c ind +1, from contravariant to solenoidal include 'param.nml' include 'msg.inc' dimension ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (TIMEPLT == 1) call ttbeg(9) #endif corporate time dependent lower boundary into mass continuity equation: ind=+1 come back to original meaning of omega : ind=-1 zbi=1./zb do 1 k=1,l zsdcoe=ind*gmul(k)*zbi*gmus(k) zhdcoe=ind*(gmul(k)*zbi-1.)*gmus(k) do 1 j=1,mp do 1 i=1,np ox(i,j,k)=ox(i,j,k)-ind*strxd(i,j) oy(i,j,k)=oy(i,j,k)-ind*stryd(i,j) oz(i,j,k)=oz(i,j,k)+zsdcoe*zsd(i,j)*gi(i,j) . -zhdcoe*zhd(i,j)*gi(i,j) 1 continue c call update(ox,np,mp,l,np,mp,iup) c call update(oy,np,mp,l,np,mp,iup) c call update(oz,np,mp,l,np,mp,iup) #if (TIMEPLT == 1) call ttend(9) #endif return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c c SUBROUTINES TOPOGRAPHY / GRID GEOMETRY c c c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccc subroutine rhsdiv(u,v,w,d,r,iflg) ccccccccccccccccccccccccccccccccccccccccc include 'param.nml' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . d(1-ih:np+ih, 1-ih:mp+ih, l), . r(1-ih:np+ih, 1-ih:mp+ih, l) #if (TIMEPLT == 1) call ttbeg(12) #endif do 200 k=1,l do 200 j=1,mp do 200 i=1,np 200 r(i,j,k)=0. if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi call update(u,np,mp,l,np,mp,iupx) call update(d,np,mp,l,np,mp,iupx) #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge #else illim = 1 iulim = np #endif do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim 1 r(i,j,k)=dxil*(u(i+1,j,k)*d(i+1,j,k)-u(i-1,j,k)*d(i-1,j,k)) #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp r(1,j,k)=(1-ibcx)*dxi*(u( 2,j,k)*d( 2,j,k) . -u( 1,j,k)*d( 1,j,k)) 2 +ibcx*dxil*(u( 2,j,k)*d( 2,j,k) . -u(-1,j,k)*d(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp r(np,j,k)=(1-ibcx)*dxi*(u(np ,j,k)*d(np ,j,k) . -u(np-1,j,k)*d(np-1,j,k)) 2 +ibcx*dxil*(u(np+2,j,k)*d(np+2,j,k) . -u(np-1,j,k)*d(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then ! ANDII call updatebt(v,np,mp,l,np,mp,iupy) call updatebt(d,np,mp,l,np,mp,iupy) jllim = 1 + j3*botedge julim = mp - j3*topedge do 12 k=1,l do 12 j=jllim,julim do 12 i=1,np 12 r(i,j,k)=r(i,j,k) 2 +dyil*(v(i,j+j3,k)*d(i,j+j3,k)-v(i,j-j3,k)*d(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np r(i,1,k)=r(i,1,k) 1 +(1-ibcy)*dyi*(v(i,1+j3,k)*d(i,1+j3,k) . -v(i, 1 ,k)*d(i, 1 ,k)) 2 +ibcy*dyil*(v(i,1+j3,k)*d(i,1+j3,k) . -v(i,-1 ,k)*d(i,-1 ,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np r(i,mp,k)=r(i,mp,k) 1 +(1-ibcy)*dyi*(v(i,mp ,k)*d(i,mp ,k) . -v(i,mp-j3,k)*d(i,mp-j3,k)) 2 +ibcy*dyil*(v(i,mp+2 ,k)*d(i,mp+2 ,k) . -v(i,mp-j3,k)*d(i,mp-j3,k)) end do end do end if #else if (botedge.eq.1) then do k=1,l do i=1,np ! r(i,1,k)=r(i,1,k)+dyil*( d(i,1+j3,k)*v(i,1+j3,k) ! . +d(i,1-j3,k)*v(i,1-j3,k)) r(i,1,k)=r(i,1,k)+dyil*( d(i,1+j3,k)*v(i,1+j3,k) . +d(i,1 ,k)*v(i,1 ,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np ! r(i,mp,k)=r(i,mp,k)-dyil*( d(i,mp+j3,k)*v(i,mp+j3,k) ! . +d(i,mp-j3,k)*v(i,mp-j3,k)) r(i,mp,k)=r(i,mp,k)-dyil*( d(i,mp ,k)*v(i,mp ,k) . +d(i,mp-j3,k)*v(i,mp-j3,k)) end do end do end if #endif endif ! ANDII do 3 k=2,l-1 do 3 j=1,mp do 3 i=1,np 3 r(i,j,k)=r(i,j,k) 3 +dzil*(w(i,j,k+1)*d(i,j,k+1)-w(i,j,k-1)*d(i,j,k-1)) if(ibcz.eq.0) then do 13 j=1,mp do 13 i=1,np r(i,j,1)=r(i,j,1)+dzi*(w(i,j,2)*d(i,j,2)-w(i,j,1 )*d(i,j,1 )) 13 r(i,j,l)=r(i,j,l)+dzi*(w(i,j,l)*d(i,j,l)-w(i,j,l-1)*d(i,j,l-1)) else do 113 j=1,mp do 113 i=1,np r(i,j,1)=r(i,j,1)+dzil*(w(i,j,2)*d(i,j,2)-w(i,j,l-1)*d(i,j,l-1)) r(i,j,l)=r(i,j,l)+dzil*(w(i,j,2)*d(i,j,2)-w(i,j,l-1)*d(i,j,l-1)) 113 continue endif if(iflg.ne.0) then do 4 k=1,l do 4 j=1,mp do 4 i=1,np 4 r(i,j,k)=iflg*r(i,j,k)/d(i,j,k) endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call update(u,np,mp,l,np,mp,1) call update(v,np,mp,l,np,mp,1) call update(w,np,mp,l,np,mp,1) dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi #if (POLES == 0) illim = 1 + leftedge #else illim = 1 #endif if(iflg.eq.0) then if(j3.eq.1) then #if (POLES == 0) jllim = 1 + j3*botedge #else jllim = 1 #endif do 5 k=2,l do 5 j=jllim,mp do 5 i=illim,np r(i,j,k)=dxil* 1 ( u(i,j ,k )*d(i,j ,k )-u(i-1,j ,k )*d(i-1,j ,k ) 1 +u(i,j-j3,k )*d(i,j-j3,k )-u(i-1,j-j3,k )*d(i-1,j-j3,k ) 1 +u(i,j ,k-1)*d(i,j ,k-1)-u(i-1,j ,k-1)*d(i-1,j ,k-1) 1 +u(i,j-j3,k-1)*d(i,j-j3,k-1)-u(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) 2 +dyil* 2 ( v(i ,j ,k )*d(i ,j ,k )-v(i ,j-j3,k )*d(i ,j-j3,k ) 2 +v(i-1,j ,k )*d(i-1,j ,k )-v(i-1,j-j3,k )*d(i-1,j-j3,k ) 2 +v(i ,j ,k-1)*d(i ,j ,k-1)-v(i ,j-j3,k-1)*d(i ,j-j3,k-1) 2 +v(i-1,j ,k-1)*d(i-1,j ,k-1)-v(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) 3 +dzil* 3 ( w(i ,j ,k)*d(i ,j ,k)-w(i ,j ,k-1)*d(i ,j ,k-1) 3 +w(i-1,j ,k)*d(i-1,j ,k)-w(i-1,j ,k-1)*d(i-1,j ,k-1) 3 +w(i ,j-j3,k)*d(i ,j-j3,k)-w(i ,j-j3,k-1)*d(i ,j-j3,k-1) 3 +w(i-1,j-j3,k)*d(i-1,j-j3,k)-w(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) 5 continue else dxi2=2.*dxil dzi2=2.*dzil do 51 k=2,l do 51 i=illim,np r(i,1,k)=dxi2* 1 dxi2*( u(i,1 ,k )*d(i ,1,k )-u(i-1,1,k )*d(i-1,1,k ) 1 +u(i,1 ,k-1)*d(i ,1,k-1)-u(i-1,1,k-1)*d(i-1,1,k-1)) 3 +dzi2*( w(i ,1,k )*d(i ,1,k )-w(i ,1,k-1)*d(i ,1,k-1) 3 +w(i-1,1,k )*d(i-1,1,k )-w(i-1,1,k-1)*d(i-1,1,k-1)) 51 continue endif else if(j3.eq.1) then #if (POLES == 0) jllim = 1 + j3*botedge #else jllim = 1 #endif do 6 k=2,l do 6 j=jllim,mp do 6 i=illim,np r(i,j,k)=dxil* 1 ( u(i,j ,k )*d(i,j ,k )-u(i-1,j ,k )*d(i-1,j ,k ) 1 +u(i,j-j3,k )*d(i,j-j3,k )-u(i-1,j-j3,k )*d(i-1,j-j3,k ) 1 +u(i,j ,k-1)*d(i,j ,k-1)-u(i-1,j ,k-1)*d(i-1,j ,k-1) 1 +u(i,j-j3,k-1)*d(i,j-j3,k-1)-u(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) 2 +dyil* 2 ( v(i ,j ,k )*d(i ,j ,k )-v(i ,j-j3,k )*d(i ,j-j3,k ) 2 +v(i-1,j ,k )*d(i-1,j ,k )-v(i-1,j-j3,k )*d(i-1,j-j3,k ) 2 +v(i ,j ,k-1)*d(i ,j ,k-1)-v(i ,j-j3,k-1)*d(i ,j-j3,k-1) 2 +v(i-1,j ,k-1)*d(i-1,j ,k-1)-v(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) 3 +dzil* 3 ( w(i ,j ,k)*d(i ,j ,k)-w(i ,j ,k-1)*d(i ,j ,k-1) 3 +w(i-1,j ,k)*d(i-1,j ,k)-w(i-1,j ,k-1)*d(i-1,j ,k-1) 3 +w(i ,j-j3,k)*d(i ,j-j3,k)-w(i ,j-j3,k-1)*d(i ,j-j3,k-1) 3 +w(i-1,j-j3,k)*d(i-1,j-j3,k)-w(i-1,j-j3,k-1)*d(i-1,j-j3,k-1) ) rhoav=.125*( d(i ,j ,k )+d(i-1,j ,k ) 1 +d(i-1,j-j3,k )+d(i ,j-j3,k ) 1 +d(i ,j ,k-1)+d(i-1,j ,k-1) 1 +d(i-1,j-j3,k-1)+d(i ,j-j3,k-1) ) 6 r(i,j,k)=iflg*r(i,j,k)/rhoav else dxi2=2.*dxil dzi2=2.*dzil do 61 k=2,l do 61 i=illim,np r(i,1,k)= 1 dxi2*( u(i ,1,k )*d(i ,1,k )-u(i-1,1,k )*d(i-1,1,k ) 1 +u(i ,1,k-1)*d(i ,1,k-1)-u(i-1,1,k-1)*d(i-1,1,k-1)) 3 +dzi2*( w(i ,1,k )*d(i ,1,k )-w(i ,1,k-1)*d(i ,1,k-1) 3 +w(i-1,1,k )*d(i-1,1,k )-w(i-1,1,k-1)*d(i-1,1,k-1)) rhoav=.25*(d(i,1,k)+d(i-1,1,k)+d(i,1,k-1)+d(i-1,1,k-1)) 61 r(i,1,k)=iflg*r(i,1,k)/rhoav endif endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif call update(r,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(12) #endif return end #if (ANALIZE == 0) #if (MHD == 1) subroutine rBB(bx,by,bz,ox,oy,oz,rho,fx,fy,fz,xmiui) include 'param.nml' include 'msg.inc' dimension bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fy(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/sltB/ x0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 y0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 z0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 c do k=1,l c do j=1,mp c do i=1,np c bx(i,j,k)=bx(i,j,k)*sqrt(xmiui/rho(i,j,k)) c by(i,j,k)=by(i,j,k)*sqrt(xmiui/rho(i,j,k)) c bz(i,j,k)=bz(i,j,k)*sqrt(xmiui/rho(i,j,k)) c enddo c enddo c enddo do j=1,mp !mod bbc do i=1,np !Bench if (ibbl .eq. 1) then bx(i,j,1) = 0. by(i,j,1) = 0. bz(i,j,1) = bze(i,j,1) bz(i,j,2) = bze(i,j,2) endif if (ibbu .eq. 1) then bx(i,j,l) = 0. by(i,j,l) = 0. bz(i,j,l-1) = bze(i,j,l-1) bz(i,j,l) = bze(i,j,l) endif end do end do call bvprd(bx,by,bz,ox,oy,oz) call donorc(x0,y0,z0,bx,rh0,31,fx) call donorc(x0,y0,z0,by,rh0,32,fy) call donorc(x0,y0,z0,bz,rh0,33,fz) c call mpdatm3B(x0,y0,z0,bx,rh0,31,fx) c call mpdatm3B(x0,y0,z0,by,rh0,32,fy) c call mpdatm3B(x0,y0,z0,bz,rh0,33,fz) do k=1,l do j=1,mp do i=1,np fx(i,j,k)=xmiui*fx(i,j,k)*rh0(i,j,k)/rho(i,j,k) fy(i,j,k)=xmiui*fy(i,j,k)*rh0(i,j,k)/rho(i,j,k) fz(i,j,k)=xmiui*fz(i,j,k)*rh0(i,j,k)/rho(i,j,k) c fx(i,j,k)=fx(i,j,k)/dt c fy(i,j,k)=fy(i,j,k)/dt c fz(i,j,k)=fz(i,j,k)/dt c bx(i,j,k)=bx(i,j,k)*sqrt(rho(i,j,k)/xmiui) c by(i,j,k)=by(i,j,k)*sqrt(rho(i,j,k)/xmiui) c bz(i,j,k)=bz(i,j,k)*sqrt(rho(i,j,k)/xmiui) enddo enddo enddo return end subroutine rBVeO(bx,by,bz,ux,uy,uz,fx,fy,fz) include 'param.nml' include 'msg.inc' dimension bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . ux(1-ih:np+ih, 1-ih:mp+ih, l), . uy(1-ih:np+ih, 1-ih:mp+ih, l), . uz(1-ih:np+ih, 1-ih:mp+ih, l), . fx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fy(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) common/mhdscr/ phix(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiy(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . div(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) call grad(ux,phix,phiy,phiz,1) c call grad(ux,phix,phiy,phiz,0) do k=1,l do j=1,mp do i=1,np fx(i,j,k)= bx(i,j,k)*phix(i,j,k) + +by(i,j,k)*phiy(i,j,k) + +bz(i,j,k)*phiz(i,j,k) div(i,j,k)=phix(i,j,k) enddo enddo enddo call grad(uy,phix,phiy,phiz,1) do k=1,l do j=1,mp do i=1,np fy(i,j,k)= bx(i,j,k)*phix(i,j,k) + +by(i,j,k)*phiy(i,j,k) + +bz(i,j,k)*phiz(i,j,k) div(i,j,k)=div(i,j,k)+phiy(i,j,k) enddo enddo enddo call grad(uz,phix,phiy,phiz,0) do k=1,l do j=1,mp do i=1,np fz(i,j,k)= bx(i,j,k)*phix(i,j,k) + +by(i,j,k)*phiy(i,j,k) + +bz(i,j,k)*phiz(i,j,k) div(i,j,k)=div(i,j,k)+phiz(i,j,k) enddo enddo enddo c call filstr(fx) c call filstr(fy) c call filstr(fz) compute divergence of the wind vector: div(V)=-1/rho*w*drho/dzbar idiv=0 if(idiv.eq.1) then dzil=0.5*dzi do k=2,l-1 do j=1,mp do i=1,np div(i,j,k)=-dzil*(rho(i,j,k+1)-rho(i,j,k-1))*gi(i,j) . *(uz(i,j,k+1)+2.*uz(i,j,k)+uz(i,j,k-1)) . /(rho(i,j,k+1)+2.*rho(i,j,k)+rho(i,j,k-1)) end do end do end do do j=1,mp do i=1,np if(ibcz.eq.1) then div(i,j,1)=-dzil*(rho(i,j,2)-rho(i,j,L-1))*gi(i,j) . *(uz(i,j,2)+2.*uz(i,j,1)+uz(i,j,L-1)) . /(rho(i,j,2)+2.*rho(i,j,1)+rho(i,j,L-1)) div(i,j,L)=div(i,j,1) else div(i,j,1)=-dzi*(rho(i,j,2)-rho(i,j,1))*gi(i,j) . *uz(i,j,1)/rho(i,j,1) div(i,j,L)=-dzi*(rho(i,j,L)-rho(i,j,L-1))*gi(i,j) . *uz(i,j,L)/rho(i,j,L) endif end do end do endif do k=1,l do j=1,mp do i=1,np fx(i,j,k)= fx(i,j,k)-bx(i,j,k)*div(i,j,k) fy(i,j,k)= fy(i,j,k)-by(i,j,k)*div(i,j,k) fz(i,j,k)= fz(i,j,k)-bz(i,j,k)*div(i,j,k) enddo enddo enddo return end subroutine rBVeN(bx,by,bz,ox,oy,oz,u,v,w,fx,fy,fz,iflg) include 'param.nml' include 'msg.inc' dimension bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . u(1-ih:np+ih, 1-ih:mp+ih,l), . v(1-ih:np+ih, 1-ih:mp+ih,l), . w(1-ih:np+ih, 1-ih:mp+ih,l), . fx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fy(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/sltB/ x0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 y0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 z0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) c common/mhdscr/ div(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/mhdscr/ phix(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiy(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . div(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) do j=1,mp !mod bbc do i=1,np !Bench if (ibbl .eq. 1) then bx(i,j,1) = 0. by(i,j,1) = 0. bz(i,j,1) = bze(i,j,1) bz(i,j,2) = bze(i,j,2) endif if (ibbu .eq. 1) then bx(i,j,l) = 0. by(i,j,l) = 0. bz(i,j,l-1) = bze(i,j,l-1) bz(i,j,l) = bze(i,j,l) endif end do end do if(iflg.eq.1) & call bvprd(bx,by,bz,ox,oy,oz) call donorc(x0,y0,z0,u,rh0,2,fx) call donorc(x0,y0,z0,v,rh0,3,fy) call donorc(x0,y0,z0,w,rh0,4,fz) compute divergence of the wind vector: div(V)=-1/rho*w*drho/dzbar dzil=0.5*dzi do k=2,l-1 do j=1,mp do i=1,np div(i,j,k)=-dzil*(rho(i,j,k+1)-rho(i,j,k-1))*gi(i,j) . *(w(i,j,k+1)+2.*w(i,j,k)+w(i,j,k-1)) . /(rho(i,j,k+1)+2.*rho(i,j,k)+rho(i,j,k-1)) end do end do end do do j=1,mp do i=1,np if(ibcz.eq.1) then div(i,j,1)=-dzil*(rho(i,j,2)-rho(i,j,L-1))*gi(i,j) . *(w(i,j,2)+2.*w(i,j,1)+w(i,j,L-1)) . /(rho(i,j,2)+2.*rho(i,j,1)+rho(i,j,L-1)) div(i,j,L)=div(i,j,1) else div(i,j,1)=-dzi*(rho(i,j,2)-rho(i,j,1))*gi(i,j) . *w(i,j,1)/rho(i,j,1) div(i,j,L)=-dzi*(rho(i,j,L)-rho(i,j,L-1))*gi(i,j) . *w(i,j,L)/rho(i,j,L) endif end do end do do k=1,l do j=1,mp do i=1,np fx(i,j,k)= fx(i,j,k)-bx(i,j,k)*div(i,j,k) fy(i,j,k)= fy(i,j,k)-by(i,j,k)*div(i,j,k) fz(i,j,k)= fz(i,j,k)-bz(i,j,k)*div(i,j,k) enddo enddo enddo return end subroutine rBVi(bx,by,bz,ux,uy,uz) include 'param.nml' include 'msg.inc' dimension bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . ux(1-ih:np+ih, 1-ih:mp+ih, l), . uy(1-ih:np+ih, 1-ih:mp+ih, l), . uz(1-ih:np+ih, 1-ih:mp+ih, l) c common/mhdscr/ div(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/mhdscr/ phix(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiy(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . phiz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . div(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,3), ! free . c11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c11 . c12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c12 . c13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c13 . c21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c21 . c22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c22 . c23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c23 . c31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c31 . c32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c32 . c33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c33 . temp(1-ih:np+ih,1-ih:mp+ih,l, 4) ! not used det3(r11,r12,r13,r21,r22,r23,r31,r32,r33)= . r11*r22*r33+r12*r23*r31+r13*r21*r32 . -r31*r22*r13-r32*r23*r11-r33*r21*r12 idiv=0 do j=1,mp !mod bbc do i=1,np !Bench if (ibbl .eq. 1) then bx(i,j,1) = 0. by(i,j,1) = 0. bz(i,j,1) = bze(i,j,1) bz(i,j,2) = bze(i,j,2) endif if (ibbu .eq. 1) then bx(i,j,l) = 0. by(i,j,l) = 0. bz(i,j,l-1) = bze(i,j,l-1) bz(i,j,l) = bze(i,j,l) endif end do end do call grad(ux,c11,c12,c13,1) c call grad(ux,c11,c12,c13,0) call grad(uy,c21,c22,c23,1) call grad(uz,c31,c32,c33,0) if(idiv.eq.0) then do k=1,l do j=1,mp do i=1,np div(i,j,k)=c11(i,j,k)+c22(i,j,k)+c33(i,j,k) enddo enddo enddo else compute divergence of the wind vector: div(V)=-1/rho*w*drho/dzbar dzil=0.5*dzi do k=2,l-1 do j=1,mp do i=1,np div(i,j,k)=-dzil*(rho(i,j,k+1)-rho(i,j,k-1))*gi(i,j) . *(uz(i,j,k+1)+2.*uz(i,j,k)+uz(i,j,k-1)) . /(rho(i,j,k+1)+2.*rho(i,j,k)+rho(i,j,k-1)) end do end do end do do j=1,mp do i=1,np if(ibcz.eq.1) then div(i,j,1)=-dzil*(rho(i,j,2)-rho(i,j,L-1))*gi(i,j) . *(uz(i,j,2)+2.*uz(i,j,1)+uz(i,j,L-1)) . /(rho(i,j,2)+2.*rho(i,j,1)+rho(i,j,L-1)) div(i,j,L)=div(i,j,1) else div(i,j,1)=-dzi*(rho(i,j,2)-rho(i,j,1))*gi(i,j) . *uz(i,j,1)/rho(i,j,1) div(i,j,L)=-dzi*(rho(i,j,L)-rho(i,j,L-1))*gi(i,j) . *uz(i,j,L)/rho(i,j,L) endif end do end do endif dthng=-dt*0.5 eps=1.e-10 do k=1,l do j=1,mp do i=1,np a11 = 1.+dthng*(c11(i,j,k)-div(i,j,k)) a12 = dthng* c12(i,j,k) a13 = dthng* c13(i,j,k) a21 = dthng* c21(i,j,k) a22 = 1.+dthng*(c22(i,j,k)-div(i,j,k)) a23 = dthng* c23(i,j,k) a31 = dthng* c31(i,j,k) c a31 = dthng* c21(i,j,k) a32 = dthng* c32(i,j,k) a33 = 1.+dthng*(c33(i,j,k)-div(i,j,k)) b1=bx(i,j,k) b2=by(i,j,k) b3=bz(i,j,k) det =det3(a11,a12,a13,a21,a22,a23,a31,a32,a33) deti=sign(1.,det)/amax1(abs(det),eps) detx=det3( b1,a12,a13, b2,a22,a23, b3,a32,a33) dety=det3(a11, b1,a13,a21, b2,a23,a31, b3,a33) detz=det3(a11,a12, b1,a21,a22, b2,a31,a32, b3) bx(i,j,k)=detx*deti by(i,j,k)=dety*deti bz(i,j,k)=detz*deti enddo enddo enddo do j=1,mp !mod bbc do i=1,np !Bench if (ibbl .eq. 1) then bx(i,j,1) = 0. by(i,j,1) = 0. bz(i,j,1) = bze(i,j,1) bz(i,j,2) = bze(i,j,2) endif if (ibbu .eq. 1) then bx(i,j,l) = 0. by(i,j,l) = 0. bz(i,j,l-1) = bze(i,j,l-1) bz(i,j,l) = bze(i,j,l) endif end do end do return end subroutine grad(p,pfx,pfy,pfz,iflip) include 'param.nml' include 'msg.inc' dimension p(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . pfx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . pfy(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . pfz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) common/blank/ scr12(1-ih:np+ih,1-ih:mp+ih,l,12), ! gcrk, coef0 . scr13(1-ih:np+ih,1-ih:mp+ih,l), ! free array . px(1-ih:np+ih,1-ih:mp+ih,l), ! local array . py(1-ih:np+ih,1-ih:mp+ih,l), ! local array . pz(1-ih:np+ih,1-ih:mp+ih,l) ! local array dimension pe(1-ih:nmhdp+ih+1, 1-ih:mmhdp+ih+1, lmhd+1) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/rigidB/ bbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,2), . bbx(1-ih:mmhdp+ih, lmhd , 2), . bby(1-ih:nmhdp+ih, lmhd , 2) coefficients e1,e2,e3 define extrapolation scheme in pressure boundary conditions for tangential contributions to pressure forces for B-grid calculations common/indx/ e1,e2,e3 call update(p,np,mp,l,np,mp,iup) if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi compute pressure derivatives everywhere #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np if (iflip.eq.1) then jllim = 1 + j3*botedge julim = mp - j3*topedge else jllim = 1 julim = mp endif #endif do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim 1 px(i,j,k)=dxil*(p(i+1,j,k)-p(i-1,j,k)) #if (POLES == 0) if (leftedge.eq.1) then do 18 k=1,l do 18 j=1,mp px(1,j,k)=(1-ibcx)*dxi*(p(2,j,k)-p( 1,j,k)) 1 +ibcx*dxil*(p(2,j,k)-p(-1,j,k)) 18 continue end if if (rightedge.eq.1) then do k=1,l do j=1,mp px(np,j,k)=(1-ibcx)*dxi*(p(np ,j,k)-p(np-1,j,k)) 1 +ibcx*dxil*(p(np+2,j,k)-p(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then do 2 k=1,l do 2 j=jllim,julim do 2 i=1,np 2 py(i,j,k)= dyil*(p(i,j+j3,k)-p(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do 28 k=1,l do 28 i=1,np py(i,1,k)=(1-ibcy)*dyi*(p(i,1+j3,k)-p(i, 1,k)) 1 +ibcy*dyil*(p(i,1+j3,k)-p(i,-1,k)) 28 continue end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=(1-ibcy)*dyi*(p(i,mp ,k)-p(i,mp-j3,k)) 1 +ibcy*dyil*(p(i,mp+2,k)-p(i,mp-j3,k)) end do end do end if #else c modif POLES if (iflip.eq.1) then if (botedge.eq.1) then do k=1,l do i=1,np py(i,1,k)=dyil*(p(i,1+j3,k)+p(i,1,k)) c py(i,1,k)=dyil*(p(i,1+j3,k)+p(i,0,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=-dyil*(p(i,mp,k)+p(i,mp-j3,k)) c py(i,mp,k)=-dyil*(p(i,mp+1,k)+p(i,mp-j3,k)) end do end do end if end if #endif else do 29 k=1,l do 29 j=1,mp do 29 i=1,np 29 py(i,j,k)=0. endif do 3 k=2,l-1 do 3 j=1,mp do 3 i=1,np 3 pz(i,j,k)=dzil*(p(i,j,k+1)-p(i,j,k-1)) if(ibcz.eq.0) then do 38 j=1,mp do 38 i=1,np pz(i,j,1)= dzi*(p(i,j,2)-p(i,j,1)) 38 pz(i,j,l)= dzi*(p(i,j,l)-p(i,j,l-1)) else do 381 j=1,mp do 381 i=1,np pz(i,j,1)= dzil*(p(i,j,2)-p(i,j,l-1)) 381 pz(i,j,l)= dzil*(p(i,j,2)-p(i,j,l-1)) endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi illim = 1 + leftedge jllim = 1 + j3*botedge iulim = np + 1*rightedge julim = mp + j3*topedge construct extended, auxiliary pressure field with either cyclic or extrapolated boundaries do 4 k=2,l do 4 j=jllim,mp do 4 i=illim,np 4 pe(i,j,k)=p(i,j,k) do 41 j=jllim,mp do 41 i=illim,np plex=2.*(e1*pe(i,j,2)+e2*pe(i,j,3 )+e3*pe(i,j,4 ))-pe(i,j,2) prex=2.*(e1*pe(i,j,l)+e2*pe(i,j,l-1)+e3*pe(i,j,l-2))-pe(i,j,l) pe(i,j,1) =(1-ibcz)*plex+ibcz*pe(i,j,l) 41 pe(i,j,l+1)=(1-ibcz)*prex+ibcz*pe(i,j,2) #if(PARALLEL == 0) do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3 ,j,k)+e3*pe(4 ,j,k))-pe(2,j,k) prex=2.*(e1*pe(n,j,k)+e2*pe(n-1,j,k)+e3*pe(n-2,j,k))-pe(n,j,k) pe(1 ,j,k)=(1-ibcx)*plex+ibcx*pe(n,j,k) pe(n+1,j,k)=(1-ibcx)*prex+ibcx*pe(2,j,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(pe,np ,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(pe,np+1,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(pe,np ,mp+1,l+1,np+1,mp+1,iupx) else call updatelr(pe,np+1,mp+1,l+1,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3,j,k)+e3*pe(4,j,k))-pe(2,j,k) pe(1,j,k) =(1-ibcx)*plex+ibcx*pe(-1,j,k) enddo enddo endif if (rightedge.eq.1) then do k=1,l+1 do j=jllim,mp prex=2.*(e1*pe(np,j,k)+e2*pe(np-1,j,k)+e3*pe(np-2,j,k))-pe(np,j,k) pe(np+1,j,k)=(1-ibcx)*prex+ibcx*pe(np+3,j,k) enddo enddo endif #endif if(j3.eq.1) then #if(PARALLEL == 0) do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) prex=2.*(e1*pe(i,m ,k)+e2*pe(i,m-j3 ,k) . +e3*pe(i,m-2*j3,k)) -pe(i,m ,k) pe(i,1,k) =(1-ibcy)*plex+ibcy*pe(i,m ,k) pe(i,m+1,k)=(1-ibcy)*prex+ibcy*pe(i,1+j3,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatebt(pe,np ,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(pe,np+1,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(pe,np ,mp+1,l+1,np+1,mp+1,iupy) else call updatebt(pe,np+1,mp+1,l+1,np+1,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) pe(i,1,k)=(1-ibcy)*plex+ibcy*pe(i,-1,k) enddo enddo end if if (topedge.eq.1) then do k=1,l+1 do i=1,iulim prex=2.*(e1*pe(i,mp ,k)+e2*pe(i,mp-j3 ,k) . +e3*pe(i,mp-2*j3,k)) -pe(i,mp ,k) pe(i,mp+1,k)=(1-ibcy)*prex+ibcy*pe(i,mp+3,k) enddo enddo endif #endif endif #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call update(pe,np ,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(pe,np+1,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(pe,np ,mp+1,l+1,np+1,mp+1,iup) else call update(pe,np+1,mp+1,l+1,np+1,mp+1,iup) end if #endif compute pressure derivatives everywhere if(j3.eq.1) then do 5 k=1,l do 5 j=1,mp do 5 i=1,np px(i,j,k)=dxil* . ( pe(i+1,j+j3,k+1)-pe(i,j+j3,k+1)+pe(i+1,j,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i,j+j3,k )+pe(i+1,j,k )-pe(i,j,k ) ) py(i,j,k)=dyil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j,k+1)+pe(i,j+j3,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i+1,j,k )+pe(i,j+j3,k )-pe(i,j,k ) ) pz(i,j,k)=dzil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j+j3,k)+pe(i,j+j3,k+1)-pe(i,j+j3,k) . +pe(i+1,j ,k+1)-pe(i+1,j ,k)+pe(i,j ,k+1)-pe(i,j ,k) ) 5 continue else dxi2=2.*dxil dzi2=2.*dzil do 51 k=1,l do 51 i=1,np px(i,1,k)=dxi2*(pe(i+1,1,k+1)-pe(i,1,k+1)+pe(i+1,1,k)-pe(i,1,k)) 51 pz(i,1,k)=dzi2*(pe(i+1,1,k+1)-pe(i+1,1,k)+pe(i,1,k+1)-pe(i,1,k)) do 52 k=1,l do 52 j=1,mp do 52 i=1,np 52 py(i,j,k)=0. endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif compute interior pressure forces do 10 k=1,l do 10 j=1,mp do 10 i=1,np g110=1./(gmm(i,j,k)*cosa(i,j)) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) pfx(i,j,k)=g11*px(i,j,k)+g12*py(i,j,k)+g13*pz(i,j,k) pfy(i,j,k)=g21*px(i,j,k)+g22*py(i,j,k)+g23*pz(i,j,k) 10 pfz(i,j,k)=g33*pz(i,j,k) return end subroutine donorc(u1,u2,u3,x,h,iflg,flxdv) include 'param.nml' include 'msg.inc' dimension u1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . u2(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . u3(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . x(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . h(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . flxdv(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+1+2*ih)*l) parameter(iv3f3=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ibcxa=(mp+2*ih)*l,ibcya=(np+2*ih)*l) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+iv3f3+ibcxa+ibcya)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+1+ih, l), . v3(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+1+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(1-ih:mp+ih, l, 2), . bcy(1-ih:np+ih, l, 2), . scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc c c pp(y)= amax1(0.,y) c pn(y)=-amin1(0.,y) c donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 donor(y1,y2,a)=a*(y1+y2)*0.5 c call update(x,np,mp,l,np,mp,iup) iboz=1-ibcz #if (POLES == 0) /* !modpol */ ibox=1-ibcx iboy=1-ibcy ibcxy=ibcx*ibcy #else ibox=0 iboy=0 ibcxy=1 #endif do k=2,n3m do j=1,mp do i=1,np v3(i,j,k) = u3(i,j,k) enddo end do end do do j=1,mp do i=1,np v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif c illim = 1 + leftedge do k=1,n3m do j=1,mp do i=illim,iulim c do i=illim,np !modpol v1(i,j,k) = u1(i,j,k) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1( 1,j,k) = ubc(j,k,1) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k) = ubc(j,k,2) end do end do end if C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + 1*botedge julim = mp do k=1,n3m do j=jllim,julim !modpol c do j=jllim,mp do i=1,np v2(i,j,k) = u2(i,j,k) end do end do end do if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k) = vbc(i,k,1) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k) = vbc(i,k,2) end do end do end if c if((itr.eq.1).and.(ibcxy.eq.0)) !mod check if(ibcxy.eq.0) . call mp3bc_mhd(x,iflg,bcx,bcy,np,mp,n3m) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif c ilft=1+leftedge*1 do k=1,n3m do j=1,mp do i=illim,iulim !modpol c do i=ilft,np f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=f1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=f1(np+3,j,k) end do end do end if else if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)= . donor(bcx(j,k,1),x(1,j,k),v1(1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)= . donor(x(np,j,k),bcx(j,k,2),v1(np+1,j,k)) end do end do end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if endif C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + botedge julim = mp !modpol c jbot=1+botedge*1 do k=1,n3m do j=jllim,julim c do j=jbot,mp do i=1,np f2(i,j,k)=donor(x(i,j-1,k),x(i,j,k),v2(i,j,k)) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=f2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k) end do end do end if else if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=donor(bcy(i,k,1),x(i,1,k),v2(i,1,k)) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)= . donor(x(i,mp,k),bcy(i,k,2),v2(i,mp+1,k)) end do end do end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if endif C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np f2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np f2(i,mp+1,k)= 0. enddo enddo endif if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 333 k=2,n3m do 333 j=1,mp do 333 i=1,np 333 f3(i,j,k)=donor(x(i,j,k-1),x(i,j,k),v3(i,j,k)) do j=1,mp do i=1,np c if (iflg.ge.31.and.iflg.le.33) then c f3(i,j, 1)= f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz c else f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz c endif c if (iflg.eq.2.or.iflg.eq.3.or.(iflg.ge.31.and.iflg.le.33)) then c f3(i,j,n3)= f3(i,j,n3m)*iboz+f3(i,j, 2 )*ibcz !mod bbc c else f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2 )*ibcz c endif enddo enddo do k=1,n3m do j=1,mp do i=1,np flxdv(i,j,k)= ( f1(i+1,j,k)-f1(i,j,k) . +f2(i,j+1,k)-f2(i,j,k) . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k)*dti end do end do end do c call update(flxdv,np,mp,l,np,mp,iup) return end subroutine mp3bc_mhd(x,iflg,bcx,bcy,n1,n2,n3) include 'param.nml' include 'msg.inc' common/profB/ prfb(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd,3) dimension x(1-ih:np+ih,1-ih:mp+ih,l), . bcx(1-ih:mp+ih,n3,2), . bcy(1-ih:np+ih,n3,2) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . prf(1-ih:np+ih,1-ih:mp+ih,l,3), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/znave/ uza(mp,l,3),thza(mp,l),qvza(mmsp,lms), . bza(mmhdp,lmhd,3) #if (TIMEPLT == 1) call ttbeg(36) #endif #if (POLES == 0) /* !modpol */ if(iflg.eq.1) then ! ---> th if(implgw.eq.1) then if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. C +thza(1,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. C +thza(mp,k) enddo enddo end if else if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,1) bcx(j,k,2)=prf( 0,j,k,1) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,1) bcx(j,k,2)=prf(np,j,k,1) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,1) bcy(i,k,2)=prf(i, 0,k,1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,1) bcy(i,k,2)=prf(i,mp,k,1) enddo enddo end if endif goto 999 endif if(mhd.eq.1) then if(iflg.ge.31.and.iflg.le.33) then if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prfb( 1,j,k,iflg-30) bcx(j,k,2)=prfb( 0,j,k,iflg-30) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prfb(np+1,j,k,iflg-30) bcx(j,k,2)=prfb(np,j,k,iflg-30) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prfb(i, 1,k,iflg-30) bcy(i,k,2)=prfb(i, 0,k,iflg-30) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prfb(i,mp+1,k,iflg-30) bcy(i,k,2)=prfb(i,mp,k,iflg-30) enddo enddo end if return endif endif #if (MOISTMOD > 0) if(iflg.eq.11) then ! ---> thf if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,1) bcx(j,k,2)=prf( 0,j,k,1) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,1) bcx(j,k,2)=prf(np,j,k,1) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,1) bcy(i,k,2)=prf(i, 0,k,1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,1) bcy(i,k,2)=prf(i,mp,k,1) enddo enddo end if goto 999 endif #endif if(iflg.eq.2.or.iflg.eq.3) then ! ---> u0.v0 if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,iflg) bcx(j,k,2)=prf( 0,j,k,iflg) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,iflg) bcx(j,k,2)=prf(np,j,k,iflg) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,iflg) C +uza(1,k,iflg-1) bcy(i,k,2)=prf(i, 0,k,iflg) C +uza(0,k,iflg-1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,iflg) C +uza(mp+1,k,iflg-1) bcy(i,k,2)=prf(i,mp,k,iflg) C +uza(mp,k,iflg-1) enddo enddo end if goto 999 endif if(iflg.eq.51) then ! ---> fox if (leftedge.eq.1) then do k=1,n3 do j=1,n2 g110w=1./((1-icylind)*gmm(1,j,k)*cosa(1,j)+icylind*1.) g220w=1./gmm(1,j,k) g11w=strxx(1,j)*g110w g21w=strxy(1,j)*g220w bcx(j,k,1)=g11w*prf(1,j,k,2)+g21w*prf(1,j,k,3)+strxd(1,j) g110w=1./((1-icylind)*gmm(0,j,k)*cosa(0,j)+icylind*1.) g220w=1./gmm(0,j,k) g11w=strxx(0,j)*g110w g21w=strxy(0,j)*g220w bcx(j,k,2)=g11w*prf(0,j,k,2)+g21w*prf(0,j,k,3)+strxd(0,j) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 g110e=1./((1-icylind)*gmm(np+1,j,k)*cosa(np+1,j)+icylind*1.) g220e=1./gmm(np+1,j,k) g11e=strxx(np+1,j)*g110e g21e=strxy(np+1,j)*g220e bcx(j,k,1)=g11e*prf(np+1,j,k,2)+g21e*prf(np+1,j,k,3)+strxd(np+1,j) g110e=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g220e=1./gmm(np,j,k) g11e=strxx(np,j)*g110e g21e=strxy(np,j)*g220e bcx(j,k,2)=g11e*prf(np,j,k,2)+g21e*prf(np,j,k,3)+strxd(np,j) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 g110s=1./((1-icylind)*gmm(i,1,k)*cosa(i,1)+icylind*1.) g220s=1./gmm(i,1,k) g11s=strxx(i,1)*g110s g21s=strxy(i,1)*g220s c bcy(i,k,1)=g11w*prf(i,1,k,2)+g21s*prf(i,1,k,3)+strxd(i,1) bcy(i,k,1)=g11s*prf(i,1,k,2)+g21s*prf(i,1,k,3)+strxd(i,1) !mod Andii g110s=1./((1-icylind)*gmm(i,0,k)*cosa(i,0)+icylind*1.) g220s=1./gmm(i,0,k) g11s=strxx(i,0)*g110s g21s=strxy(i,0)*g220s c bcy(i,k,2)=g11w*prf(i,0,k,2)+g21s*prf(i,0,k,3)+strxd(i,0) bcy(i,k,2)=g11s*prf(i,0,k,2)+g21s*prf(i,0,k,3)+strxd(i,0) !mod Andii enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 g110n=1./((1-icylind)*gmm(i,mp+1,k)*cosa(i,mp+1)+icylind*1.) g220n=1./gmm(i,mp+1,k) g11n=strxx(i,mp+1)*g110n g21n=strxy(i,mp+1)*g220n bcy(i,k,1)=g11n*prf(i,mp+1,k,2)+g21n*prf(i,mp+1,k,3)+strxd(i,mp+1) g110n=1./((1-icylind)*gmm(i,mp,k)*cosa(i,mp)+icylind*1.) g220n=1./gmm(i,mp,k) g11n=strxx(i,mp)*g110n g21n=strxy(i,mp)*g220n bcy(i,k,2)=g11n*prf(i,mp,k,2)+g21n*prf(i,mp,k,3)+strxd(i,mp) enddo enddo end if goto 999 endif if(iflg.eq.52) then ! ---> foy if (leftedge.eq.1) then do k=1,n3 do j=1,n2 g110w=1./((1-icylind)*gmm(1,j,k)*cosa(1,j)+icylind*1.) g220w=1./gmm(1,j,k) g12w=stryx(1,j)*g110w g22w=stryy(1,j)*g220w bcx(j,k,1)=g12w*prf(1,j,k,2)+g22w*prf(1,j,k,3)+stryd(1,j) g110w=1./((1-icylind)*gmm(0,j,k)*cosa(0,j)+icylind*1.) g220w=1./gmm(0,j,k) g12w=stryx(0,j)*g110w g22w=stryy(0,j)*g220w bcx(j,k,2)=g12w*prf(0,j,k,2)+g22w*prf(0,j,k,3)+stryd(0,j) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 g110e=1./((1-icylind)*gmm(np+1,j,k)*cosa(np+1,j)+icylind*1.) g220e=1./gmm(np+1,j,k) g12e=stryx(np+1,j)*g110e g22e=stryy(np+1,j)*g220e bcx(j,k,1)=g12e*prf(np+1,j,k,2)+g22e*prf(np+1,j,k,3)+stryd(np+1,j) g110e=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g220e=1./gmm(np,j,k) g12e=stryx(np,j)*g110e g22e=stryy(np,j)*g220e bcx(j,k,2)=g12e*prf(np,j,k,2)+g22e*prf(np,j,k,3)+stryd(np,j) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 g110s=1./((1-icylind)*gmm(i,1,k)*cosa(i,1)+icylind*1.) g220s=1./gmm(i,1,k) g12s=stryx(i,1)*g110s g22s=stryy(i,1)*g220s bcy(i,k,1)=g12s*prf(i,1,k,2)+g22s*prf(i,1,k,3)+stryd(i,1) g110s=1./((1-icylind)*gmm(i,0,k)*cosa(i,0)+icylind*1.) g220s=1./gmm(i,0,k) g12s=stryx(i,0)*g110s g22s=stryy(i,0)*g220s bcy(i,k,2)=g12s*prf(i,0,k,2)+g22s*prf(i,0,k,3)+stryd(i,0) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 g110n=1./((1-icylind)*gmm(i,mp+1,k)*cosa(i,mp+1)+icylind*1.) g220n=1./gmm(i,mp+1,k) g12n=stryx(i,mp+1)*g110n g22n=stryy(i,mp+1)*g220n bcy(i,k,1)=g12n*prf(i,mp+1,k,2)+g22n*prf(i,mp+1,k,3)+stryd(i,mp+1) g110n=1./((1-icylind)*gmm(i,mp,k)*cosa(i,mp)+icylind*1.) g220n=1./gmm(i,mp,k) g12n=stryx(i,mp)*g110n g22n=stryy(i,mp)*g220n bcy(i,k,2)=g12n*prf(i,mp,k,2)+g22n*prf(i,mp,k,3)+stryd(i,mp) enddo enddo end if goto 999 endif if(iflg.eq.4.or.iflg.eq.53.or.iflg.eq.12) then ! w0| foz |ftf,fqv,fqc,fqr if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. C +uza(1,k,3) bcy(i,k,2)=0. C +uza(0,k,3) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. C +uza(mp+1,k,3) bcy(i,k,2)=0. C +uza(mp,k,3) enddo enddo end if goto 999 endif #if (MOISTMOD > 0) if(iflg.eq.6) then ! ---> qv if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=qve( 1,j,k) bcx(j,k,2)=qve( 0,j,k) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=qve(np+1,j,k) bcx(j,k,2)=qve(np,j,k) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=qve(i, 1,k) bcy(i,k,2)=qve(i, 0,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=qve(i,mp+1,k) bcy(i,k,2)=qve(i,mp,k) enddo enddo end if goto 999 endif if(iflg.ge.7) then ! ---> qc if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. enddo enddo end if goto 999 endif #endif #endif 999 continue #if (TIMEPLT == 1) call ttend(36) #endif return end #endif /* MHD == 1 */ subroutine integz(a,b) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l), . b(1-ih:np+ih, 1-ih:mp+ih, l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(65) #endif do k=2,l-1 do j=1,mp do i=1,np b(i,j,k)=0.25*(a(i,j,k+1)+2.*a(i,j,k)+a(i,j,k-1)) enddo enddo enddo if(ibcz.eq.0) then do j=1,mp do i=1,np b(i,j,1)=0.5*(a(i,j,2)+a(i,j, 1)) b(i,j,l)=0.5*(a(i,j,l)+a(i,j,l-1)) enddo enddo else do j=1,mp do i=1,np b(i,j,1)=0.25*(a(i,j,2)+2.*a(i,j,1)+a(i,j,l-1)) b(i,j,l)=0.25*(a(i,j,2)+2.*a(i,j,1)+a(i,j,l-1)) enddo enddo endif do k=1,l do j=1,mp do i=1,np a(i,j,k)=b(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(65) #endif return end subroutine prforc(p,pfx,pfy,pfz,u,v,w,c,fc,fd,ft,ub,vb,ob,ibf) include 'param.nml' include 'msg.inc' compute available storage in // parameter (nml=n*m*l) c parameter (nml=n*m*l,iuse=12) c common// wara(iuse) dimension wgx(np),wgy(mp),wgz(l) dimension p(1-ih:np+ih, 1-ih:mp+ih, l), . u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . c(1-ih:np+ih, 1-ih:mp+ih, l), . fc(1-ih:np+ih, 1-ih:mp+ih, l), . fd(1-ih:np+ih, 1-ih:mp+ih, l), . ft(1-ih:np+ih, 1-ih:mp+ih, l), . pfx(1-ih:np+ih, 1-ih:mp+ih, l), . pfy(1-ih:np+ih, 1-ih:mp+ih, l), . pfz(1-ih:np+ih, 1-ih:mp+ih, l) dimension ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) dimension tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/blank/ scr12(1-ih:np+ih,1-ih:mp+ih,l,12), ! gcrk, coef0 . scr13(1-ih:np+ih,1-ih:mp+ih,l), ! free array . px(1-ih:np+ih,1-ih:mp+ih,l), ! local array . py(1-ih:np+ih,1-ih:mp+ih,l), ! local array . pz(1-ih:np+ih,1-ih:mp+ih,l) ! local array dimension pe(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) c common/rigid/ ob(1-ih:np+ih,1-ih:mp+ih,2), !mod c . ub(1-ih:mp+ih, l , 2), c . vb(1-ih:np+ih, l , 2) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/slip/ noslip !mod bbc common/slipb/ noslipb coefficients e1,e2,e3 define extrapolation scheme in pressure boundary conditions for tangential contributions to pressure forces for B-grid calculations common/indx/ e1,e2,e3 c pp(xx)=amax1(xx,0.) c pn(xx)=amin1(xx,0.) #if (TIMEPLT == 1) call ttbeg(13) #endif compute weights for integrals do i=1,np wgx(i)=1. enddo if( leftedge.eq.1) wgx(1)=0.5 if(rightedge.eq.1) wgx(np)=0.5 do j=1,mp wgy(j)=1. enddo if(botedge.eq.1) wgy(1)=0.5 if(topedge.eq.1) wgy(mp)=0.5 do k=1,l wgz(k)=1. enddo wgz(1)=0.5 wgz(l)=0.5 call update(p,np,mp,l,np,mp,iup) if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi compute pressure derivatives everywhere #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim 1 px(i,j,k)=dxil*(p(i+1,j,k)-p(i-1,j,k)) #if (POLES == 0) if (leftedge.eq.1) then do 18 k=1,l do 18 j=1,mp px(1,j,k)=(1-ibcx)*dxi*(p(2,j,k)-p( 1,j,k)) 1 +ibcx*dxil*(p(2,j,k)-p(-1,j,k)) 18 continue end if if (rightedge.eq.1) then do k=1,l do j=1,mp px(np,j,k)=(1-ibcx)*dxi*(p(np ,j,k)-p(np-1,j,k)) 1 +ibcx*dxil*(p(np+2,j,k)-p(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then do 2 k=1,l do 2 j=jllim,julim do 2 i=1,np 2 py(i,j,k)= dyil*(p(i,j+j3,k)-p(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do 28 k=1,l do 28 i=1,np py(i,1,k)=(1-ibcy)*dyi*(p(i,1+j3,k)-p(i, 1,k)) 1 +ibcy*dyil*(p(i,1+j3,k)-p(i,-1,k)) 28 continue end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=(1-ibcy)*dyi*(p(i,mp ,k)-p(i,mp-j3,k)) 1 +ibcy*dyil*(p(i,mp+2,k)-p(i,mp-j3,k)) end do end do end if #endif else do 29 k=1,l do 29 j=1,mp do 29 i=1,np 29 py(i,j,k)=0. endif do 3 k=2,l-1 do 3 j=1,mp do 3 i=1,np 3 pz(i,j,k)=dzil*(p(i,j,k+1)-p(i,j,k-1)) if(ibcz.eq.0) then do 38 j=1,mp do 38 i=1,np pz(i,j,1)= dzi*(p(i,j,2)-p(i,j,1)) 38 pz(i,j,l)= dzi*(p(i,j,l)-p(i,j,l-1)) else do 381 j=1,mp do 381 i=1,np pz(i,j,1)= dzil*(p(i,j,2)-p(i,j,l-1)) 381 pz(i,j,l)= dzil*(p(i,j,2)-p(i,j,l-1)) endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) /* Not ready for POLES = 1 */ dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi illim = 1 + leftedge jllim = 1 + j3*botedge iulim = np + rightedge julim = mp + j3*topedge construct extended, auxiliary pressure field with either cyclic or extrapolated boundaries do 4 k=2,l do 4 j=jllim,mp do 4 i=illim,np 4 pe(i,j,k)=p(i,j,k) do 41 j=jllim,mp do 41 i=illim,np plex=2.*(e1*pe(i,j,2)+e2*pe(i,j,3 )+e3*pe(i,j,4 ))-pe(i,j,2) prex=2.*(e1*pe(i,j,l)+e2*pe(i,j,l-1)+e3*pe(i,j,l-2))-pe(i,j,l) pe(i,j,1) =(1-ibcz)*plex+ibcz*pe(i,j,l) 41 pe(i,j,l+1)=(1-ibcz)*prex+ibcz*pe(i,j,2) #if(PARALLEL == 0) do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3 ,j,k)+e3*pe(4 ,j,k))-pe(2,j,k) prex=2.*(e1*pe(n,j,k)+e2*pe(n-1,j,k)+e3*pe(n-2,j,k))-pe(n,j,k) pe(1 ,j,k)=(1-ibcx)*plex+ibcx*pe(n,j,k) pe(n+1,j,k)=(1-ibcx)*prex+ibcx*pe(2,j,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(pe,np ,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(pe,np+1,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(pe,np ,mp+1,l+1,np+1,mp+1,iupx) else call updatelr(pe,np+1,mp+1,l+1,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3,j,k)+e3*pe(4,j,k))-pe(2,j,k) pe(1,j,k) =(1-ibcx)*plex+ibcx*pe(-1,j,k) enddo enddo endif if (rightedge.eq.1) then do k=1,l+1 do j=jllim,mp prex=2.*(e1*pe(np,j,k)+e2*pe(np-1,j,k)+e3*pe(np-2,j,k))-pe(np,j,k) pe(np+1,j,k)=(1-ibcx)*prex+ibcx*pe(np+3,j,k) enddo enddo endif #endif if(j3.eq.1) then #if(PARALLEL == 0) do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) prex=2.*(e1*pe(i,m ,k)+e2*pe(i,m-j3 ,k) . +e3*pe(i,m-2*j3,k)) -pe(i,m ,k) pe(i,1,k) =(1-ibcy)*plex+ibcy*pe(i,m ,k) pe(i,m+1,k)=(1-ibcy)*prex+ibcy*pe(i,1+j3,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatebt(pe,np ,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(pe,np+1,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(pe,np ,mp+1,l+1,np+1,mp+1,iupy) else call updatebt(pe,np+1,mp+1,l+1,np+1,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) pe(i,1,k)=(1-ibcy)*plex+ibcy*pe(i,-1,k) enddo enddo end if if (topedge.eq.1) then do k=1,l+1 do i=1,iulim prex=2.*(e1*pe(i,mp ,k)+e2*pe(i,mp-j3 ,k) . +e3*pe(i,mp-2*j3,k)) -pe(i,mp ,k) pe(i,mp+1,k)=(1-ibcy)*prex+ibcy*pe(i,mp+3,k) enddo enddo endif #endif endif #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call update(pe,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(pe,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(pe,np ,mp+1,l+1,np+1,mp+1,1) else call update(pe,np+1,mp+1,l+1,np+1,mp+1,1) end if #endif compute pressure derivatives everywhere if(j3.eq.1) then do 5 k=1,l do 5 j=1,mp do 5 i=1,np px(i,j,k)=dxil* . ( pe(i+1,j+j3,k+1)-pe(i,j+j3,k+1)+pe(i+1,j,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i,j+j3,k )+pe(i+1,j,k )-pe(i,j,k ) ) py(i,j,k)=dyil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j,k+1)+pe(i,j+j3,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i+1,j,k )+pe(i,j+j3,k )-pe(i,j,k ) ) pz(i,j,k)=dzil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j+j3,k)+pe(i,j+j3,k+1)-pe(i,j+j3,k) . +pe(i+1,j ,k+1)-pe(i+1,j ,k)+pe(i,j ,k+1)-pe(i,j ,k) ) 5 continue else dxi2=2.*dxil dzi2=2.*dzil do 51 k=1,l do 51 i=1,np px(i,1,k)=dxi2*(pe(i+1,1,k+1)-pe(i,1,k+1)+pe(i+1,1,k)-pe(i,1,k)) 51 pz(i,1,k)=dzi2*(pe(i+1,1,k+1)-pe(i+1,1,k)+pe(i,1,k+1)-pe(i,1,k)) do 52 k=1,l do 52 j=1,mp do 52 i=1,np 52 py(i,j,k)=0. endif #else STOP 'B GRID NOT READY FOR CYCLIC POLE CONDITIONS' #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif compute interior pressure forces c---> c = astri c---> fc = Gmod c---> fd = 1./etainv do 10 k=2-ibcz,l-1+ibcz do 10 j=1,mp do 10 i=1,np F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 pfx(i,j,k)=u(i,j,k)-(c11*px(i,j,k)+c12*py(i,j,k)+c13*pz(i,j,k)) pfy(i,j,k)=v(i,j,k)-(c21*px(i,j,k)+c22*py(i,j,k)+c23*pz(i,j,k)) 10 pfz(i,j,k)=w(i,j,k)-(c31*px(i,j,k)+c32*py(i,j,k)+c33*pz(i,j,k)) compute pressure forces at the boundaries #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then illim=1 else illim=np end if if (rightedge.eq.1) then iulim=np else iulim=1 end if jllim = 1 + (j3-ibcy)*botedge julim = mp + (-j3+ibcy)*topedge do 11 i=illim,iulim,np-1 ii=1+i/np do 111 j=jllim,julim ja=(mpos-1)*mp + j do 111 k=2-ibcz,l-1+ibcz F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfx(i,j,k)= ub(j,k,ii)*coefi pxb=( u(i,j,k)-pfx(i,j,k)-(c12*py(i,j,k)+c13*pz(i,j,k)) )/c11 pfy(i,j,k)=v(i,j,k)-(c21*pxb+c22*py(i,j,k)+c23*pz(i,j,k)) 111 pfz(i,j,k)= . icw*(w(i,j,k)-(c31*pxb+c32*py(i,j,k)+c33*pz(i,j,k))) . +(1-icw)*(g13*pfx(i,j,k)+g23*pfy(i,j,k)) 11 continue if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if do 112 i=illim,iulim,np-1 ii=1+i/np do 112 j=jllim,julim,mp-j3 jj=1+j/mp do 1121 k=2-ibcz,l-1+ibcz F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfx(i,j,k)= ub(j,k,ii)*coefi pfy(i,j,k)= vb(i,k,jj)*coefi a=u(i,j,k)-pfx(i,j,k)-c13*pz(i,j,k) b=v(i,j,k)-pfy(i,j,k)-c23*pz(i,j,k) pxb=(c22*a-c12*b)/(c11*c22-c12*c21) pyb=(c11*b-c21*a)/(c11*c22-c12*c21) 1121 pfz(i,j,k)=w(i,j,k)-(c31*pxb+c32*pyb+c33*pz(i,j,k)) 112 continue endif ! ibcy.eq.0.and.j3.eq.1 endif ! ibcx.eq.0 if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge do 12 j=jllim,julim,mp-j3 jj=1+j/mp do 121 k=2-ibcz,l-1+ibcz do 121 i=illim,iulim F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfy(i,j,k)= vb(i,k,jj)*coefi pyb=( v(i,j,k)-pfy(i,j,k)-(c21*px(i,j,k)+c23*pz(i,j,k)) )/c22 pfx(i,j,k)=u(i,j,k)-(c11*px(i,j,k)+c12*pyb+c13*pz(i,j,k)) 121 pfz(i,j,k)= . icw*(w(i,j,k)-(c31*px(i,j,k)+c32*pyb+c33*pz(i,j,k))) . +(1-icw)*(g13*pfx(i,j,k)+g23*pfy(i,j,k)) 12 continue endif #endif if(ibcz.eq.0) then #if (POLES == 0) jllim = 1 + (j3-ibcy)*botedge julim = mp + (-j3+ibcy)*topedge illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge #else jllim = 1 julim = mp illim = 1 iulim = np #endif do 20 k=1,l,l-1 kk=1+k/l do 21 j=jllim,julim do 21 i=illim,iulim F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pzb=(w(i,j,k)-pfz(i,j,k)-(c31*px(i,j,k)+c32*py(i,j,k)))/c33 pfx(i,j,k)=u(i,j,k)-(c11*px(i,j,k)+c12*py(i,j,k)+c13*pzb) pfy(i,j,k)=v(i,j,k)-(c21*px(i,j,k)+c22*py(i,j,k)+c23*pzb) 21 continue 20 continue #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then illim=1 else illim=np end if if (rightedge.eq.1) then iulim=np else iulim=1 end if do 211 k=1,l,l-1 kk=1+k/l do 211 i=illim,iulim,np-1 ii=1+i/np do 2111 j=jllim,julim F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pfx(i,j,k)= ub(j,k,ii)*coefi pzb=(c11*(w(i,j,k)-pfz(i,j,k))-c31*(u(i,j,k)-pfx(i,j,k)) . -(c11*c32-c31*c12)*py(i,j,k) )/(c11*c33-c31*c13) pxb=(u(i,j,k)-pfx(i,j,k)-(c12*py(i,j,k)+c13*pzb))/c11 2111 pfy(i,j,k)=v(i,j,k)-(c21*pxb+c22*py(i,j,k)+c23*pzb) 211 continue if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if do 212 k=1,l,l-1 kk=1+k/l do 212 i=illim,iulim,np-1 ii=1+i/np do 212 j=jllim,julim,mp-j3 jj=1+j/mp coefi=1./fd(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pfx(i,j,k)= ub(j,k,ii)*coefi pfy(i,j,k)= vb(i,k,jj)*coefi 212 continue endif ! ibcy.eq.0.and.j3.eq.1 endif ! ibcx.eq.0 if(ibcy.eq.0.and.j3.eq.1) then illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if cdel a11=1. do 221 k=1,l,l-1 kk=1+k/l do 221 j=jllim,julim,mp-j3 jj=1+j/mp do 221 i=illim,iulim F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11=g11*a11+g21*a21 c12=g11*a12+g21*a22 c13=g11*a13+g21*a23 c21=g12*a11+g22*a21 c22=g12*a12+g22*a22 c23=g12*a13+g22*a23 c31=g13*a11+g23*a21+g33*a31 c32=g13*a12+g23*a22+g33*a32 c33=g13*a13+g23*a23+g33*a33 coefi=1./fd(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pfy(i,j,k)= vb(i,k,jj)*coefi pzb=( c22*(w(i,j,k)-pfz(i,j,k))-c32*(v(i,j,k)-pfy(i,j,k)) . -(c31*c22-c32*c21)*px(i,j,k) )/(c33*c22-c32*c23) pyb=(v(i,j,k)-pfy(i,j,k)-(c21*px(i,j,k)+c23*pzb))/c22 pfx(i,j,k)=u(i,j,k)-(c11*px(i,j,k)+c12*pyb+c13*pzb) 221 continue 999 continue endif ! ibcy.eq.0.and.j3.eq.1 #endif endif ! ibcz.eq.0 do 99 k=1,l do 99 j=1,mp do 99 i=1,np pfx(i,j,k)=fd(i,j,k)*pfx(i,j,k) pfy(i,j,k)=fd(i,j,k)*pfy(i,j,k) 99 pfz(i,j,k)=fd(i,j,k)*pfz(i,j,k) if(noslip.eq.1) then customized for QBO lab experiment, noslip x boundaries, and zbar=0 as an option #if (POLES == 0) if(leftedge.eq.1) then do k=1,l do j=1,mp c pfx(1,j,k)=0. pfy(1,j,k)=0. pfz(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp c pfx(np,j,k)=0. pfy(np,j,k)=0. pfz(np,j,k)=0. enddo enddo endif #endif c---> noslip lower boundary do j=1,mp do i=1,np pfx(i,j,1)=0. pfy(i,j,1)=0. c pfx(i,j,l)=0. c pfy(i,j,l)=0. enddo enddo endif !mod bbc ! if(ibf.eq.2.and.noslipb.eq.1) then if(ibf.eq.2) then c---> noslipb upper boundary if (ibbl .eq. 1) then do j=1,mp do i=1,np pfx(i,j,1) = 0. pfy(i,j,1) = 0. enddo enddo endif if (ibbu .eq. 1) then do j=1,mp do i=1,np pfx(i,j,l) = 0. pfy(i,j,l) = 0. enddo enddo endif ! if (noslipb.eq.1) then ! do j=1,mp ! do i=1,np ! pfx(i,j,1) = 0. ! pfy(i,j,1) = 0. ! pfx(i,j,l) = 0. ! pfy(i,j,l) = 0. ! enddo ! enddo ! endif ! if (noslipb.eq.2) then ! do j=1,mp ! do i=1,np ! pfx(i,j,l) = 0. ! pfy(i,j,l) = 0. ! enddo ! enddo ! endif ! if (noslipb .ge. 1) call bbcad(ub,vb,ob,rh0) if ((ibbl .eq. 1).or.(ibbu.eq.1)) call bbcad(ub,vb,ob,rh0) endif if (istab.eq.1.and.isphere.eq.0) then iencyc=1 else iencyc=0 endif if(iencyc.eq.1) then c enforce cyclicity !mod if(ibcx.eq.1) then call updatelr(pfx,np,mp,l,np,mp,1) call updatelr(pfy,np,mp,l,np,mp,1) call updatelr(pfz,np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,L do j=1,mp pfx(np,j,k)=pfx(np+1,j,k) pfy(np,j,k)=pfy(np+1,j,k) pfz(np,j,k)=pfz(np+1,j,k) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(pfx,np,mp,l,np,mp,1) call updatebt(pfy,np,mp,l,np,mp,1) call updatebt(pfz,np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,l do i=1,np pfx(i,mp,k)=pfx(i,mp+j3,k) pfy(i,mp,k)=pfy(i,mp+j3,k) pfz(i,mp,k)=pfz(i,mp+j3,k) enddo enddo endif endif endif !iencyc #if (TIMEPLT == 1) call ttend(13) #endif return end subroutine gcrk(p,pfx,pfy,pfz,u,v,w,c,fc,fd,ft,ub,vb,ob, . itr,eps0,inner,ibf) include 'param.nml' include 'msg.inc' dimension p(1-ih:np+ih, 1-ih:mp+ih, l), . pfx(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfx . pfy(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfy . pfz(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfz . u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . c(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fx . fc(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fy . fd(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fz . ft(1-ih:np+ih, 1-ih:mp+ih, l) ! <--- common slt: ft dimension ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/itero/ niter,nitsm,icount,miter,mitsm,jcount,eer,eem common/iterb/ niteb,nitsb,icounb,miteb,mitsb,jcounb,erb,emb common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/blank/ r(1-ih:np+ih,1-ih:mp+ih,l), ! --> r . qr(1-ih:np+ih,1-ih:mp+ih,l), ! --> qr . ar(1-ih:np+ih,1-ih:mp+ih,l), ! --> ar . scr3(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c11 . scr4(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c12 . scr5(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c13 . scr6(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c21 . scr7(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c22 . scr8(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c23 . scr9(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c31 . scr11(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c32 . scr12(1-ih:np+ih,1-ih:mp+ih,l), ! --> coef0: c33 . tmp1(1-ih:np+ih,1-ih:mp+ih,l), ! local array . tmp2(1-ih:np+ih,1-ih:mp+ih,l), ! local array . tmp3(1-ih:np+ih,1-ih:mp+ih,l), ! local array . tmp4(1-ih:np+ih,1-ih:mp+ih,l) ! local array parameter (lrd=3) c parameter (lrd=9) dimension ax2(lrd),axar(lrd),del(lrd) dimension x(1-ih:np+ih, 1-ih:mp+ih, l, lrd), . ax(1-ih:np+ih, 1-ih:mp+ih, l, lrd) real globmax,globsum convergence test modes ************************************************** logical ctest * data ctest/.false./ * c data ctest/.true./ * parameter (nplt=100) * dimension err(0:nplt),xitr(0:nplt) * #if (TIMEPLT == 1) call ttbeg(10) #endif if(ctest) then * itr=900/lrd * ner=2 * snorm=1./float(n*m*l) * eps0=1.e-15 * endif * convergence test modes ************************************************** c itr=90/lrd #if (POLES == 0) kl = 1 + igrid jl = 1 + igrid*j3*botedge il = 1 + igrid*leftedge #else kl = 1 jl = 1 il = 1 #endif lord=lrd if(inner.ge.1) lord=3 eps=eps0*dti if(ibf.eq.2) eps=1.e-2*eps ! eps~sqrt(100.*xmiu)*eps nml=n*m*l epa=1.e-30 nlc=0 c ------ number of outer cycles of pressure iterations: c e.g., calls to precon/lapc: see 200 loop below itmn=1 iprc=1 if(igrid.eq.1) iprc=0 ! grid B call coef0(c,fc,fd,ft) call precon(r,qr,ar,pfx,pfy,pfz,fd,iprc,0) do k1=1,l do j1=1,mp do i1=1,np r(i1,j1,k1)=0. ar(i1,j1,k1)=0. qr(i1,j1,k1)=0. enddo end do end do do i=1,lord do k1=1,l do j1=1,mp do i1=1,np x(i1,j1,k1,i)=0. ax(i1,j1,k1,i)=0. enddo end do end do enddo call prforc(p,pfx,pfy,pfz,u,v,w,c,fc,fd,ft,ub,vb,ob,ibf) call rhsdiv(pfx,pfy,pfz,rho,r,-1) call precon(r,qr,ar,pfx,pfy,pfz,fd,iprc,1) eer0=0. eem0=-1.e15 rl20=0. dvmx0=-1.e15 do k1=kl,l do j1=jl,mp do i1=il,np tmp1(i1,j1,k1)=qr(i1,j1,k1)**2 tmp2(i1,j1,k1)=abs(qr(i1,j1,k1)) tmp3(i1,j1,k1)=r(i1,j1,k1)**2 tmp4(i1,j1,k1)=abs(r(i1,j1,k1)) enddo end do end do eer0=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) eem0=globmax(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) rl20=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) dvmx=globmax(tmp4,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) dvmx= amax1(dvmx,dvmx0) eer0=amax1(eer0,epa) eem0=amax1(eem0,epa) rl20=amax1(rl20,epa) if((dvmx.le.eps).and.(ispcpr.eq.1)) then do k1=kl,l do j1=jl,mp do i1=il,np p(i1,j1,k1)= p(i1,j1,k1)-qr(i1,j1,k1) end do end do end do go to 200 endif convergence test modes ************************************************** if(ctest) then * do ier=0,nplt * err(ier)=eps * enddo * eer=-1.e15 * do k1=kl,l * do j1=jl,mp * do i1=il,np * tmp1(i1,j1,k1)=abs(r(i1,j1,k1)) * enddo * end do * end do * eer=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) * err(0)=eer * if (mype.eq.0) print 300, err(0) * 300 format(4x,e11.4,' residual error at it=1') * endif * convergence test modes ************************************************** do k1=kl,l do j1=jl,mp do i1=il,np x(i1,j1,k1,1)=qr(i1,j1,k1) enddo end do end do call laplc(x(1-ih,1-ih,1,1),ax(1-ih,1-ih,1,1),pfx,pfy,pfz,fd,ibf) c ***** inner iterations ***** do 100 it=1,itr do i=1,lord dvmx0=-1.e15 rl2=0. rax=0. ax2(i)=0. do k1=kl,l do j1=jl,mp do i1=il,np tmp1(i1,j1,k1)= r(i1,j1,k1)* ax(i1,j1,k1,i) tmp2(i1,j1,k1)= ax(i1,j1,k1,i)* ax(i1,j1,k1,i) end do end do end do rax=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) ax2(i)=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) ax2(i)=amax1(epa,ax2(i)) beta=-rax/ax2(i) do k1=kl,l do j1=jl,mp do i1=il,np p(i1,j1,k1)= p(i1,j1,k1)+beta* x(i1,j1,k1,i) r(i1,j1,k1)= r(i1,j1,k1)+beta*ax(i1,j1,k1,i) tmp3(i1,j1,k1)=abs(r(i1,j1,k1)) tmp4(i1,j1,k1)= r(i1,j1,k1)* r(i1,j1,k1) end do end do end do dvmx=globmax(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) dvmx= amax1(dvmx,dvmx0) rl2 =globsum(tmp4,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) if((dvmx.le.eps).and.(it.gt.itmn)) go to 200 ! Linf norm if((rl2.ge.rl20).and.(.not.ctest)) go to 200 ! L2 norm rl20=amax1(rl2,epa) call precon(r,qr,ar,pfx,pfy,pfz,fd,iprc,1) call laplc(qr,ar,pfx,pfy,pfz,fd,ibf) nlc=nlc+1 do ii=1,i axar(ii)=0. do k1=kl,l do j1=jl,mp do i1=il,np tmp1(i1,j1,k1)=ax(i1,j1,k1,ii)*ar(i1,j1,k1) end do end do end do axar(ii)=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) del(ii)=-axar(ii)/ax2(ii) c del(ii)=amax1(del(ii),0.5) enddo if(i.lt.lord) then do k1=kl,l do j1=jl,mp do i1=il,np x(i1,j1,k1,i+1)=qr(i1,j1,k1) ax(i1,j1,k1,i+1)=ar(i1,j1,k1) enddo end do end do do ii=1,i do k1=kl,l do j1=jl,mp do i1=il,np x(i1,j1,k1,i+1)= x(i1,j1,k1,i+1)+del(ii)* x(i1,j1,k1,ii) ax(i1,j1,k1,i+1)=ax(i1,j1,k1,i+1)+del(ii)*ax(i1,j1,k1,ii) enddo end do end do enddo else do k1=kl,l do j1=jl,mp do i1=il,np x(i1,j1,k1,1)=qr(i1,j1,k1)+del(1)* x(i1,j1,k1,1) ax(i1,j1,k1,1)=ar(i1,j1,k1)+del(1)*ax(i1,j1,k1,1) enddo end do end do do ii=2,i do k1=kl,l do j1=jl,mp do i1=il,np x(i1,j1,k1,1 )= x(i1,j1,k1,1)+del(ii)* x(i1,j1,k1,ii) x(i1,j1,k1,ii)=0. ax(i1,j1,k1,1 )=ax(i1,j1,k1,1)+del(ii)*ax(i1,j1,k1,ii) ax(i1,j1,k1,ii)=0. enddo end do end do enddo endif convergence test modes ************************************************** if(ctest) then * if(nlc/ner*ner.eq.nlc) then * ier=nlc/ner * eer=-1.e15 * do k1=kl,l * do j1=jl,mp * do i1=il,np * tmp1(i1,j1,k1)=abs(r(i1,j1,k1)) * enddo * end do * end do * eer=amax1(eer, * . globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l)) * err(ier)=eer * endif * endif * convergence test modes ************************************************** enddo 100 continue c ***** end inner iterations ***** 200 continue IF(ibf.eq.1) THEN eer=0. eem=-1.e15 do k1=kl,l do j1=jl,mp do i1=il,np tmp1(i1,j1,k1)=qr(i1,j1,k1)**2 tmp2(i1,j1,k1)=abs(qr(i1,j1,k1)) enddo end do end do eer = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) eem = amax1(eem, . globmax(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l)) eer=eer/eer0 eem=eem/eem0 if(inner.eq.0) then niter=nlc nitsm=nitsm+niter icount=icount+1 else miter=nlc mitsm=mitsm+miter jcount=jcount+1 endif ELSE erb=0. emb=-1.e15 do k1=kl,l do j1=jl,mp do i1=il,np tmp1(i1,j1,k1)=qr(i1,j1,k1)**2 tmp2(i1,j1,k1)=abs(qr(i1,j1,k1)) enddo end do end do erb = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l) emb = amax1(emb, . globmax(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,il,np,jl,mp,kl,l)) erb=erb/eer0 emb=emb/eem0 if(inner.eq.0) then niteb=nlc nitsb=nitsb+niteb icounb=icounb+1 else miteb=nlc mitsb=mitsb+miteb jcounb=jcounb+1 endif ENDIF !(ibf.eq.1) if(inner.eq.0) then niter=nlc nitsm=nitsm+niter icount=icount+1 c if (mype.eq.0) print 205, inner,niter,dvmx,eer,eem 205 format(1x,'inner,niter,dvmx,eer,eem:',i2,i6,3e11.4) else miter=nlc mitsm=mitsm+miter jcount=jcount+1 c if (mype.eq.0) print 206, inner,miter,dvmx,eer,eem 206 format(1x,'inner,miter,dvmx,eer,eem:',i2,i6,3e11.4) endif convergence test modes ************************************************** if(ctest) then * if (mype.eq.0) print 301, (err(ier),ier=1,nplt,1) * 301 format(4x,5e11.4) * endif * convergence test modes ************************************************** #if (TIMEPLT == 1) call ttend(10) #endif return end subroutine coef0(c,fc,fd,ft) include 'param.nml' include 'msg.inc' dimension c(1-ih:np+ih, 1-ih:mp+ih, l), . fc(1-ih:np+ih, 1-ih:mp+ih, l), . fd(1-ih:np+ih, 1-ih:mp+ih, l), . ft(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) c scr0 to scr2 are occupied by r,qr,ar; common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> r . scr1(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> qr . scr2(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> ar . c11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c11 . c12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c12 . c13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c13 . c21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c21 . c22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c22 . c23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c23 . c31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c31 . c32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c32 . c33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> c33 . temp(1-ih:np+ih,1-ih:mp+ih,l, 4) ! not used c---> c = astri c---> fc = Gmod c---> fd = 1./etainv #if (TIMEPLT == 1) call ttbeg(11) #endif do k=1,l do j=1,mp do i=1,np F2=.5*dt*fcr2(i,j)*c(i,j,k)*initprs F3=.5*dt*fcr3(i,j)*c(i,j,k)*initprs g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) Rt=ft(i,j,k) a11= Rt*(g11+F3*g21)+fc(i,j,k)*(dthe(i,j,k,3)*g11 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g21) a12= Rt*(g12+F3*g22)+fc(i,j,k)*(dthe(i,j,k,3)*g12 + +(F3*dthe(i,j,k,3)+F2*dthe(i,j,k,2))*g22) a13= Rt*(g13+g23*F3-g33*F2)+fc(i,j,k)*( . g23*F2*dthe(i,j,k,2)+(g13+g23*F3)*dthe(i,j,k,3) ) a21= Rt*(g21*(1.+F2*F2)-g11*F3)+fc(i,j,k)*(-F2*g21*dthe(i,j,k,1) + +(g21-F3*g11)*dthe(i,j,k,3)) a22= Rt*(g22*(1.+F2*F2)-g12*F3)+fc(i,j,k)*(-F2*g22*dthe(i,j,k,1) + +(g22-F3*g12)*dthe(i,j,k,3)) a23= Rt*((1.+F2*F2)*g23-F3*g13+F2*F3*g33) . +fc(i,j,k)*((g23-g13*F3)*dthe(i,j,k,3)-g23*F2*dthe(i,j,k,1)) a31= Rt*(F2*g11+F2*F3*g21)-fc(i,j,k)*((g11+F3*g21)*dthe(i,j,k,1) + -(F3*g11-g21)*dthe(i,j,k,2)) a32= Rt*(F2*g12+F2*F3*g22)-fc(i,j,k)*((g12+F3*g22)*dthe(i,j,k,1) + -(F3*g12-g22)*dthe(i,j,k,2)) a33= Rt*(F2*g13+F2*F3*g23+(1+F3*F3)*g33) + -fc(i,j,k)*((g13+F3*g23)*dthe(i,j,k,1) + -(F3*g13-g23)*dthe(i,j,k,2)) c11(i,j,k)=g11*a11+g21*a21 c12(i,j,k)=g11*a12+g21*a22 c13(i,j,k)=g11*a13+g21*a23 c21(i,j,k)=g12*a11+g22*a21 c22(i,j,k)=g12*a12+g22*a22 c23(i,j,k)=g12*a13+g22*a23 c31(i,j,k)=g13*a11+g23*a21+g33*a31 c32(i,j,k)=g13*a12+g23*a22+g33*a32 c33(i,j,k)=g13*a13+g23*a23+g33*a33 end do end do end do #if (TIMEPLT == 1) call ttend(11) #endif return end subroutine precon(rhs,p,r,c11,c22,c33,fd,iflg,jfl) include 'param.nml' include 'msg.inc' include 'param.ior' dimension rhs(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr0 . p(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr1 . r(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr2 . c11(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfx . c22(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfy . c33(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfz . fd(1-ih:np+ih, 1-ih:mp+ih, l) ! <--- common slt: fz iprflg=ispcpr c iprflg=-1 #if(PRECF == 0) if(iprflg.eq.-1) call precon_df(rhs,p,r,c11,c22,c33,fd,iflg,jfl) if(iprflg.eq. 0) call precon_bcz(rhs,p,r,c11,c22,c33,fd,iflg,jfl) c if(iprflg.eq. 0) call precon_adi(rhs,p,r,c11,c22,c33,fd,iflg,jfl) #else if(iprflg.eq. 1) call precon_f(rhs,p,r,fd,iflg,jfl) #endif return end #if(PRECF == 0) subroutine precon_df(rhs,p,r,c11,c22,c33,fd,iflg,jfl) include 'param.nml' include 'msg.inc' include 'param.ior' dimension rhs(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr0 . p(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr1 . r(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr2 . c11(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfx . c22(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfy . c33(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfz . fd(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fz . e(1-ih:np+ih, 1-ih:mp+ih, 0:l-1) ! local array dimension f(np,mp,0:l-1),dgh(np,mp,l) ! local arrays common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> r --> rhs . scr1(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> qr --> p . scr2(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> ar --> r . a11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a11 . a12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a12 . a13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a13 . a21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a21 . a22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a22 . a23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a23 . a31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a31 . a32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a32 . a33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a33 . po(1-ih:np+ih,1-ih:mp+ih,l), ! local array . px(1-ih:np+ih,1-ih:mp+ih,l), ! local array . py(1-ih:np+ih,1-ih:mp+ih,l), ! local array . pz(1-ih:np+ih,1-ih:mp+ih,l) ! local array real globmax,globsum data beta/-1.e15/ c --- itr - number of richardson iterations c --- line - 0 = line iterations data itr,line/8,0/ c data itr,line/2,1/ c data itr,line/1,0/ #if (TIMEPLT == 1) call ttbeg(14) #endif if(iflg.eq.0) then do k=1,l do j=1,mp do i=1,np p(i,j,k)=rhs(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(14) #endif return endif #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif omg=.7 oms=1.-omg dxi2=0.25*dxi*dxi dyi2=0.25*dyi*dyi dzi2=0.25*dzi*dzi do k=1,l do j=1,mp do i=1,np cf00=d(i,j,k)*fd(i,j,k) c11(i,j,k)=cf00*a11(i,j,k)*dxi2 c22(i,j,k)=cf00*a22(i,j,k)*dyi2 c33(i,j,k)=cf00*a33(i,j,k)*dzi2 dgh(i,j,k)=0. po(i,j,k)=0. p(i,j,k)=0. r(i,j,k)=0. enddo enddo enddo if(line.eq.1) then call updatelr(c11,np,mp,l,np,mp,iupx) call updatebt(c22,np,mp,l,np,mp,iupy) do k=1,l do j=1,mp do i=illim,iulim dgh(i,j,k)=c11(i+1,j,k)+c11(i-1,j,k) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp dgh(1,j,k)=c11(2,j,k)+ibcx*c11(-1,j,k) enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp dgh(np,j,k)=ibcx*c11(np+2,j,k)+c11(np-1,j,k) enddo enddo end if #endif if(j3.eq.1) then do k=1,l do j=jllim,julim do i=1,np dgh(i,j,k)=dgh(i,j,k)+c22(i,j+j3,k)+c22(i,j-j3,k) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np dgh(i,1,k)=dgh(i,1,k)+c22(i,1+j3,k)+ibcy*c22(i,-j3,k) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np dgh(i,mp,k)=dgh(i,mp,k)+ibcy*c22(i,mp+1+j3,k)+c22(i,mp-j3,k) enddo enddo end if #endif endif if(ibcz.eq.1) then do j=1,mp do i=1,np do k=2,l-1 dgh(i,j,k)=dgh(i,j,k)+c33(i,j,k+1)+c33(i,j,k-1) enddo dgh(i,j,1)=dgh(i,j,1)+c33(i,j,l-1) dgh(i,j,l)=dgh(i,j,l)+c33(i,j, 2 ) enddo enddo endif endif if(jfl.eq.0) then if(line.eq.0) then beta=-1.e15 do k=1,l do j=1,mp do i=1,np e(i,j,k-1)=(abs(c11(i,j,k))+abs(c22(i,j,k)) . +ibcz*abs(c33(i,j,k)) )/d(i,j,k) enddo enddo enddo beta=amax1(globmax(e,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . beta) beta=0.5/beta else beta=1. endif #if (TIMEPLT == 1) call ttend(14) #endif return endif beti=1./beta*(1-line) do 100 it=1,itr do k=1,l do j=1,mp do i=1,np r(i,j,k)=r(i,j,k)+d(i,j,k)*(beti*p(i,j,k)-rhs(i,j,k)) . +dgh(i,j,k)*p(i,j,k) enddo enddo enddo IF(IBCZ.EQ.0) THEN do j=1,mp do i=1,np e(i,j,0)=1. f(i,j,0)=0. dn=d(i,j,1)*beti+2.*c33(i,j,2)+dgh(i,j,1) e(i,j,1)=2.*c33(i,j,2)/dn f(i,j,1)= r(i,j,1)/dn enddo enddo do k=2,l-1 do j=1,mp do i=1,np dn=c33(i,j,k+1)+c33(i,j,k-1)*(1.-e(i,j,k-2))+d(i,j,k)*beti . + dgh(i,j,k) e(i,j,k)= c33(i,j,k+1)/dn f(i,j,k)=(c33(i,j,k-1)*f(i,j,k-2)+r(i,j,k))/dn enddo enddo enddo do j=1,mp do i=1,np dn=d(i,j,l)*beti+2.*(1.-e(i,j,l-2))*c33(i,j,l-1) . + dgh(i,j,l) p(i,j,l)=(r(i,j,l)+2.*f(i,j,l-2)*c33(i,j,l-1))/dn p(i,j,l-1)=f(i,j,l-1)/(1.-e(i,j,l-1)) enddo enddo do k=l-2,1,-1 do j=1,mp do i=1,np p(i,j,k)=e(i,j,k)*p(i,j,k+2)+f(i,j,k) enddo enddo enddo ELSE do k=1,l do j=1,mp do i=1,np dn=d(i,j,k)*beti+dgh(i,j,k) p(i,j,k)=r(i,j,k)/dn enddo enddo enddo ENDIF if(line.eq.1) then do k=1,l do j=1,mp do i=1,np p(i,j,k)=oms*po(i,j,k)+omg*p(i,j,k) po(i,j,k)= p(i,j,k) enddo enddo enddo endif if(it.eq.itr) go to 101 call update2(p,np,mp,l,np,mp,iup) do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim px(i,j,k)=c11(i,j,k)*(p(i+1,j,k)-p(i-1,j,k)) 1 continue #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp px(1,j,k)=ibcx*c11(1,j,k)*(p(2,j,k)-p(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp px(np,j,k)=ibcx*c11(np,j,k)*(p(np+2,j,k)-p(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then do 28 k=1,l do 28 j=jllim,julim do 28 i=1,np 28 py(i,j,k)= c22(i,j,k)*(p(i,j+j3,k)-p(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np py(i,1,k)=ibcy*c22(i,1,k)*(p(i,1+j3,k)-p(i,-j3,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=ibcy*c22(i,mp,k)*(p(i,mp+1+j3,k)-p(i,mp-j3,k)) end do end do end if #endif else do 29 k=1,l do 29 j=1,mp do 29 i=1,np 29 py(i,j,k)=0. endif if(ibcz.eq.1) then do 3 j=1,mp do 3 i=1,np do k=2,l-1 pz(i,j,k)=c33(i,j,k)*(p(i,j,k+1)-p(i,j,k-1)) enddo pz(i,j,1)=c33(i,j,1)*(p(i,j,2)-p(i,j,l-1)) pz(i,j,l)=c33(i,j,l)*(p(i,j,2)-p(i,j,l-1)) 3 continue endif call updatelr(px,np,mp,l,np,mp,iupx) do 91 k=1,l do 91 j=1,mp do 91 i=illim,iulim 91 r(i,j,k)=px(i+1,j,k)-px(i-1,j,k) #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp r(1,j,k)=(1-ibcx)*2.*px(2,j,k)+ . ibcx*(px(2,j,k)-px(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp r(np,j,k)=(ibcx-1)*2.*px(np-1,j,k)+ . ibcx*(px(np+2,j,k)-px(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then call updatebt(py,np,mp,l,np,mp,iupy) jllim2 = 1 + j3*botedge julim2 = mp - j3*topedge do k=1,l do j=jllim2,julim2 do i=1,np r(i,j,k)=r(i,j,k)+(py(i,j+j3,k)-py(i,j-j3,k)) end do end do end do #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np r(i,1,k)=r(i,1,k)+(1-ibcy)*2.*py(i,1+j3,k) . +ibcy*(py(i,1+j3,k)-py(i,-j3,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np r(i,mp,k)=r(i,mp,k)+(ibcy-1)*2.*py(i,mp-j3,k) 2 +ibcy*(py(i,mp+1+j3,k)-py(i,mp-j3,k)) end do end do end if #else if (botedge.eq.1) then do k=1,l do i=1,np r(i,1,k)=r(i,1,k)+(py(i,1+j3,k)+py(i,1,k )) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np r(i,mp,k)=r(i,mp,k)-(py(i,mp,k)+py(i,mp-j3,k)) end do end do end if #endif endif if(ibcz.eq.1) then do 93 j=1,mp do 93 i=1,np do 931 k=2,l-1 931 r(i,j,k)=r(i,j,k)+(pz(i,j,k+1)-pz(i,j,k-1)) r(i,j,1)=r(i,j,1)+(pz(i,j, 2 )-pz(i,j,l-1)) r(i,j,l)=r(i,j,l)+(pz(i,j, 2 )-pz(i,j,l-1)) 93 continue endif 100 continue 101 continue #if (TIMEPLT == 1) call ttend(14) #endif return end subroutine precon_bcz(rhs,p,r,c11,c22,c33,fd,iflg,jfl) include 'param.nml' include 'msg.inc' include 'param.ior' dimension rhs(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr0 . p(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr1 . r(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr2 . c11(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfx . c22(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfy . c33(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: pfz . fd(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fz . e(1-ih:np+ih, 1-ih:mp+ih, 0:l-1) ! local array dimension f(np,mp,0:l-1),dgh(np,mp,l), . g(npcz,mpcz,0:lcz-1,2),q(npcz,mpcz,lcz,4), . aa(npcz,mpcz,4) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> r --> rhs . scr1(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> qr --> p . scr2(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> ar --> r . a11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a11 . a12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a12 . a13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a13 . a21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a21 . a22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a22 . a23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a23 . a31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a31 . a32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a32 . a33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a33 . po(1-ih:np+ih,1-ih:mp+ih,l), ! local array . px(1-ih:np+ih,1-ih:mp+ih,l), ! local array . py(1-ih:np+ih,1-ih:mp+ih,l), ! local array . pz(1-ih:np+ih,1-ih:mp+ih,l) ! local array real globmax data beta/-1.e15/ c data itr,line/8,0/ data itr,line/2,0/ c data itr,line/2,1/ c data itr,line/6,0/ det3(r11,r12,r13,r21,r22,r23,r31,r32,r33)= . r11*r22*r33+r12*r23*r31+r13*r21*r32 . -r31*r22*r13-r32*r23*r11-r33*r21*r12 #if (TIMEPLT == 1) call ttbeg(15) #endif if(iflg.eq.0) then do k=1,l do j=1,mp do i=1,np p(i,j,k)=rhs(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(15) #endif return endif #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif omg=.7 oms=1.-omg dxi2=0.25*dxi*dxi dyi2=0.25*dyi*dyi dzi2=0.25*dzi*dzi do k=1,l do j=1,mp do i=1,np cf00=d(i,j,k)*fd(i,j,k) c11(i,j,k)=cf00*a11(i,j,k)*dxi2 c22(i,j,k)=cf00*a22(i,j,k)*dyi2 c33(i,j,k)=cf00*a33(i,j,k)*dzi2 dgh(i,j,k)=0. po(i,j,k)=0. p(i,j,k)=0. r(i,j,k)=0. enddo enddo enddo if(line.eq.1) then call updatelr(c11,np,mp,l,np,mp,iupx) call updatebt(c22,np,mp,l,np,mp,iupy) do k=1,l do j=1,mp do i=illim,iulim dgh(i,j,k)=c11(i+1,j,k)+c11(i-1,j,k) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp dgh(1,j,k)=c11(2,j,k)+ibcx*c11(-1,j,k) enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp dgh(np,j,k)=ibcx*c11(np+2,j,k)+c11(np-1,j,k) enddo enddo end if #endif if(j3.eq.1) then do k=1,l do j=jllim,julim do i=1,np dgh(i,j,k)=dgh(i,j,k)+c22(i,j+j3,k)+c22(i,j-j3,k) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np dgh(i,1,k)=dgh(i,1,k)+c22(i,1+j3,k)+ibcy*c22(i,-j3,k) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np dgh(i,mp,k)=dgh(i,mp,k)+ibcy*c22(i,mp+1+j3,k)+c22(i,mp-j3,k) enddo enddo end if #endif endif endif if(jfl.eq.0) then if(line.eq.0) then beta=-1.e15 do k=1,l do j=1,mp do i=1,np e(i,j,k-1)=( abs(c11(i,j,k))+abs(c22(i,j,k)) )/d(i,j,k) enddo enddo enddo beta=amax1(globmax(e,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . beta) beta=0.5/beta else beta=1. endif #if (TIMEPLT == 1) call ttend(15) #endif return endif beti=1./beta*(1-line) do 100 it=1,itr do k=1,l do j=1,mp do i=1,np r(i,j,k)=r(i,j,k)+d(i,j,k)*(beti*p(i,j,k)-rhs(i,j,k)) . +dgh(i,j,k)*p(i,j,k) enddo enddo enddo IF(IBCZ.EQ.0) THEN do j=1,mp do i=1,np e(i,j,0)=1. f(i,j,0)=0. dn=d(i,j,1)*beti+2.*c33(i,j,2)+dgh(i,j,1) e(i,j,1)=2.*c33(i,j,2)/dn f(i,j,1)= r(i,j,1)/dn enddo enddo do k=2,l-1 do j=1,mp do i=1,np dn=c33(i,j,k+1)+c33(i,j,k-1)*(1.-e(i,j,k-2))+d(i,j,k)*beti . + dgh(i,j,k) e(i,j,k)= c33(i,j,k+1)/dn f(i,j,k)=(c33(i,j,k-1)*f(i,j,k-2)+r(i,j,k))/dn enddo enddo enddo do j=1,mp do i=1,np dn=d(i,j,l)*beti+2.*(1.-e(i,j,l-2))*c33(i,j,l-1) . + dgh(i,j,l) p(i,j,l)=(r(i,j,l)+2.*f(i,j,l-2)*c33(i,j,l-1))/dn p(i,j,l-1)=f(i,j,l-1)/(1.-e(i,j,l-1)) enddo enddo do k=l-2,1,-1 do j=1,mp do i=1,np p(i,j,k)=e(i,j,k)*p(i,j,k+2)+f(i,j,k) enddo enddo enddo ELSE i1=ibcz ! remove compiler wornings for exceed array dimension do j=1,mpcz do i=1,npcz e(i,j,0)=0. f(i,j,0)=0. dn=c33(i,j,2)+c33(i,j,l-1)+d(i,j,1)*beti+dgh(i,j,1) e(i,j,1)= c33(i,j,2)/dn f(i,j,1)= r(i,j,1)/dn g(i,j,0 ,1)=1. g(i,j,i1,1)=0. g(i,j,0 ,2)=0. g(i,j,i1,2)= c33(i,j,l-1)/dn enddo enddo il=(1-ibcz)*2+ibcz*(lcz-ibcz) ! (2 or l-1) remove compiler wornings do k=2,il do j=1,mpcz do i=1,npcz dn=c33(i,j,k+1)+c33(i,j,k-1)*(1.-e(i,j,k-2))+d(i,j,k)*beti . + dgh(i,j,k) e(i,j,k)= c33(i,j,k+1)/dn f(i,j,k)=(c33(i,j,k-1)*f(i,j,k-2)+r(i,j,k))/dn g(i,j,k,1)=(c33(i,j,k-1)*g(i,j,k-2,1) )/dn g(i,j,k,2)=(c33(i,j,k-1)*g(i,j,k-2,2) )/dn enddo enddo enddo il=lcz-ibcz ! remove compiler wornings for exceed array dimension do j=1,mpcz do i=1,npcz p(i,j,lcz )=0. p(i,j,il )=f(i,j,il) q(i,j,lcz,1)=0. q(i,j,il ,1)=g(i,j,il,1) q(i,j,lcz,2)=1. q(i,j,il ,2)=0. q(i,j,lcz,3)=0. q(i,j,il ,3)=g(i,j,il,2) q(i,j,lcz,4)=0. q(i,j,il ,4)=e(i,j,il) enddo enddo il=(1-ibcz)+ibcz*(lcz-2*ibcz) ! (l-2 or 1) remove compiler wornings do k=il,1,-ibcz do j=1,mpcz do i=1,npcz p(i,j,k)=e(i,j,k)*p(i,j,k+2)+f(i,j,k) q(i,j,k,1)=e(i,j,k)*q(i,j,k+2,1)+g(i,j,k,1) q(i,j,k,2)=e(i,j,k)*q(i,j,k+2,2) q(i,j,k,3)=e(i,j,k)*q(i,j,k+2,3)+g(i,j,k,2) q(i,j,k,4)=e(i,j,k)*q(i,j,k+2,4) enddo enddo enddo il1=lcz-ibcz ! remove compiler wornings for exceed array dimension il2=lcz-2*ibcz ! remove compiler wornings for exceed array dimension i2 =1+ibcz ! remove compiler wornings for exceed array dimension do j=1,mpcz do i=1,npcz d11= q(i,j,il1,1)-1. d12= q(i,j,il1,2) d13= q(i,j,il1,3) d14= q(i,j,il1,4) s1 =-p(i,j,il1) d21= q(i,j,1,1) d22= q(i,j,1,2)-1. d23= q(i,j,1,3) d24= q(i,j,1,4) s2 =-p(i,j,1) d31= q(i,j,il2,1) d32= q(i,j,il2,2) d33= q(i,j,il2,3)-1. d34= q(i,j,il2,4) s3 =-p(i,j,il2) d41= q(i,j,i2,1) d42= q(i,j,i2,2) d43= q(i,j,i2,3) d44= q(i,j,i2,4)-1. s4 =-p(i,j,i2) det40=d11*det3(d22,d23,d24,d32,d33,d34,d42,d43,d44) . -d21*det3(d12,d13,d14,d32,d33,d34,d42,d43,d44) . +d31*det3(d12,d13,d14,d22,d23,d24,d42,d43,d44) . -d41*det3(d12,d13,d14,d22,d23,d24,d32,d33,d34) deti=1./det40 det41=s1 *det3(d22,d23,d24,d32,d33,d34,d42,d43,d44) . -s2 *det3(d12,d13,d14,d32,d33,d34,d42,d43,d44) . +s3 *det3(d12,d13,d14,d22,d23,d24,d42,d43,d44) . -s4 *det3(d12,d13,d14,d22,d23,d24,d32,d33,d34) det42=d11*det3( s2,d23,d24, s3,d33,d34, s4,d43,d44) . -d21*det3( s1,d13,d14, s3,d33,d34, s4,d43,d44) . +d31*det3( s1,d13,d14, s2,d23,d24, s4,d43,d44) . -d41*det3( s1,d13,d14, s2,d23,d24, s3,d33,d34) det43=d11*det3(d22, s2,d24,d32, s3,d34,d42, s4,d44) . -d21*det3(d12, s1,d14,d32, s3,d34,d42, s4,d44) . +d31*det3(d12, s1,d14,d22, s2,d24,d42, s4,d44) . -d41*det3(d12, s1,d14,d22, s2,d24,d32, s3,d34) det44=d11*det3(d22,d23, s2,d32,d33, s3,d42,d43, s4) . -d21*det3(d12,d13, s1,d32,d33, s3,d42,d43, s4) . +d31*det3(d12,d13, s1,d22,d23, s2,d42,d43, s4) . -d41*det3(d12,d13, s1,d22,d23, s2,d32,d33, s3) aa(i,j,4)=det44*deti aa(i,j,3)=det43*deti aa(i,j,2)=det42*deti aa(i,j,1)=det41*deti enddo enddo do k=1,lcz do j=1,mpcz do i=1,npcz p(i,j,k)=p(i,j,k)+aa(i,j,1)*q(i,j,k,1) . +aa(i,j,2)*q(i,j,k,2) . +aa(i,j,3)*q(i,j,k,3) . +aa(i,j,4)*q(i,j,k,4) enddo enddo enddo correct for round-off departures from the cyclicity in the vertical do j=1,mpcz do i=1,npcz p(i,j,l)=p(i,j,1) enddo enddo ENDIF if(line.eq.1) then do k=1,l do j=1,mp do i=1,np p(i,j,k)=oms*po(i,j,k)+omg*p(i,j,k) po(i,j,k)= p(i,j,k) enddo enddo enddo endif if(ibcz.eq.1) then do j=1,mp do i=1,np p(i,j,l)=p(i,j,1) end do end do endif call update2(p,np,mp,l,np,mp,iup) #if (POLES == 0) if(ibcx.eq.1) then if (rightedge.eq.1) then do k=1,l do j=1,mp p(np,j,k)=p(np+1,j,k) end do end do end if endif if(ibcy.eq.1) then if (topedge.eq.1) then do k=1,l do i=1,np p(i,mp,k)=p(i,mp+1,k) end do end do end if endif #endif if(it.eq.itr) go to 101 do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim px(i,j,k)=c11(i,j,k)*(p(i+1,j,k)-p(i-1,j,k)) 1 continue #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp px(1,j,k)=ibcx*c11(1,j,k)*(p(2,j,k)-p(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp px(np,j,k)=ibcx*c11(np,j,k)*(p(np+2,j,k)-p(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then do 28 k=1,l do 28 j=jllim,julim do 28 i=1,np 28 py(i,j,k)= c22(i,j,k)*(p(i,j+j3,k)-p(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np py(i,1,k)=ibcy*c22(i,1,k)*(p(i,1+j3,k)-p(i,-j3,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=ibcy*c22(i,mp,k)*(p(i,mp+1+j3,k)-p(i,mp-j3,k)) end do end do end if #endif else do 29 k=1,l do 29 j=1,mp do 29 i=1,np 29 py(i,j,k)=0. endif call updatelr(px,np,mp,l,np,mp,iupx) do 91 k=1,l do 91 j=1,mp do 91 i=illim,iulim 91 r(i,j,k)=px(i+1,j,k)-px(i-1,j,k) #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp r(1,j,k)=(1-ibcx)*2.*px(2,j,k)+ . ibcx*(px(2,j,k)-px(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp r(np,j,k)=(ibcx-1)*2.*px(np-1,j,k)+ . ibcx*(px(np+2,j,k)-px(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then C-------------------------------------------- C At the poles C py=dp/dy C d(py)/dy=0 C-------------------------------------------- call updatebt(py,np,mp,l,np,mp,iupy) jllim2 = 1 + j3*botedge julim2 = mp - j3*topedge do k=1,l do j=jllim2,julim2 do i=1,np r(i,j,k)=r(i,j,k)+(py(i,j+j3,k)-py(i,j-j3,k)) end do end do end do #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np r(i,1,k)=r(i,1,k)+(1-ibcy)*2.*py(i,1+j3,k) . +ibcy*(py(i,1+j3,k)-py(i,-j3,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np r(i,mp,k)=r(i,mp,k)+(ibcy-1)*2.*py(i,mp-j3,k) 2 +ibcy*(py(i,mp+1+j3,k)-py(i,mp-j3,k)) end do end do end if #else if (botedge.eq.1) then do k=1,l do i=1,np ! r(i,1,k)=r(i,1,k)+(py(i,1+j3,k)+py(i,1-j3,k )) r(i,1,k)=r(i,1,k)+(py(i,1+j3,k)+py(i,1,k )) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np ! r(i,mp,k)=r(i,mp,k)-(py(i,mp+j3,k)+py(i,mp-j3,k)) r(i,mp,k)=r(i,mp,k)-(py(i,mp,k)+py(i,mp-j3,k)) end do end do end if #endif endif 100 continue 101 continue #if (TIMEPLT == 1) call ttend(15) #endif return end #endif /* PRECF=0 */ #if(PRECF > 0) subroutine precon_f(rhs,p,r,fd,iflg,jfl) include 'param.nml' include 'msg.inc' include 'param.ior' dimension rhs(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr0 . p(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr1 . r(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common blank: scr2 . fd(1-ih:np+ih, 1-ih:mp+ih, l), ! <--- common slt: fz . tmp1(1-ih:np+ih, 1-ih:mp+ih), . tmp2(1-ih:np+ih, 1-ih:mp+ih), . tmp3(1-ih:np+ih, 1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) dimension ar(nssp, mssp, lspp), 1 ai(nssp, mssp, lspp), 1 br(nssp, mssp, lspp), 1 bi(nssp, mssp, lspp) common/fourierC/ egx(nssp,mssp), 1 egy(nssp,mssp), 1 cosx(nspp,nssp,nprocx), 1 cosy(mspp,mssp,nprocy), 1 sinx(nspp,nssp,nprocx), 1 siny(mspp,mssp,nprocy), 1 cosxi(nspp,nssp,nprocx), 1 cosyi(mspp,mssp,nprocy), 1 sinxi(nspp,nssp,nprocx), 1 sinyi(mspp,mssp,nprocy), 1 gx(nspp),gy(mspp), 1 wx(nssp),wy(mssp), 1 xmsk(nspct),ymsk(mspct), 1 xnm,ynm,c11(lspp),c22(lspp),c33(lspp) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> r --> rhs . scr1(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> qr --> p . scr2(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> ar --> r . a11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a11 . a12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a12 . a13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a13 . a21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a21 . a22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a22 . a23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a23 . a31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a31 . a32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a32 . a33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a33 . po(1-ih:np+ih,1-ih:mp+ih,l,4) ! local array real globsum #if (TIMEPLT == 1) call ttbeg(16) #endif if(iflg.eq.0) then do k=1,l do j=1,mp do i=1,np p(i,j,k)=rhs(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(16) #endif return endif if(jfl.eq.0) then fnmi=1./float(n*m) fdzi25=0.25*dzi*dzi*fnmi do k=1,l temp1=0. temp2=0. temp3=0. do j=1,mp do i=1,np p(i,j,k)=0. r(i,j,k)=d(i,j,k)*rhs(i,j,k) temp1=temp1+d(i,j,k)*fd(i,j,k)*a11(i,j,k) temp2=temp2+d(i,j,k)*fd(i,j,k)*a22(i,j,k) temp3=temp3+d(i,j,k)*fd(i,j,k)*a33(i,j,k) end do end do c11(k)=globsum(temp1,1,1,1,1,1,1,1,1,1,1,1,1) c22(k)=globsum(temp2,1,1,1,1,1,1,1,1,1,1,1,1) c33(k)=globsum(temp3,1,1,1,1,1,1,1,1,1,1,1,1) c11(k)=c11(k)*fnmi c22(k)=c22(k)*fnmi c33(k)=c33(k)*fdzi25 enddo #if (TIMEPLT == 1) call ttend(16) #endif return endif do k=1,l do j=1,mp do i=1,np p(i,j,k)=0. r(i,j,k)=-d(i,j,k)*rhs(i,j,k) end do end do end do #if (TIMEPLT == 1) call ttend(16) #endif call fourier(r,ar,ai,br,bi,1) c ------> solve 3-diagonal problems for Fourier amplitudes call tridg(ar) IF(IBCX*IBCY.EQ.1) THEN call tridg(ai) call tridg(br) call tridg(bi) ENDIF IF(IBCX.EQ.1.and.IBCY.EQ.0) THEN call tridg(bi) ENDIF IF(IBCX.EQ.0.and.IBCY.EQ.1) THEN call tridg(br) ENDIF call fourieri(p,ar,ai,br,bi,-1) return end subroutine fourier(r,ar,ai,br,bi,iflg) include 'param.nml' include 'msg.inc' include 'param.ior' #if (PARALLEL > 0) #include "msg.lnk" #endif dimension r(1-ih:np+ih, 1-ih:mp+ih, l), 1 ar(nssp, mssp, lspp), 1 ai(nssp, mssp, lspp), 1 br(nssp, mssp, lspp), 1 bi(nssp, mssp, lspp), #if (PARALLEL == 0) 2 ari(nssp, mssp), 2 aii(nssp, mssp), 2 bri(nssp, mssp), 2 bii(nssp, mssp), 2 arj(nssp, mspp), 2 aij(nssp, mspp), 2 brj(nssp, mspp), 2 bij(nssp, mspp) #else 2 dri(nssp, mssp, nprocy, 4), 2 cri(mspp, nssp, nprocx, 4) #endif common/fourierC/ egx(nssp,mssp), 1 egy(nssp,mssp), 1 cosx(nspp,nssp,nprocx), 1 cosy(mspp,mssp,nprocy), 1 sinx(nspp,nssp,nprocx), 1 siny(mspp,mssp,nprocy), 1 cosxi(nspp,nssp,nprocx), 1 cosyi(mspp,mssp,nprocy), 1 sinxi(nspp,nssp,nprocx), 1 sinyi(mspp,mssp,nprocy), 1 gx(nspp),gy(mspp), 1 wx(nssp),wy(mssp), 1 xmsk(nspct),ymsk(mspct), 1 xnm,ynm,c11(lspp),c22(lspp),c33(lspp) common/cnnmm/ nnp,nprocxp,mmp,nprocyp common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(17) #endif compute Fourier transform #if (POLES == 0) iulimc = np - rightedge*ibcx julimc = mp - topedge*ibcy #else iulimc = np julimc = mp #endif IF(IBCX*IBCY.EQ.1) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocxp ! nr of processors occupying spectral space in X do ii=1,nssp ! typical spectral size in X for each processor do j=1,mp cri(j,ii,is,1)=0. cri(j,ii,is,2)=0. cri(j,ii,is,3)=0. cri(j,ii,is,4)=0. do i=1,iulimc ! n-ibcx - physical space cri(j,ii,is,1)=cri(j,ii,is,1)+r(i,j,k)*cosx(i,ii,is) cri(j,ii,is,2)=cri(j,ii,is,2)+r(i,j,k)*sinx(i,ii,is) cri(j,ii,is,3)=cri(j,ii,is,3)+r(i,j,k)*cosx(i,ii,is) cri(j,ii,is,4)=cri(j,ii,is,4)+r(i,j,k)*sinx(i,ii,is) end do end do end do end do nx=mp*nssp*nprocxp*4 ! sum over physical space in X CALL MPI_ALLReduce(cri(1:mspp,1:nssp,1:nprocxp,1:4), . cri(1:mspp,1:nssp,1:nprocxp,1:4), . nx,DC_TYPE,MPI_SUM,my_row,ierr) do js=1,nprocyp ! nr of processors occupying spectral space in Y do jj=1,mssp ! typical spectral size in Y for each processor do ii=1,nssp ! typical spectral size in X for each processor dri(ii,jj,js,1)=0. dri(ii,jj,js,2)=0. dri(ii,jj,js,3)=0. dri(ii,jj,js,4)=0. do j=1,julimc ! m-ibcy - physical space dri(ii,jj,js,1)=dri(ii,jj,js,1)+cri(j,ii,npos,1)*cosy(j,jj,js) dri(ii,jj,js,2)=dri(ii,jj,js,2)+cri(j,ii,npos,2)*siny(j,jj,js) dri(ii,jj,js,3)=dri(ii,jj,js,3)+cri(j,ii,npos,3)*siny(j,jj,js) dri(ii,jj,js,4)=dri(ii,jj,js,4)+cri(j,ii,npos,4)*cosy(j,jj,js) end do enddo end do end do nx=mssp*nssp*nprocyp*4 ! sum over physical space in Y CALL MPI_ALLReduce(dri(1:nssp,1:mssp,1:nprocyp,1:4), . dri(1:nssp,1:mssp,1:nprocyp,1:4), . nx,DC_TYPE,MPI_SUM,my_col,ierr) do ii=1,nnp ! local spectral space nnp do jj=1,mmp ! local spectral space mmp ar(ii,jj,k)=dri(ii,jj,mpos,1) ai(ii,jj,k)=dri(ii,jj,mpos,2) br(ii,jj,k)=dri(ii,jj,mpos,3) bi(ii,jj,k)=dri(ii,jj,mpos,4) end do end do #else do ii=1,nnp do j=1,mp arj(ii,j)=0. aij(ii,j)=0. brj(ii,j)=0. bij(ii,j)=0. do i=1,iulimc ! n-ibcx - physical space arj(ii,j)=arj(ii,j)+r(i,j,k)*cosx(i,ii,1) aij(ii,j)=aij(ii,j)+r(i,j,k)*sinx(i,ii,1) brj(ii,j)=brj(ii,j)+r(i,j,k)*cosx(i,ii,1) bij(ii,j)=bij(ii,j)+r(i,j,k)*sinx(i,ii,1) end do end do end do do ii=1,nnp do jj=1,mmp ar(ii,jj,k)=0. ai(ii,jj,k)=0. br(ii,jj,k)=0. bi(ii,jj,k)=0. do j=1,julimc ! m-ibcy - physical space ar(ii,jj,k)=ar(ii,jj,k)+arj(ii,j)*cosy(j,jj,1) ai(ii,jj,k)=ai(ii,jj,k)+aij(ii,j)*siny(j,jj,1) br(ii,jj,k)=br(ii,jj,k)+brj(ii,j)*siny(j,jj,1) bi(ii,jj,k)=bi(ii,jj,k)+bij(ii,j)*cosy(j,jj,1) end do enddo end do #endif ENDDO ENDIF IF(IBCX.EQ.1.and.IBCY.EQ.0) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocxp ! nr of processors occupying spectral space in X do ii=1,nssp ! typical spectral size in X for each processor do j=1,mp cri(j,ii,is,1)=0. cri(j,ii,is,2)=0. do i=1,iulimc ! n-ibcx - physical space cri(j,ii,is,1)=cri(j,ii,is,1)+r(i,j,k)*cosx(i,ii,is) cri(j,ii,is,2)=cri(j,ii,is,2)+r(i,j,k)*sinx(i,ii,is) end do end do end do end do nx=mp*nssp*nprocxp*2 ! sum over physical space in X CALL MPI_ALLReduce(cri(1:mspp,1:nssp,1:nprocxp,1:2), . cri(1:mspp,1:nssp,1:nprocxp,1:2), . nx,DC_TYPE,MPI_SUM,my_row,ierr) do js=1,nprocyp ! nr of processors occupying spectral space in Y do jj=1,mssp ! typical spectral size in Y for each processor do ii=1,nssp ! typical spectral size in X for each processor dri(ii,jj,js,1)=0. dri(ii,jj,js,2)=0. do j=1,julimc ! m-ibcy - physical space dri(ii,jj,js,1)=dri(ii,jj,js,1) . +cri( j,ii,npos,1)*cosy(j,jj,js)*gy(j) dri(ii,jj,js,2)=dri(ii,jj,js,2) . +cri( j,ii,npos,2)*cosy(j,jj,js)*gy(j) end do enddo end do end do nx=mssp*nssp*nprocyp*2 ! sum over physical space in Y CALL MPI_ALLReduce(dri(1:nssp,1:mssp,1:nprocyp,1:2), . dri(1:nssp,1:mssp,1:nprocyp,1:2), . nx,DC_TYPE,MPI_SUM,my_col,ierr) do ii=1,nnp ! local spectral space nnp do jj=1,mmp ! local spectral space mmp ar(ii,jj,k)=dri(ii,jj,mpos,1) bi(ii,jj,k)=dri(ii,jj,mpos,2) end do end do #else do ii=1,nnp do j=1,mp arj(ii,j)=0. bij(ii,j)=0. do i=1,iulimc ! n-ibcx - physical space arj(ii,j)=arj(ii,j)+r(i,j,k)*cosx(i,ii,1) bij(ii,j)=bij(ii,j)+r(i,j,k)*sinx(i,ii,1) end do end do end do do ii=1,nnp do jj=1,mmp ar(ii,jj,k)=0. bi(ii,jj,k)=0. do j=1,julimc ! m-ibcy - physical space ar(ii,jj,k)=ar(ii,jj,k)+arj(ii,j)*cosy(j,jj,1)*gy(j) bi(ii,jj,k)=bi(ii,jj,k)+bij(ii,j)*cosy(j,jj,1)*gy(j) end do enddo end do #endif ENDDO ENDIF IF(IBCX.eq.0.and.IBCY.EQ.1) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocxp ! nr of processors occupying spectral space in X do ii=1,nssp ! typical spectral size in X for each processor do j=1,mp cri(j,ii,is,1)=0. do i=1,iulimc ! n-ibcx - physical space cri(j,ii,is,1)=cri(j,ii,is,1)+r(i,j,k)*cosx(i,ii,is)*gx(i) end do end do end do end do nx=mp*nssp*nprocxp*1 ! sum over physical space in X CALL MPI_ALLReduce(cri(1:mspp,1:nssp,1:nprocxp,1:1), . cri(1:mspp,1:nssp,1:nprocxp,1:1), . nx,DC_TYPE,MPI_SUM,my_row,ierr) do js=1,nprocyp ! nr of processors occupying spectral space in Y do jj=1,mssp ! typical spectral size in Y for each processor do ii=1,nssp ! typical spectral size in X for each processor dri(ii,jj,js,1)=0. dri(ii,jj,js,2)=0. do j=1,julimc ! m-ibcy - physical space dri(ii,jj,js,1)=dri(ii,jj,js,1)+cri(j,ii,npos,1)*cosy(j,jj,js) dri(ii,jj,js,2)=dri(ii,jj,js,2)+cri(j,ii,npos,1)*siny(j,jj,js) end do enddo end do end do nx=mssp*nssp*nprocyp*2 ! sum over physical space in Y CALL MPI_ALLReduce(dri(1:nssp,1:mssp,1:nprocyp,1:2), . dri(1:nssp,1:mssp,1:nprocyp,1:2), . nx,DC_TYPE,MPI_SUM,my_col,ierr) do ii=1,nnp ! local spectral space nnp do jj=1,mmp ! local spectral space mmp ar(ii,jj,k)=dri(ii,jj,mpos,1) br(ii,jj,k)=dri(ii,jj,mpos,2) end do end do #else do ii=1,nnp do j=1,mp arj(ii,j)=0. do i=1,iulimc ! n-ibcx - physical space arj(ii,j)=arj(ii,j)+r(i,j,k)*cosx(i,ii,1)*gx(i) end do end do end do do ii=1,nnp do jj=1,mmp ar(ii,jj,k)=0. br(ii,jj,k)=0. do j=1,julimc ! m-ibcy - physical space ar(ii,jj,k)=ar(ii,jj,k)+arj(ii,j)*cosy(j,jj,1) br(ii,jj,k)=br(ii,jj,k)+arj(ii,j)*siny(j,jj,1) end do enddo end do #endif ENDDO ENDIF IF(IBCX.eq.0.and.IBCY.EQ.0) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocxp ! nr of processors occupying spectral space in X do ii=1,nssp ! typical spectral size in X for each processor do j=1,mp cri(j,ii,is,1)=0. do i=1,iulimc ! n-ibcx - physical space cri(j,ii,is,1)=cri(j,ii,is,1)+r(i,j,k)*cosx(i,ii,is)*gx(i) end do end do end do end do nx=mp*nssp*nprocxp*1 ! sum over physical space in X CALL MPI_ALLReduce(cri(1:mspp,1:nssp,1:nprocxp,1:1), . cri(1:mspp,1:nssp,1:nprocxp,1:1), . nx,DC_TYPE,MPI_SUM,my_row,ierr) do js=1,nprocyp ! nr of processors occupying spectral space in Y do jj=1,mssp ! typical spectral size in Y for each processor do ii=1,nssp ! typical spectral size in X for each processor dri(ii,jj,js,1)=0. do j=1,julimc ! m-ibcy - physical space dri(ii,jj,js,1)=dri(ii,jj,js,1) . +cri( j,ii,npos,1)*cosy(j,jj,js)*gy(j) end do enddo end do end do nx=mssp*nssp*nprocyp*1 ! sum over physical space in Y CALL MPI_ALLReduce(dri(1:nssp,1:mssp,1:nprocyp,1:1), . dri(1:nssp,1:mssp,1:nprocyp,1:1), . nx,DC_TYPE,MPI_SUM,my_col,ierr) do ii=1,nnp ! local spectral space nnp do jj=1,mmp ! local spectral space mmp ar(ii,jj,k)=dri(ii,jj,mpos,1) end do end do #else do ii=1,nnp do j=1,mp arj(ii,j)=0. do i=1,iulimc ! n-ibcx - physical space arj(ii,j)=arj(ii,j)+r(i,j,k)*cosx(i,ii,1)*gx(i) end do end do end do do ii=1,nnp do jj=1,mmp ar(ii,jj,k)=0. do j=1,julimc ! m-ibcy - physical space ar(ii,jj,k)=ar(ii,jj,k)+arj(ii,j)*cosy(j,jj,1)*gy(j) end do enddo end do #endif ENDDO ENDIF #if (TIMEPLT == 1) call ttend(17) #endif return end subroutine fourieri(r,ar,ai,br,bi,iflg) include 'param.nml' include 'msg.inc' include 'param.ior' #if (PARALLEL > 0) #include "msg.lnk" #endif dimension r(1-ih:np+ih, 1-ih:mp+ih, l), 1 ar(nssp, mssp, lspp), 1 ai(nssp, mssp, lspp), 1 br(nssp, mssp, lspp), 1 bi(nssp, mssp, lspp), #if (PARALLEL == 0) 2 prj(mssp, nspp), 2 pij(mssp, nspp), 2 qrj(mssp, nspp), 2 qij(mssp, nspp) #else 2 xii(mssp, nspp, nprocx, 4), 2 rii(nspp, mspp, nprocy) #endif common/fourierC/ egx(nssp,mssp), 1 egy(nssp,mssp), 1 cosx(nspp,nssp,nprocx), 1 cosy(mspp,mssp,nprocy), 1 sinx(nspp,nssp,nprocx), 1 siny(mspp,mssp,nprocy), 1 cosxi(nspp,nssp,nprocx), 1 cosyi(mspp,mssp,nprocy), 1 sinxi(nspp,nssp,nprocx), 1 sinyi(mspp,mssp,nprocy), 1 gx(nspp),gy(mspp), 1 wx(nssp),wy(mssp), 1 xmsk(nspct),ymsk(mspct), 1 xnm,ynm,c11(lspp),c22(lspp),c33(lspp) common/cnnmm/ nnp,nprocxp,mmp,nprocyp common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(18) #endif compute inverse Fourier transform !synthesis IF(IBCX*IBCY.EQ.1) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocx ! physiscal space do i=1,np do jj=1,mssp ! typical local spectral space xii(jj,i,is,1)=0. xii(jj,i,is,2)=0. xii(jj,i,is,3)=0. xii(jj,i,is,4)=0. do ii=1,nnp ! nnp spectral space xii(jj,i,is,1)=xii(jj,i,is,1)+ar(ii,jj,k)*cosxi(i,ii,is) xii(jj,i,is,2)=xii(jj,i,is,2)+ai(ii,jj,k)*sinxi(i,ii,is) xii(jj,i,is,3)=xii(jj,i,is,3)+br(ii,jj,k)*cosxi(i,ii,is) xii(jj,i,is,4)=xii(jj,i,is,4)+bi(ii,jj,k)*sinxi(i,ii,is) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(nnp.gt.0) then nx=mssp*nspp*nprocx*4 CALL MPI_ALLReduce(xii(1:mssp,1:nspp,1:nprocx,1:4), . xii(1:mssp,1:nspp,1:nprocx,1:4), . nx,DC_TYPE,MPI_SUM,my_row_sp(mpos),ier) irecv=mype+nprocxp if(irecv.le.(mpos*nprocx-1))then irpos=npos+nprocxp nx=mssp*np*4 call MPI_SEND(xii(1:mssp,1:nspp,irpos:irpos,1:4), . nx,DC_TYPE,irecv,irecv,MPI_WORLD_COMM,ier) endif else nx=mssp*np*4 call MPI_Recv(xii(1:mssp,1:nspp,npos:npos,1:4), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do js=1,nprocy ! physiscal space do j=1,mp do i=1,np rii(i,j,js)=0. do jj=1,mmp ! mmp spectral space rii(i,j,js)=rii(i,j,js)+xii(jj,i,npos,1)*cosyi(j,jj,js) . +xii(jj,i,npos,2)*sinyi(j,jj,js) . +xii(jj,i,npos,3)*sinyi(j,jj,js) . +xii(jj,i,npos,4)*cosyi(j,jj,js) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(mmp.gt.0) then nx=nspp*mspp*nprocy CALL MPI_ALLReduce(rii,rii,nx,DC_TYPE,MPI_SUM,my_col_sp(npos),ier) jrecv=mype+nprocx*nprocyp if(jrecv.le.(npos+nprocx*(nprocy-1)))then jrpos=mpos+nprocyp nx=nspp*mspp call MPI_SEND(rii(1:nspp,1:mspp,jrpos:jrpos), . nx,DC_TYPE,jrecv,jrecv,MPI_WORLD_COMM,ier) endif else nx=nspp*mspp call MPI_Recv(rii(1:nspp,1:mspp,mpos:mpos), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do j=1,mp do i=1,np r(i,j,k)=rii(i,j,mpos) enddo enddo #else do i=1,np do jj=1,mmp ! local spectral space mmp prj(jj,i)=0. pij(jj,i)=0. qrj(jj,i)=0. qij(jj,i)=0. do ii=1,nnp ! nnp spectral space prj(jj,i)=prj(jj,i)+ar(ii,jj,k)*cosxi(i,ii,1) pij(jj,i)=pij(jj,i)+ai(ii,jj,k)*sinxi(i,ii,1) qrj(jj,i)=qrj(jj,i)+br(ii,jj,k)*cosxi(i,ii,1) qij(jj,i)=qij(jj,i)+bi(ii,jj,k)*sinxi(i,ii,1) enddo enddo enddo do i=1,np do j=1,mp r(i,j,k)=0. do jj=1,mmp ! spectral space r(i,j,k)=r(i,j,k)+prj(jj,i)*cosyi(j,jj,1) . +pij(jj,i)*sinyi(j,jj,1) . +qrj(jj,i)*sinyi(j,jj,1) . +qij(jj,i)*cosyi(j,jj,1) enddo enddo enddo #endif ENDDO ENDIF IF(IBCX.eq.1.and.IBCY.EQ.0) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocx ! physiscal space do i=1,np do jj=1,mssp ! typical local spectral space xii(jj,i,is,1)=0. xii(jj,i,is,2)=0. do ii=1,nnp ! nnp spectral space xii(jj,i,is,1)=xii(jj,i,is,1)+ar(ii,jj,k)*cosxi(i,ii,is) xii(jj,i,is,2)=xii(jj,i,is,2)+bi(ii,jj,k)*sinxi(i,ii,is) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(nnp.gt.0) then nx=mssp*nspp*nprocx*2 CALL MPI_ALLReduce(xii(1:mssp,1:nspp,1:nprocx,1:2), . xii(1:mssp,1:nspp,1:nprocx,1:2), . nx,DC_TYPE,MPI_SUM,my_row_sp(mpos),ier) irecv=mype+nprocxp if(irecv.le.(mpos*nprocx-1))then irpos=npos+nprocxp nx=mssp*np*2 call MPI_ISEND(xii(1:mssp,1:nspp,irpos:irpos,1:2), . nx,DC_TYPE,irecv,irecv,MPI_WORLD_COMM,stats,ier) endif else nx=mssp*np*2 call MPI_Recv(xii(1:mssp,1:nspp,npos:npos,1:2), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do js=1,nprocy ! physiscal space do j=1,mp rii(i,j,js)=0. do jj=1,mmp ! mmp spectral space rii(i,j,js)=rii(i,j,js)+xii(jj,i,npos,1)*cosyi(j,jj,js) . +xii(jj,i,npos,2)*cosyi(j,jj,js) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(mmp.gt.0) then nx=nspp*mspp*nprocy CALL MPI_ALLReduce(rii,rii,nx,DC_TYPE,MPI_SUM,my_col_sp(npos),ier) jrecv=mype+nprocx*nprocyp if(jrecv.le.(npos+nprocx*(nprocy-1)))then jrpos=mpos+nprocyp nx=nspp*mspp call MPI_ISEND(rii(1:nspp,1:mspp,jrpos:jrpos), . nx,DC_TYPE,jrecv,jrecv,MPI_WORLD_COMM,stats,ier) endif else nx=nspp*mspp call MPI_Recv(rii(1:nspp,1:mspp,mpos:mpos), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do j=1,mp r(i,j,k)=rii(i,j,mpos) enddo enddo #else do i=1,np do jj=1,mmp prj(jj,i)=0. qij(jj,i)=0. do ii=1,nnp prj(jj,i)=prj(jj,i)+ar(ii,jj,k)*cosxi(i,ii,1) qij(jj,i)=qij(jj,i)+bi(ii,jj,k)*sinxi(i,ii,1) enddo enddo enddo do j=1,mp do i=1,np r(i,j,k)=0. do jj=1,mmp r(i,j,k)=r(i,j,k)+prj(jj,i)*cosyi(j,jj,1) . +qij(jj,i)*cosyi(j,jj,1) enddo enddo enddo #endif ENDDO ENDIF IF(IBCX.eq.0.and.IBCY.EQ.1) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocx ! physiscal space do i=1,np do jj=1,mssp ! typical local spectral space xii(jj,i,is,1)=0. xii(jj,i,is,2)=0. do ii=1,nnp ! nnp spectral space xii(jj,i,is,1)=xii(jj,i,is,1)+ar(ii,jj,k)*cosxi(i,ii,is) xii(jj,i,is,2)=xii(jj,i,is,2)+br(ii,jj,k)*cosxi(i,ii,is) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(nnp.gt.0) then nx=mssp*nspp*nprocx*2 CALL MPI_ALLReduce(xii(1:mssp,1:nspp,1:nprocx,1:2), . xii(1:mssp,1:nspp,1:nprocx,1:2), . nx,DC_TYPE,MPI_SUM,my_row_sp(mpos),ier) irecv=mype+nprocxp if(irecv.le.(mpos*nprocx-1))then irpos=npos+nprocxp nx=mssp*np*2 call MPI_ISEND(xii(1:mssp,1:nspp,irpos:irpos,1:2), . nx,DC_TYPE,irecv,irecv,MPI_WORLD_COMM,stats,ier) endif else nx=mssp*np*2 call MPI_Recv(xii(1:mssp,1:nspp,npos:npos,1:2), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do js=1,nprocy ! physiscal space do j=1,mp rii(i,j,js)=0. do jj=1,mmp ! mmp spectral space rii(i,j,js)=rii(i,j,js)+xii(jj,i,npos,1)*cosyi(j,jj,js) . +xii(jj,i,npos,2)*sinyi(j,jj,js) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(mmp.gt.0) then nx=nspp*mspp*nprocy CALL MPI_ALLReduce(rii,rii,nx,DC_TYPE,MPI_SUM,my_col_sp(npos),ier) jrecv=mype+nprocx*nprocyp if(jrecv.le.(npos+nprocx*(nprocy-1)))then jrpos=mpos+nprocyp nx=nspp*mspp call MPI_ISEND(rii(1:nspp,1:mspp,jrpos:jrpos), . nx,DC_TYPE,jrecv,jrecv,MPI_WORLD_COMM,stats,ier) endif else nx=nspp*mspp call MPI_Recv(rii(1:nspp,1:mspp,mpos:mpos), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do j=1,mp r(i,j,k)=rii(i,j,mpos) enddo enddo #else do i=1,np do jj=1,mmp prj(jj,i)=0. qrj(jj,i)=0. do ii=1,nnp prj(jj,i)=prj(jj,i)+ar(ii,jj,k)*cosxi(i,ii,1) qrj(jj,i)=qrj(jj,i)+br(ii,jj,k)*cosxi(i,ii,1) enddo enddo enddo do j=1,mp do i=1,np r(i,j,k)=0. do jj=1,mmp r(i,j,k)=r(i,j,k)+prj(jj,i)*cosyi(j,jj,1) . +qrj(jj,i)*sinyi(j,jj,1) enddo enddo enddo #endif ENDDO ENDIF IF(IBCX.eq.0.and.IBCY.EQ.0) THEN DO K=1,L #if (PARALLEL == 2) do is=1,nprocx ! physiscal space do i=1,np do jj=1,mssp ! typical local spectral space xii(jj,i,is,1)=0. xii(jj,i,is,2)=0. do ii=1,nnp ! nnp spectral space xii(jj,i,is,1)=xii(jj,i,is,1)+ar(ii,jj,k)*cosxi(i,ii,is) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(nnp.gt.0) then nx=mssp*nspp*nprocx*1 CALL MPI_ALLReduce(xii(1:mssp,1:nspp,1:nprocx,1:1), . xii(1:mssp,1:nspp,1:nprocx,1:1), . nx,DC_TYPE,MPI_SUM,my_row_sp(mpos),ier) irecv=mype+nprocxp if(irecv.le.(mpos*nprocx-1))then irpos=npos+nprocxp nx=mssp*np*1 call MPI_ISEND(xii(1:mssp,1:nspp,irpos:irpos,1:1), . nx,DC_TYPE,irecv,irecv,MPI_WORLD_COMM,stats,ier) endif else nx=mssp*np*1 call MPI_Recv(xii(1:mssp,1:nspp,npos:npos,1:1), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do js=1,nprocy ! physiscal space do j=1,mp rii(i,j,js)=0. do jj=1,mmp ! mmp spectral space rii(i,j,js)=rii(i,j,js)+xii(jj,i,npos,1)*cosyi(j,jj,js) enddo enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Barrier(MPI_COMM_EULAG, ierr) if(mmp.gt.0) then nx=nspp*mspp*nprocy CALL MPI_ALLReduce(rii,rii,nx,DC_TYPE,MPI_SUM,my_col_sp(npos),ier) jrecv=mype+nprocx*nprocyp if(jrecv.le.(npos+nprocx*(nprocy-1)))then jrpos=mpos+nprocyp nx=nspp*mspp call MPI_ISEND(rii(1:nspp,1:mspp,jrpos:jrpos), . nx,DC_TYPE,jrecv,jrecv,MPI_WORLD_COMM,stats,ier) endif else nx=nspp*mspp call MPI_Recv(rii(1:nspp,1:mspp,mpos:mpos), . nx,DC_TYPE,MPI_ANY_SOURCE,mype,MPI_WORLD_COMM,status,ier) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC do i=1,np do j=1,mp r(i,j,k)=rii(i,j,mpos) enddo enddo #else do i=1,np do jj=1,mmp prj(jj,i)=0. do ii=1,nnp prj(jj,i)=prj(jj,i)+ar(ii,jj,k)*cosxi(i,ii,1) enddo enddo enddo do j=1,mp do i=1,np r(i,j,k)=0. do jj=1,mmp r(i,j,k)=r(i,j,k)+prj(jj,i)*cosyi(j,jj,1) enddo enddo enddo #endif ENDDO ENDIF #if (TIMEPLT == 1) call ttend(18) #endif return end CDPR double precision function CDPR 1 det3(r11,r12,r13,r21,r22,r23,r31,r32,r33) CDPR double precision r11,r12,r13,r21,r22,r23,r31,r32,r33 CDPR CDPR det3=r11*r22*r33+r12*r23*r31+r13*r21*r32 CDPR . -r31*r22*r13-r32*r23*r11-r33*r21*r12 CDPR CDPR return CDPR end subroutine tridg(p) include 'param.nml' include 'msg.inc' common/fourierC/ egx(nssp,mssp), 1 egy(nssp,mssp), 1 cosx(nspp,nssp,nprocx), 1 cosy(mspp,mssp,nprocy), 1 sinx(nspp,nssp,nprocx), 1 siny(mspp,mssp,nprocy), 1 cosxi(nspp,nssp,nprocx), 1 cosyi(mspp,mssp,nprocy), 1 sinxi(nspp,nssp,nprocx), 1 sinyi(mspp,mssp,nprocy), 1 gx(nspp),gy(mspp), 1 wx(nssp),wy(mssp), 1 xmsk(nspct),ymsk(mspct), 1 xnm,ynm,c11(lspp),c22(lspp),c33(lspp) common/cnnmm/ nnp,nprocxp,mmp,nprocyp common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc dimension p(nssp, mssp, lssp), . e(nssp, mssp, 0:lssp-1), . f(nssp, mssp, 0:lssp-1), . g(nssp, mssp, 0:lssp-1, 2), . q(nssp, mssp, lssp, 4), . aa(nssp, mssp, 4) Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C dimension p(1-ih:nssp+ih, 1-ih:mssp+ih, lcz), C . e(1-ih:nssp+ih, 1-ih:mssp+ih, 0:lcz-1), C . f(1-ih:nssp+ih, 1-ih:mssp+ih, 0:lcz-1), C . g(1-ih:nssp+ih, 1-ih:mssp+ih, 0:lcz-1, 2), C . q(1-ih:nssp+ih, 1-ih:mssp+ih, lcz, 4), C . aa(1-ih:nssp+ih, 1-ih:mssp+ih, 4) Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc CDPR double precision dn,dgh CDPR double precision deti,det40,det41,det42,det43,det44,det3, CDPR . d11,d21,d31,d41, CDPR . d12,d22,d32,d42, CDPR . d13,d23,d33,d43, CDPR . d14,d24,d34,d44, CDPR . s1 ,s2 ,s3 ,s4 det3(r11,r12,r13,r21,r22,r23,r31,r32,r33)= . r11*r22*r33+r12*r23*r31+r13*r21*r32 . -r31*r22*r13-r32*r23*r11-r33*r21*r12 #if (TIMEPLT == 1) call ttbeg(19) #endif if((nnp.lt.1).or.(mmp.lt.1)) return IF(IBCZ.EQ.0) THEN do j=1,mmp do i=1,nnp e(i,j,0)=1. f(i,j,0)=0. dgh=c11(1)*egx(i,j)+c22(1)*egy(i,j) dn=1./(2.*c33(2)+dgh) e(i,j,1)=2.*c33(2)*dn f(i,j,1)= p(i,j,1)*dn enddo enddo do k=2,l-1 do j=1,mmp do i=1,nnp dgh=c11(k)*egx(i,j)+c22(k)*egy(i,j) dn=1./(c33(k+1)+c33(k-1)*(1.-e(i,j,k-2))+dgh) e(i,j,k)= c33(k+1)*dn f(i,j,k)=(c33(k-1)*f(i,j,k-2)+p(i,j,k))*dn enddo enddo enddo do j=1,mmp do i=1,nnp dgh=c11(l)*egx(i,j)+c22(l)*egy(i,j) dn=2.*(1.-e(i,j,l-2))*c33(l-1)+dgh CDPR if(dabs(dn).gt.1.e-10) then if( abs(dn).gt.1.e-10) then p(i,j,l)=(p(i,j,l)+2.*f(i,j,l-2)*c33(l-1))/dn else p(i,j,l)=0. endif if(abs(1.-e(i,j,l-1)).gt.1.e-10) then p(i,j,l-1)=f(i,j,l-1)/(1.-e(i,j,l-1)) else p(i,j,l-1)=0. endif enddo enddo do k=l-2,1,-1 do j=1,mmp do i=1,nnp p(i,j,k)=e(i,j,k)*p(i,j,k+2)+f(i,j,k) enddo enddo enddo ELSE !periodic tridiagonal solver do j=1,mmp do i=1,nnp e(i,j,0)=0. f(i,j,0)=0. dgh=c11(1)*egx(i,j)+c22(1)*egy(i,j) dn=1./(c33(2)+c33(l-1)+dgh) e(i,j,1)= c33(2)*dn f(i,j,1)= p(i,j,1)*dn g(i,j,0,1)=1. g(i,j,1,1)=0. g(i,j,0,2)=0. g(i,j,1,2)= c33(l-1)*dn enddo enddo do k=2,l-1 do j=1,mmp do i=1,nnp dgh=c11(k)*egx(i,j)+c22(k)*egy(i,j) dn=1./(c33(k+1)+c33(k-1)*(1.-e(i,j,k-2))+dgh) e(i,j,k) = c33(k+1)*dn f(i,j,k) =(c33(k-1)*f(i,j,k-2)+p(i,j,k))*dn g(i,j,k,1)=(c33(k-1)*g(i,j,k-2,1) )*dn g(i,j,k,2)=(c33(k-1)*g(i,j,k-2,2) )*dn enddo enddo enddo do j=1,mmp do i=1,nnp p(i,j, l )=0. p(i,j,l-1 )=f(i,j,l-1) q(i,j, l ,1)=0. q(i,j,l-1,1)=g(i,j,l-1,1) q(i,j, l ,2)=1. q(i,j,l-1,2)=0. q(i,j, l ,3)=0. q(i,j,l-1,3)=g(i,j,l-1,2) q(i,j, l ,4)=0. q(i,j,l-1,4)=e(i,j,l-1) enddo enddo do k=l-2,1,-1 do j=1,mmp do i=1,nnp p(i,j,k )=e(i,j,k)*p(i,j,k+2 )+f(i,j,k) q(i,j,k,1)=e(i,j,k)*q(i,j,k+2,1)+g(i,j,k,1) q(i,j,k,2)=e(i,j,k)*q(i,j,k+2,2) q(i,j,k,3)=e(i,j,k)*q(i,j,k+2,3)+g(i,j,k,2) q(i,j,k,4)=e(i,j,k)*q(i,j,k+2,4) enddo enddo enddo do j=1,mmp do i=1,nnp d11= q(i,j,l-1,1)-1. d12= q(i,j,l-1,2) d13= q(i,j,l-1,3) d14= q(i,j,l-1,4) d21= q(i,j,1,1) d22= q(i,j,1,2)-1. d23= q(i,j,1,3) d24= q(i,j,1,4) d31= q(i,j,l-2,1) d32= q(i,j,l-2,2) d33= q(i,j,l-2,3)-1. d34= q(i,j,l-2,4) d41= q(i,j,2,1) d42= q(i,j,2,2) d43= q(i,j,2,3) d44= q(i,j,2,4)-1. det40=d11*det3(d22,d23,d24,d32,d33,d34,d42,d43,d44) . -d21*det3(d12,d13,d14,d32,d33,d34,d42,d43,d44) . +d31*det3(d12,d13,d14,d22,d23,d24,d42,d43,d44) . -d41*det3(d12,d13,d14,d22,d23,d24,d32,d33,d34) CDPR if(dabs(det40).lt.1.e-10) then if( abs(det40).lt.1.e-10) then aa(i,j,4)=0. aa(i,j,3)=0. aa(i,j,2)=0. aa(i,j,1)=0. else s1 =-p(i,j,l-1) s2 =-p(i,j,1) s3 =-p(i,j,l-2) s4 =-p(i,j,2) deti=1./det40 det41=s1 *det3(d22,d23,d24,d32,d33,d34,d42,d43,d44) . -s2 *det3(d12,d13,d14,d32,d33,d34,d42,d43,d44) . +s3 *det3(d12,d13,d14,d22,d23,d24,d42,d43,d44) . -s4 *det3(d12,d13,d14,d22,d23,d24,d32,d33,d34) det42=d11*det3( s2,d23,d24, s3,d33,d34, s4,d43,d44) . -d21*det3( s1,d13,d14, s3,d33,d34, s4,d43,d44) . +d31*det3( s1,d13,d14, s2,d23,d24, s4,d43,d44) . -d41*det3( s1,d13,d14, s2,d23,d24, s3,d33,d34) det43=d11*det3(d22, s2,d24,d32, s3,d34,d42, s4,d44) . -d21*det3(d12, s1,d14,d32, s3,d34,d42, s4,d44) . +d31*det3(d12, s1,d14,d22, s2,d24,d42, s4,d44) . -d41*det3(d12, s1,d14,d22, s2,d24,d32, s3,d34) det44=d11*det3(d22,d23, s2,d32,d33, s3,d42,d43, s4) . -d21*det3(d12,d13, s1,d32,d33, s3,d42,d43, s4) . +d31*det3(d12,d13, s1,d22,d23, s2,d42,d43, s4) . -d41*det3(d12,d13, s1,d22,d23, s2,d32,d33, s3) aa(i,j,4)=det44*deti aa(i,j,3)=det43*deti aa(i,j,2)=det42*deti aa(i,j,1)=det41*deti endif enddo enddo do k=1,l do j=1,mmp do i=1,nnp p(i,j,k)=p(i,j,k)+aa(i,j,1)*q(i,j,k,1) . +aa(i,j,2)*q(i,j,k,2) . +aa(i,j,3)*q(i,j,k,3) . +aa(i,j,4)*q(i,j,k,4) enddo enddo enddo correct for round-off departures from the cyclicity in the vertical do j=1,mmp do i=1,nnp p(i,j,l)=p(i,j,1) enddo enddo ENDIF #if (TIMEPLT == 1) call ttend(19) #endif return end subroutine spcpri include 'param.nml' include 'msg.inc' common/fourierC/ egx(nssp,mssp), 1 egy(nssp,mssp), 1 cosx(nspp,nssp,nprocx), 1 cosy(mspp,mssp,nprocy), 1 sinx(nspp,nssp,nprocx), 1 siny(mspp,mssp,nprocy), 1 cosxi(nspp,nssp,nprocx), 1 cosyi(mspp,mssp,nprocy), 1 sinxi(nspp,nssp,nprocx), 1 sinyi(mspp,mssp,nprocy), 1 gx(nspp),gy(mspp), 1 wx(nssp),wy(mssp), 1 xmsk(nspct),ymsk(mspct), 1 xnm,ynm,c11(lspp),c22(lspp),c33(lspp) common/cnnmm/ nnp,nprocxp,mmp,nprocyp common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(20) #endif c precompute trygonometric coefficients pi=acos(-1.) pi2=2.*pi pih=pi/2. piho=1./pih pi2o=1./pi2 xnm=1./float(N-1) ynm=1./float(M-1) #if (POLES == 0) nn=(n+1)/2*ibcx+(1-ibcx)*n mm=(m+1)/2*ibcy+(1-ibcy)*m #else nn=(n+1)/2 mm=(m+1)/2 #endif nnp=max(0,min(nssp,nn-(npos-1)*np)) ! local value of nn mmp=max(0,min(mssp,mm-(mpos-1)*mp)) ! local value of mm ism=max(ispcpr,0) ! nprocxp - no of processors covering spectral domian in X ! nprocyp - no of processors covering spectral domian in Y nprocxp=nint(float(nn)/float(np)+.49999999)*ism+(1-ism) nprocyp=nint(float(mm)/float(mp)+.49999999)*ism+(1-ism) do i=1,nspct xmsk(i)=0. enddo do ii=1,nn xmsk(ii)=1. enddo do i=1,nssp ia=(npos-1)*np + i if(xmsk(ia).eq.1.) wx(i)=2. if(xmsk(ia).eq.0.) wx(i)=0. enddo #if (POLES == 0) if(ibcx.eq.1) then if(leftedge.eq.1) wx(1)=1 ! wx(1)=1 if(mod(n,2).eq.1) then do i=1,nssp ia=(npos-1)*np + i if(ia.eq.nn) wx(i)=1. ! wx(nn)=1 enddo endif else if(leftedge.eq.1) wx(1)=1. ! wx(1)=1 do i=1,nssp ia=(npos-1)*np + i if(ia.eq.nn) wx(i)=1. ! wx(nn)=1 enddo endif #endif do j=1,mspct ymsk(j)=0. enddo do jj=1,mm ymsk(jj)=1. enddo do j=1,mssp ja=(mpos-1)*mp + j if(ymsk(ja).eq.(1.)) wy(j)=2. if(ymsk(ja).eq.(0.)) wy(j)=0. enddo #if (POLES == 0) if(ibcy.eq.1) then if(botedge.eq.1) wy(1)=1 ! wy(1)=1 if(mod(m,2).eq.1) then do j=1,mssp ja=(mpos-1)*mp + j if(ja.eq.mm) wy(j)=1. ! wy(mm)=1 enddo endif else if(botedge.eq.1) wy(1)=1 ! wy(1)=1 do j=1,mssp ja=(mpos-1)*mp + j if(ja.eq.mm) wy(j)=1. ! wy(mm)=1 enddo endif #endif IF(IBCX.EQ.1) THEN do is=1,nprocx do ii=1,nssp iia=(is-1)*np+ii do i=1,np gx(i)=1. ia=(npos-1)*np + i cosx(i,ii,is)=cos(pi2*(ia-1)*(iia-1)*xnm)*xmsk(iia)*xnm sinx(i,ii,is)=sin(pi2*(ia-1)*(iia-1)*xnm)*xmsk(iia)*xnm enddo enddo enddo do ii=1,nssp iia=(npos-1)*np+ii do is=1,nprocx do i=1,np ia=(is-1)*np + i cosxi(i,ii,is)=cos(pi2*(ia-1)*(iia-1)*xnm)*xmsk(iia)*wx(ii) sinxi(i,ii,is)=sin(pi2*(ia-1)*(iia-1)*xnm)*xmsk(iia)*wx(ii) enddo enddo enddo ELSE do is=1,nprocx do ii=1,nssp iia=(is-1)*np+ii do i=1,np gx(i)=1. ia=(npos-1)*np + i cosx(i,ii,is)=cos(pi*(ia-1)*(iia-1)*xnm)*xmsk(iia)*xnm enddo enddo enddo do ii=1,nssp iia=(npos-1)*np+ii do is=1,nprocx do i=1,np ia=(is-1)*np + i cosxi(i,ii,is)=cos(pi*(ia-1)*(iia-1)*xnm)*xmsk(iia)*wx(ii) enddo enddo enddo if (leftedge.eq.1) gx( 1)=.5 if (rightedge.eq.1) gx(np)=.5 ENDIF IF(IBCY.EQ.1) THEN do js=1,nprocy do jj=1,mssp jja=(js-1)*mp + jj do j=1,mp gy(j)=1. ja=(mpos-1)*mp + j cosy(j,jj,js)=cos(pi2*(ja-1)*(jja-1)*ynm)*ymsk(jja)*ynm siny(j,jj,js)=sin(pi2*(ja-1)*(jja-1)*ynm)*ymsk(jja)*ynm enddo enddo enddo do jj=1,mssp jja=(mpos-1)*mp + jj do js=1,nprocy do j=1,mp ja=(js-1)*mp + j cosyi(j,jj,js)=cos(pi2*(ja-1)*(jja-1)*ynm)*ymsk(jja)*wy(jj) sinyi(j,jj,js)=sin(pi2*(ja-1)*(jja-1)*ynm)*ymsk(jja)*wy(jj) enddo enddo enddo ELSE do js=1,nprocy do jj=1,mssp jja=(js-1)*mp + jj do j=1,mp gy(j)=1. ja=(mpos-1)*mp + j cosy(j,jj,js)=cos(pi*(ja-1)*(jja-1)*ynm)*ymsk(jja)*ynm enddo enddo enddo do jj=1,mssp jja=(mpos-1)*mp + jj do js=1,nprocy do j=1,mp ja=(js-1)*mp + j cosyi(j,jj,js)=cos(pi*(ja-1)*(jja-1)*ynm)*ymsk(jja)*wy(jj) enddo enddo enddo if (botedge.eq.1) gy( 1)=.5 if (topedge.eq.1) gy(mp)=.5 endif #if (POLES == 0) if(ibcx*ibcy.eq.1) then do jj=1,mssp jja=(mpos-1)*mp + jj do ii=1,nssp iia=(npos-1)*np + ii egx(ii,jj)=( dxi*sin(pi2*(iia-1)*xnm) )**2*xmsk(iia) egy(ii,jj)=( dyi*sin(pi2*(jja-1)*ynm) )**2*ymsk(jja) enddo enddo endif if(ibcx.eq.1.and.ibcy.eq.0) then do jj=1,mssp jja=(mpos-1)*mp + jj do ii=1,nssp iia=(npos-1)*np + ii egx(ii,jj)=( dxi*sin(pi2*(iia-1)*xnm) )**2*xmsk(iia) egy(ii,jj)=( dyi*sin(pi *(jja-1)*ynm) )**2*ymsk(jja) enddo enddo endif if(ibcx.eq.0.and.ibcy.eq.1) then do jj=1,mssp jja=(mpos-1)*mp + jj do ii=1,nssp iia=(npos-1)*np + ii egx(ii,jj)=( dxi*sin(pi *(iia-1)*xnm) )**2*xmsk(iia) egy(ii,jj)=( dyi*sin(pi2*(jja-1)*ynm) )**2*ymsk(jja) enddo enddo endif if(ibcx.eq.0.and.ibcy.eq.0) then do jj=1,mssp jja=(mpos-1)*mp + jj do ii=1,nssp iia=(npos-1)*np + ii egx(ii,jj)=( dxi*sin(pi *(iia-1)*xnm) )**2*xmsk(iia) egy(ii,jj)=( dyi*sin(pi *(jja-1)*ynm) )**2*ymsk(jja) enddo enddo endif #else do jj=1,mssp jja=(mpos-1)*mp + jj do ii=1,nssp iia=(npos-1)*np + ii egx(ii,jj)=( dxi*sin(pi2*(iia-1)*xnm) )**2*xmsk(iia) egy(ii,jj)=( dyi*sin(pi2*(jja-1)*ynm) )**2*ymsk(jja) enddo enddo #endif #if (TIMEPLT == 1) call ttend(20) #endif return end #endif /* PRECF > 0 */ subroutine laplc(p,r,u,v,w,fd,ibf) include 'param.nml' include 'msg.inc' dimension p(1-ih:np+ih, 1-ih:mp+ih, l), ! gcrk ---> x, r . r(1-ih:np+ih, 1-ih:mp+ih, l), ! gcrk ---> ax, ar . u(1-ih:np+ih, 1-ih:mp+ih, l), ! gcrk ---> pfx . v(1-ih:np+ih, 1-ih:mp+ih, l), ! gcrk ---> pfy . w(1-ih:np+ih, 1-ih:mp+ih, l), ! gcrk ---> pfz . fd(1-ih:np+ih, 1-ih:mp+ih, l) ! <--- common slt: fz common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/slip/ noslip !mod bbc common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/slipb/ noslipb common/indx/ e1,e2,e3 common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> r --> rhs . scr1(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> qr --> p . scr2(1-ih:np+ih,1-ih:mp+ih,l), ! gcrk --> ar --> r . a11(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a11 . a12(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a12 . a13(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a13 . a21(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a21 . a22(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a22 . a23(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a23 . a31(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a31 . a32(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a32 . a33(1-ih:np+ih,1-ih:mp+ih,l), ! coef0 --> a33 . scr3(1-ih:np+ih,1-ih:mp+ih,l), ! not used . px(1-ih:np+ih,1-ih:mp+ih,l), ! local array . py(1-ih:np+ih,1-ih:mp+ih,l), ! local array . pz(1-ih:np+ih,1-ih:mp+ih,l) ! local array dimension pe(1-ih:np+ih+1,1-ih:mp+ih+1,l+1) ! local array #if (TIMEPLT == 1) call ttbeg(21) #endif c do 77 k=1,l c do 77 j=1,mp c do 77 i=1,np c ia=(npos-1)*np + i c ja=(mpos-1)*mp + j c 77 p(i,j,k)=1.e-8*float(ia*ja*k*k)/float(n*m*l) call update2(p,np,mp,l,np,mp,iup) if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi compute pressure derivatives everywhere #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge #else illim = 1 iulim = np #endif do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim 1 px(i,j,k)= dxil*(p(i+1,j,k)-p(i-1,j,k)) #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp px(1,j,k)=(1-ibcx)*dxi*(p(2,j,k)-p( 1,j,k)) 1 +ibcx*dxil*(p(2,j,k)-p(-1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp px(np,j,k)=(1-ibcx)*dxi*(p(np ,j,k)-p(np-1,j,k)) 1 +ibcx*dxil*(p(np+2,j,k)-p(np-1,j,k)) end do end do end if #endif if(j3.eq.1) then #if (POLES == 0) jllim = 1 + j3*botedge julim = mp - j3*topedge #else jllim = 1 julim = mp #endif do 2 k=1,l do 2 j=jllim,julim do 2 i=1,np 2 py(i,j,k)= dyil*(p(i,j+j3,k)-p(i,j-j3,k)) #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np py(i,1,k)=(1-ibcy)*dyi*(p(i,1+j3,k)-p(i, 1,k)) 1 +ibcy*dyil*(p(i,1+j3,k)-p(i,-1,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np py(i,mp,k)=(1-ibcy)*dyi*(p(i,mp ,k)-p(i,mp-j3,k)) 1 +ibcy*dyil*(p(i,mp+2,k)-p(i,mp-j3,k)) end do end do end if #endif else do 29 k=1,l do 29 j=1,mp do 29 i=1,np 29 py(i,j,k)=0. endif do 3 k=2,l-1 do 3 j=1,mp do 3 i=1,np 3 pz(i,j,k)=dzil*(p(i,j,k+1)-p(i,j,k-1)) if(ibcz.eq.0) then do j=1,mp do i=1,np pz(i,j,1)= dzi*(p(i,j,2)-p(i,j,1)) pz(i,j,l)= dzi*(p(i,j,l)-p(i,j,l-1)) end do end do else do j=1,mp do i=1,np pz(i,j,1)= dzil*(p(i,j,2)-p(i,j,l-1)) pz(i,j,l)= dzil*(p(i,j,2)-p(i,j,l-1)) end do end do endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi illim = 1 + leftedge jllim = 1 + j3*botedge iulim = np + rightedge julim = mp + j3*topedge construct extended, auxiliary pressure field with either cyclic or extrapolated boundaries do 4 k=2,l do 4 j=jllim,mp do 4 i=illim,np 4 pe(i,j,k)=p(i,j,k) do 41 j=jllim,mp do 41 i=illim,np plex=2.*(e1*pe(i,j,2)+e2*pe(i,j,3 )+e3*pe(i,j,4 ))-pe(i,j,2) prex=2.*(e1*pe(i,j,l)+e2*pe(i,j,l-1)+e3*pe(i,j,l-2))-pe(i,j,l) pe(i,j,1) =(1-ibcz)*plex+ibcz*pe(i,j,l) 41 pe(i,j,l+1)=(1-ibcz)*prex+ibcz*pe(i,j,2) #if (PARALLEL == 0) do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3 ,j,k)+e3*pe(4 ,j,k))-pe(2,j,k) prex=2.*(e1*pe(n,j,k)+e2*pe(n-1,j,k)+e3*pe(n-2,j,k))-pe(n,j,k) pe(1 ,j,k)=(1-ibcx)*plex+ibcx*pe(n,j,k) pe(n+1,j,k)=(1-ibcx)*prex+ibcx*pe(2,j,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(pe,np ,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(pe,np+1,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(pe,np ,mp+1,l+1,np+1,mp+1,iupx) else call updatelr(pe,np+1,mp+1,l+1,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do k=1,l+1 do j=jllim,mp plex=2.*(e1*pe(2,j,k)+e2*pe(3,j,k)+e3*pe(4,j,k))-pe(2,j,k) pe(1,j,k) =(1-ibcx)*plex+ibcx*pe(-1,j,k) enddo enddo endif if (rightedge.eq.1) then do k=1,l+1 do j=jllim,mp prex=2.*(e1*pe(np,j,k)+e2*pe(np-1,j,k)+e3*pe(np-2,j,k))-pe(np,j,k) pe(np+1,j,k)=(1-ibcx)*prex+ibcx*pe(np+3,j,k) enddo enddo endif #endif if(j3.eq.1) then #if (PARALLEL == 0) do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) prex=2.*(e1*pe(i,m ,k)+e2*pe(i,m-j3 ,k) . +e3*pe(i,m-2*j3,k)) -pe(i,m ,k) pe(i,1,k) =(1-ibcy)*plex+ibcy*pe(i,m ,k) pe(i,m+1,k)=(1-ibcy)*prex+ibcy*pe(i,1+j3,k) enddo enddo #else if (rightedge.eq.0 .and. topedge.eq.0) then call updatebt(pe,np ,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(pe,np+1,mp ,l+1,np+1,mp+1,iupy) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(pe,np ,mp+1,l+1,np+1,mp+1,iupy) else call updatebt(pe,np+1,mp+1,l+1,np+1,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l+1 do i=1,iulim plex=2.*(e1*pe(i,1+j3 ,k)+e2*pe(i,1+2*j3,k) . +e3*pe(i,1+3*j3,k)) -pe(i,1+j3 ,k) pe(i,1,k)=(1-ibcy)*plex+ibcy*pe(i,-1,k) enddo enddo end if if (topedge.eq.1) then do k=1,l+1 do i=1,iulim prex=2.*(e1*pe(i,mp ,k)+e2*pe(i,mp-j3 ,k) . +e3*pe(i,mp-2*j3,k)) -pe(i,mp ,k) pe(i,mp+1,k)=(1-ibcy)*prex+ibcy*pe(i,mp+3,k) enddo enddo endif #endif endif #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call update(pe,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(pe,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(pe,np ,mp+1,l+1,np+1,mp+1,1) else call update(pe,np+1,mp+1,l+1,np+1,mp+1,1) end if #endif compute pressure derivatives everywhere if(j3.eq.1) then do 5 k=1,l do 5 j=1,mp do 5 i=1,np px(i,j,k)=dxil* . ( pe(i+1,j+j3,k+1)-pe(i,j+j3,k+1)+pe(i+1,j,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i,j+j3,k )+pe(i+1,j,k )-pe(i,j,k ) ) py(i,j,k)=dyil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j,k+1)+pe(i,j+j3,k+1)-pe(i,j,k+1) . +pe(i+1,j+j3,k )-pe(i+1,j,k )+pe(i,j+j3,k )-pe(i,j,k ) ) pz(i,j,k)=dzil* . ( pe(i+1,j+j3,k+1)-pe(i+1,j+j3,k)+pe(i,j+j3,k+1)-pe(i,j+j3,k) . +pe(i+1,j ,k+1)-pe(i+1,j ,k)+pe(i,j ,k+1)-pe(i,j ,k) ) 5 continue else dxi2=2.*dxil dzi2=2.*dzil do 51 k=1,l do 51 i=1,np px(i,1,k)=dxi2*(pe(i+1,1,k+1)-pe(i,1,k+1)+pe(i+1,1,k)-pe(i,1,k)) 51 pz(i,1,k)=dzi2*(pe(i+1,1,k+1)-pe(i+1,1,k)+pe(i,1,k+1)-pe(i,1,k)) do 52 k=1,l do 52 j=1,mp do 52 i=1,np 52 py(i,j,k)=0. endif #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif compute interior pressure forces do 10 k=2-ibcz,l-1+ibcz do 10 j=1,mp do 10 i=1,np c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) u(i,j,k)=-(c11*px(i,j,k)+c12*py(i,j,k)+c13*pz(i,j,k)) v(i,j,k)=-(c21*px(i,j,k)+c22*py(i,j,k)+c23*pz(i,j,k)) w(i,j,k)=-(c31*px(i,j,k)+c32*py(i,j,k)+c33*pz(i,j,k)) 10 continue compute pressure forces at the boundaries #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then illim=1 else illim=np end if if (rightedge.eq.1) then iulim=np else iulim=1 end if jllim = 1 + (j3-ibcy)*botedge julim = mp + (-j3+ibcy)*topedge do 11 i=illim,iulim,np-1 cdel ii=1+i/np do 111 j=jllim,julim do 111 k=2-ibcz,l-1+ibcz c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) u(i,j,k)=0. pxb=-(c12*py(i,j,k)+c13*pz(i,j,k))/c11 v(i,j,k)=-(c21*pxb+c22*py(i,j,k)+c23*pz(i,j,k)) 111 w(i,j,k)=-(c31*pxb+c32*py(i,j,k)+c33*pz(i,j,k))*icw 11 continue if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if do 112 i=illim,iulim,np-1 cdel ii=1+i/np do 112 j=jllim,julim,mp-j3 cdel jj=1+j/mp do 1121 k=2-ibcz,l-1+ibcz c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) u(i,j,k)=0. v(i,j,k)=0. a=-c13*pz(i,j,k) b=-c23*pz(i,j,k) pxb=(c22*a-c12*b)/(c11*c22-c12*c21) pyb=(c11*b-c21*a)/(c11*c22-c12*c21) 1121 w(i,j,k)=-(c31*pxb+c32*pyb+c33*pz(i,j,k)) 112 continue endif ! ibcy.eq.0.and.j3.eq.1 endif ! ibcx.eq.0 if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge do 12 j=jllim,julim,mp-j3 cdel jj=1+j/mp do 121 k=2-ibcz,l-1+ibcz do 121 i=illim,iulim c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) v(i,j,k)= 0. pyb=-(c21*px(i,j,k)+c23*pz(i,j,k))/c22 u(i,j,k)=-(c11*px(i,j,k)+c12*pyb+c13*pz(i,j,k)) 121 w(i,j,k)=-(c31*px(i,j,k)+c32*pyb+c33*pz(i,j,k))*icw 12 continue endif #endif if(ibcz.eq.0) then #if (POLES == 0) jllim = 1 + (j3-ibcy)*botedge julim = mp + (-j3+ibcy)*topedge illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge #else jllim = 1 julim = mp illim = 1 iulim = np #endif do 20 k=1,l,l-1 cdel kk=1+k/l do 21 j=jllim,julim do 21 i=illim,iulim c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) w(i,j,k)=0. pzb=-(c31*px(i,j,k)+c32*py(i,j,k))/c33 u(i,j,k)=-(c11*px(i,j,k)+c12*py(i,j,k)+c13*pzb) v(i,j,k)=-(c21*px(i,j,k)+c22*py(i,j,k)+c23*pzb) 21 continue 20 continue #if (POLES == 0) if(ibcx.eq.0) then if (leftedge.eq.1) then illim=1 else illim=np end if if (rightedge.eq.1) then iulim=np else iulim=1 end if do 211 k=1,l,l-1 cdel kk=1+k/l do 211 i=illim,iulim,np-1 cdel ii=1+i/np do 2111 j=jllim,julim c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) w(i,j,k)=0. u(i,j,k)=0. pzb=-(c11*c32-c31*c12)*py(i,j,k)/(c11*c33-c31*c13) pxb=-(c12*py(i,j,k)+c13*pzb)/c11 2111 v(i,j,k)=-(c21*pxb+c22*py(i,j,k)+c23*pzb) 211 continue if(ibcy.eq.0.and.j3.eq.1) then if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if do 212 k=1,l,l-1 do 212 i=illim,iulim,np-1 do 212 j=jllim,julim,mp-j3 cdel jj=1+j/mp w(i,j,k)=0. u(i,j,k)=0. 212 v(i,j,k)=0. endif ! ibcy.eq.0.and.j3.eq.1 endif ! ibcx.eq.0 if(ibcy.eq.0.and.j3.eq.1) then illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge if (botedge.eq.1) then jllim=1 else jllim=mp end if if (topedge.eq.1) then julim=mp else julim=1 end if do 221 k=1,l,l-1 cdel kk=1+k/l do 221 j=jllim,julim,mp-j3 cdel jj=1+j/mp do 221 i=illim,iulim c11=a11(i,j,k) c12=a12(i,j,k) c13=a13(i,j,k) c21=a21(i,j,k) c22=a22(i,j,k) c23=a23(i,j,k) c31=a31(i,j,k) c32=a32(i,j,k) c33=a33(i,j,k) w(i,j,k)=0. v(i,j,k)=0. pzb=-(c31*c22-c32*c21)*px(i,j,k)/(c33*c22-c32*c23) pyb=-(c21*px(i,j,k)+c23*pzb)/c22 221 u(i,j,k)=-(c11*px(i,j,k)+c12*pyb+c13*pzb) endif ! ibcy.eq.0.and.j3.eq.1 #endif endif ! ibcz.eq.0 do 99 k=1,l do 99 j=1,mp do 99 i=1,np cf00=d(i,j,k)*fd(i,j,k) u(i,j,k)=cf00*u(i,j,k) v(i,j,k)=cf00*v(i,j,k) 99 w(i,j,k)=cf00*w(i,j,k) if(noslip.eq.1) then #if (POLES == 0) customized for QBO lab experiment, noslip y boundaries, and zbar=0 as an option if(leftedge.eq.1) then do k=1,l do j=1,mp c u(1,j,k)=0. v(1,j,k)=0. w(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp c u(np,j,k)=0. v(np,j,k)=0. w(np,j,k)=0. enddo enddo endif #endif c---> noslip lower boundary do j=1,mp do i=1,np u(i,j,1)=0. v(i,j,1)=0. c u(i,j,l)=0. c v(i,j,l)=0. enddo enddo endif !mod bbc ! if(ibf.eq.2.and.noslipb.eq.1) then if(ibf.eq.2) then c---> noslipb boundary (vertical magnetic field) if (ibbl .eq. 1) then u(i,j,1)=0. v(i,j,1)=0. endif if (ibbu .eq. 1) then u(i,j,l)=0. v(i,j,l)=0. endif ! if (noslipb.eq.1) then ! do j=1,mp ! do i=1,np ! u(i,j,1)=0. ! v(i,j,1)=0. ! u(i,j,l)=0. ! v(i,j,l)=0. ! enddo ! enddo ! endif ! if (noslipb.eq.2) then ! do j=1,mp ! do i=1,np ! u(i,j,l)=0. ! v(i,j,l)=0. ! enddo ! enddo ! endif endif if (istab.eq.1.and.isphere.eq.0) then iencyc=1 else iencyc=0 endif if(iencyc.eq.1) then c enforce cyclicity !mod if(ibcx.eq.1) then call updatelr(u,np,mp,l,np,mp,1) call updatelr(v,np,mp,l,np,mp,1) call updatelr(w,np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,L do j=1,mp u(np,j,k)=u(np+1,j,k) v(np,j,k)=v(np+1,j,k) w(np,j,k)=w(np+1,j,k) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(u,np,mp,l,np,mp,1) call updatebt(v,np,mp,l,np,mp,1) call updatebt(w,np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,l do i=1,np u(i,mp,k)=u(i,mp+j3,k) v(i,mp,k)=v(i,mp+j3,k) w(i,mp,k)=w(i,mp+j3,k) enddo enddo endif endif endif !iencyc compute laplacian if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call updatelr(u,np,mp,l,np,mp,iupx) call updatebt(v,np,mp,l,np,mp,iupy) #if (POLES == 0) if (leftedge.eq.0 .and. rightedge.eq.0) then do k=1,l do j=1,mp do i=1,np r(i,j,k)=dxil*(u(i+1,j,k)-u(i-1,j,k)) end do end do end do else if (leftedge.eq.1 .and. rightedge.eq.0) then do k=1,l do j=1,mp do i=2,np r(i,j,k)=dxil*(u(i+1,j,k)-u(i-1,j,k)) end do r(1,j,k)=(1-ibcx)*dxi*(u(2,j,k)-u( 1,j,k)) 2 +ibcx*dxil*(u(2,j,k)-u(-1,j,k)) end do end do else if (rightedge.eq.1 .and. leftedge.eq.0) then do k=1,l do j=1,mp do i=1,np-1 r(i,j,k)=dxil*(u(i+1,j,k)-u(i-1,j,k)) end do r(np,j,k)=(1-ibcx)*dxi*(u(np ,j,k)-u(np-1,j,k)) 2 +ibcx*dxil*(u(np+2,j,k)-u(np-1,j,k)) end do end do else if (rightedge.eq.1 .and. leftedge.eq.1) then do k=1,l do j=1,mp do i=2,np-1 r(i,j,k)=dxil*(u(i+1,j,k)-u(i-1,j,k)) end do r(1 ,j,k)=(1-ibcx)*dxi*(u(2 ,j,k)-u( 1,j,k)) 2 +ibcx*dxil*(u(2 ,j,k)-u( -1,j,k)) r(np,j,k)=(1-ibcx)*dxi*(u(np ,j,k)-u(np-1,j,k)) 2 +ibcx*dxil*(u(np+2,j,k)-u(np-1,j,k)) end do end do end if #else do k=1,l do j=1,mp do i=1,np r(i,j,k)=dxil*(u(i+1,j,k)-u(i-1,j,k)) end do end do end do #endif if(j3.eq.1) then #if (POLES == 0) if (topedge.eq.0 .and. botedge.eq.0) then do k=1,l do j=1,mp do i=1,np r(i,j,k)=r(i,j,k)+dyil*(v(i,j+j3,k)- . v(i,j-j3,k)) end do end do end do else if (botedge.eq.1 .and. topedge.eq.0) then do k=1,l do i=1,np do j=2,mp r(i,j,k)=r(i,j,k)+dyil*(v(i,j+j3,k)- . v(i,j-j3,k)) end do r(i,1,k)=r(i,1,k)+(1-ibcy)*dyi*(v(i,1+j3,k)- . v(i,1,k)) 2 +ibcy*dyil*(v(i,1+j3,k)-v(i,-1,k)) end do end do else if (topedge.eq.1 .and. botedge.eq.0) then do k=1,l do i=1,np do j=1,mp-j3 r(i,j,k)=r(i,j,k)+dyil*(v(i,j+j3,k)- . v(i,j-j3,k)) end do r(i,mp,k)=r(i,mp,k)+(1-ibcy)*dyi* . (v(i,mp,k)-v(i,mp-j3,k)) 2 +ibcy*dyil*(v(i,mp+2,k)-v(i,mp-j3,k)) end do end do else if (topedge.eq.1 .and. botedge.eq.1) then do k=1,l do i=1,np do j=2,mp-j3 r(i,j,k)=r(i,j,k)+dyil*(v(i,j+j3,k)- . v(i,j-j3,k)) end do r(i,1,k)=r(i,1,k)+(1-ibcy)*dyi*(v(i,1+j3,k)- . v(i,1,k)) 2 +ibcy*dyil*(v(i,1+j3,k)-v(i,-1,k)) r(i,mp,k)=r(i,mp,k)+(1-ibcy)*dyi* . (v(i,mp,k)-v(i,mp-j3,k)) 2 +ibcy*dyil*(v(i,mp+2,k)-v(i,mp-j3,k)) end do end do end if #else jllim2 = 1 + j3*botedge julim2 = mp - j3*topedge do k=1,l do j=jllim2,julim2 do i=1,np r(i,j,k)=r(i,j,k)+dyil*(v(i,j+j3,k)-v(i,j-j3,k)) end do end do end do if (botedge.eq.1) then do k=1,l do i=1,np ! r(i,1,k)=r(i,1,k)+dyil*(v(i,1+j3,k)+v(i,1-j3,k)) r(i,1,k)=r(i,1,k)+dyil*(v(i,1+j3,k)+v(i,1 ,k)) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np ! r(i,mp,k)=r(i,mp,k)-dyil*(v(i,mp+j3,k)+v(i,mp-j3,k)) r(i,mp,k)=r(i,mp,k)-dyil*(v(i,mp ,k)+v(i,mp-j3,k)) end do end do end if #endif endif do 93 k=2,l-1 do 93 j=1,mp do 93 i=1,np 93 r(i,j,k)=r(i,j,k)+dzil*(w(i,j,k+1)-w(i,j,k-1)) if(ibcz.eq.0) then do 931 j=1,mp do 931 i=1,np r(i,j,1)=r(i,j,1)+dzi*(w(i,j,2)-w(i,j,1)) r(i,j,l)=r(i,j,l)+dzi*(w(i,j,l)-w(i,j,l-1)) 931 continue else do 932 j=1,mp do 932 i=1,np r(i,j,1)=r(i,j,1)+dzil*(w(i,j,2)-w(i,j,l-1)) r(i,j,l)=r(i,j,l)+dzil*(w(i,j,2)-w(i,j,l-1)) 932 continue endif do 94 k=1,l do 94 j=1,mp do 94 i=1,np 94 r(i,j,k)=-r(i,j,k)/d(i,j,k) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) call update(u,np,mp,l,np,mp,1) call update(v,np,mp,l,np,mp,1) call update(w,np,mp,l,np,mp,1) illim = 1 + leftedge if(j3.eq.1) then jllim = 1 + j3*botedge do 95 k=2,l do 95 j=jllim,mp do 95 i=illim,np r(i,j,k)=dxil* 1 ( u(i,j,k )-u(i-1,j,k )+u(i,j-j3,k )-u(i-1,j-j3,k ) 1 +u(i,j,k-1)-u(i-1,j,k-1)+u(i,j-j3,k-1)-u(i-1,j-j3,k-1) ) 2 +dyil* 2 ( v(i,j,k )-v(i,j-j3,k )+v(i-1,j,k )-v(i-1,j-j3,k ) 2 +v(i,j,k-1)-v(i,j-j3,k-1)+v(i-1,j,k-1)-v(i-1,j-j3,k-1) ) 3 +dzil* 3 ( w(i,j ,k)-w(i,j ,k-1)+w(i-1,j ,k)-w(i-1,j ,k-1) 3 +w(i,j-j3,k)-w(i,j-j3,k-1)+w(i-1,j-j3,k)-w(i-1,j-j3,k-1) ) rhoav=.125*( d(i,j,k-1)+d(i-1,j,k-1)+d(i-1,j-j3,k-1)+d(i,j-j3,k-1) 1 +d(i,j,k) +d(i-1,j,k) +d(i-1,j-j3,k) +d(i,j-j3,k) ) 95 r(i,j,k)=-r(i,j,k)/rhoav else do 96 k=2,l do 96 i=illim,np r(i,1,k)=dxi2*( u(i,1,k)-u(i-1,1,k)+u(i,1,k-1)-u(i-1,1,k-1)) 3 +dzi2*( w(i,1,k)-w(i,1,k-1)+w(i-1,1,k)-w(i-1,1,k-1)) rhoav=.25*( d(i,1,k-1)+d(i-1,1,k-1)+d(i,1,k)+d(i-1,1,k)) 96 r(i,1,k)=-r(i,1,k)/rhoav endif #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif #if (TIMEPLT == 1) call ttend(21) #endif return end #endif /* ANALIZE == 0 */ subroutine filtprf(a,n3,ifl1,ifl2) dimension a(n3) include 'param.nml' include 'msg.inc' dimension sz(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(66) #endif if (ifl1.eq.1) then do k=2,l-1 sz(k)=0.25*(a(k+1)+2.*a(k)+a(k-1)) end do sz(1)=a(1) sz(l)=a(l) do k=1,l a(k)=sz(k) end do end if if (ifl2.eq.1) then do k=3,l-2 sz(k)=0.25*(a(k+2)+2.*a(k)+a(k-2)) end do sz(1)=a(1) sz(2)=a(2) sz(l)=a(l) sz(l-1)=a(l-1) do k=1,l a(k)=sz(k) end do end if #if (TIMEPLT == 1) call ttend(66) #endif return end subroutine noise(f1,f2,f3,iflg) include 'param.nml' include 'msg.inc' dimension f1(1-ih:np+ih, 1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l) dimension f1temp(np, mp, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common /hstst/ theq(1-ih:np+ih,1-ih:mp+ih,l), . dfhs(1-ih:np+ih,1-ih:mp+ih,l), . hskf,hska,hsks, . qveq(1-ih:nmsp+ih,1-ih:mmsp+ih,lms) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #include "msg.lnk" c randomf1(x,kk)=(x) c randomf2(x,kk)=(x-0.5) c randomf3(x,kk)=(x-0.5)*amax1(0.,1.-(kk-1)*dz/500.) #if (TIMEPLT == 1) call ttbeg(67) #endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c inodes=1 ! different seeding on different processor inodes=1 ! noise equivalent to single processor run CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C Numerical Recipes in Fortran - Quick and Dirty Generators p.274-275 C im ia ic overflow C 86436 1093 18254 2^27 C 117128 1277 24749 2^28 C 145800 3661 30809 2^29 C 139968 3877 29573 2^30 C 134456 8121 28411 2^31 C 233280 9301 49297 2^32 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c im=117128 c ia=1277 c ic=24749 im=86436 ia=1093 ic=18254 iran=mype+1 ! mype is a processor geometry parameter #if (PARALLEL == 0) #if (POLES == 0) do k=1,l-ibcz do j=1,mp-ibcy do i=1,np-ibcz #else do k=1,l do j=1,mp do i=1,np #endif iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f1(i,j,k)=(randx-0.5) iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f2(i,j,k)=randx iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f3(i,j,k)=randx enddo enddo enddo #else if (inodes.eq.1) then ! different seeding on multiprocessor run iran=mype+1 ! different iran on each processor #if (POLES == 0) iulim=np-ibcx*rightedge julim=mp-ibcy*topedge #else iulim=np julim=mp #endif kulim= l-ibcz do k=1,kulim do j=1,julim do i=1,iulim iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f1(i,j,k)=(randx-0.5) C *dfhs(i,j,k)*cosa(i,j)**2 iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f2(i,j,k)=randx iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f3(i,j,k)=randx enddo enddo enddo else ! noise equivalent to single processor run iran = 1 ! iran equivalent to single processor seeding do k=1,l-ibcz #if (POLES == 0) do jam=1,m-ibcy ! total domain position in y do ian=1,n-ibcx ! total domain position in x #else do jam=1,m do ian=1,n #endif i=ian-(npos-1)*np ! local processor position in x j=jam-(mpos-1)*mp ! local processor position in y iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) if((i.ge.1).and.(i.le.np).and.(j.ge.1).and.(j.le.mp)) c . f1(i,j,k)=(randx-0.5) c . *dfhs(i,j,k)*cosa(i,j)**2 . f1(i,j,k)=(randx-0.5) !mod 20111129 c . f1(i,j,k)=(randx-0.5)*cosa(i,j)**4 iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) if((i.ge.1).and.(i.le.np).and.(j.ge.1).and.(j.le.mp)) . f2(i,j,k)=randx iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) if((i.ge.1).and.(i.le.np).and.(j.ge.1).and.(j.le.mp)) . f3(i,j,k)=randx enddo end do end do endif #endif if(ibcz.eq.1) then do j=1,mp do i=1,np f1(i,j,l)=f1(i,j,1) f2(i,j,l)=f2(i,j,1) f3(i,j,l)=f3(i,j,1) enddo end do endif isym=0 if (isym.eq.1) then c impose symmetric noise w.r.t. equator nmlp = np*mp*l iprocsym = (nprocy - mpos)*nprocx + npos - 1 nprocyh = nprocy/2 if (mpos.gt.nprocyh) then do k=1,l do j=1,mp do i=1,np f1temp(i,j,k)=f1(i,j,k) enddo enddo enddo call MPI_Send(f1temp,nmlp,DC_TYPE,iprocsym,99, & MPI_COMM_EULAG,ierr) else call MPI_Recv(f1temp,nmlp,DC_TYPE,iprocsym,99, & MPI_COMM_EULAG,status,ierr) do k=1,l do j=1,mp do i=1,np if (iflg.eq.0) then f1(i,j,k)=f1temp(i,mp-j+1,k) else c impose antisymmetric noise w.r.t. equator for b f1(i,j,k)=-f1temp(i,mp-j+1,k) endif enddo enddo enddo endif call mybarrier() endif !isym #if (POLES == 0) if(ibcx.eq.1) then call updatelr(f1,np,mp,l,np,mp,1) call updatelr(f2,np,mp,l,np,mp,1) call updatelr(f3,np,mp,l,np,mp,1) if (rightedge.eq.1) then do k=1,l do j=1,mp f1(np,j,k)=f1(np+1,j,k) f2(np,j,k)=f2(np+1,j,k) f3(np,j,k)=f3(np+1,j,k) enddo enddo end if end if if(ibcy.eq.1) then call updatebt(f1,np,mp,l,np,mp,1) call updatebt(f2,np,mp,l,np,mp,1) call updatebt(f3,np,mp,l,np,mp,1) if (topedge.eq.1) then do k=1,l do i=1,np f1(i,mp,k)=f1(i,mp+1,k) f2(i,mp,k)=f2(i,mp+1,k) f3(i,mp,k)=f3(i,mp+1,k) enddo end do end if end if #else call update2(f1,np,mp,l,np,mp,1) call update2(f2,np,mp,l,np,mp,1) call update2(f3,np,mp,l,np,mp,1) #endif #if (TIMEPLT == 1) call ttend(67) #endif return end subroutine nois2(f1,f2,iseed) include 'param.nml' include 'msg.inc' dimension f1(1-ih:np+ih, 1-ih:mp+ih), . f2(1-ih:np+ih, 1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc c randomf1(x,kk)=(x) c randomf2(x,kk)=(x-0.5) c randomf3(x,kk)=(x-0.5)*amax1(0.,1.-(kk-1)*dz/500.) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC inodes=1 ! different seeding on different processor c inodes=0 ! noise equivalent to single processor run CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C Numerical Recipes in Fortran - Quick and Dirty Generators p.274-275 C im ia ic overflow C 86436 1093 18254 2^27 C 117128 1277 24749 2^28 C 145800 3661 30809 2^29 C 139968 3877 29573 2^30 C 134456 8121 28411 2^31 C 233280 9301 49297 2^32 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC im=86436 ia=1093*iseed ic=18254 iran=mype+1 ! mype is a processor geometry parameter #if (PARALLEL == 0) #if (POLES == 0) do j=1,mp-ibcy do i=1,np-ibcx #else do j=1,mp do i=1,np #endif iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f1(i,j)=(randx-0.5) enddo enddo #else if (inodes.eq.1) then ! different seeding on multiprocessor run iran=mype+1 ! different iran on each processor #if (POLES == 0) iulim=np-ibcx*rightedge julim=mp-ibcy*topedge #else iulim=np julim=mp #endif do j=1,julim do i=1,iulim iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) f1(i,j)=(randx-0.5) enddo enddo else ! noise equivalent to single processor run iran = 1 ! iran equivalent to single processor seeding #if (POLES == 0) do jam=1,m-ibcy ! total domain position in y do ian=1,n-ibcx ! total domain position in x #else do jam=1,m do ian=1,n #endif i=ian-(npos-1)*np ! local processor position in x j=jam-(mpos-1)*mp ! local processor position in y iran=mod(iran*ia+ic,im) randx=float(iran)/float(im) if((i.ge.1).and.(i.le.np).and.(j.ge.1).and.(j.le.mp)) . f1(i,j)=(randx-0.5) enddo end do endif #endif iflt=1 if(iflt.eq.1) then customize: filter noise call updatelr(f1,np,mp,1,np,mp,iupx) #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge ibox=1-ibcx iboy=1-ibcy #else illim = 1 iulim = np #endif do j=1,mp do i=illim,iulim f2(i,j)=0.25*(f1(i+1,j)+2.*f1(i,j)+f1(i-1,j)) enddo #if (POLES == 0) if (leftedge.eq.1) then f2(1,j)=ibcx*0.25*(f1(2,j)+2.*f1(1,j)+f1(-1,j))+ibox*f1(1,j) end if if (rightedge.eq.1) then temp=0.25*(f1(np+2,j)+2.*f1(np+1,j)+f1(np-1,j)) f2(np,j)=ibcx*temp+ibox*f1(np,j) end if #endif do i=1,np f1(i,j)=f2(i,j) f2(i,j)=0. enddo enddo endif #if (POLES == 0) if(ibcx.eq.1) then call updatelr(f1,np,mp,1,np,mp,1) if (rightedge.eq.1) then do j=1,mp f1(np,j)=f1(np+1,j) enddo end if end if if(ibcy.eq.1) then call updatebt(f1,np,mp,1,np,mp,iupy) if (topedge.eq.1) then do i=1,np f1(i,mp)=f1(i,mp+1) enddo end if end if #endif call update(f1,np,mp,1,np,mp,1) if(iflt.eq.1) call filstr2(f1) return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c stress code c C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine rical(u,v,w,th,qv,qc,ismoth) C-grid Richardson number include 'param.nml' include 'msg.inc' dimension th(1-ih:np+ih, 1-ih:mp+ih, l), . u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . stab(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . d33(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 12) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . stab(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . d33(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 5) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common /stress2/ d11(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . d12(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . d22(1-ih:np+ih, 1-ih:mp+ih+1, l), * d23(1-ih:np+ih, 1-ih:mp+ih+1, l+1), . d13(1-ih:np+ih+1, 1-ih:mp+ih, l+1), * dv(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/stresd/ diagstr(8),ivis,irid,itstr common/cmoist/ rv,t00,ee0,hlat common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm cdel real qwk,qwkm1 real dqv,qva,dThd,N2unsat,ee,Tk,Tkm1,Ta,dqw, 1 rgam,c1,c2,c3,N2sat c #if (TIMEPLT == 1) call ttbeg(49) #endif compute some local constants hdxi=0.5*dxi hdyi=0.5*dyi hdzi=0.5*dzi if(j3.eq.1) dii=3. if(j3.eq.0) dii=2. c initialize output variables call update(u,np,mp,l,np,mp,iup) call update(v,np,mp,l,np,mp,iup) call update(w,np,mp,l,np,mp,iup) DO K=1,L do j=1,mp do i=1,np th(i,j,k)=th(i,j,k)+the(i,j,k) ri(i,j,k)=0. stab(i,j,k)=0. defsq(i,j,k)=0. d33(i,j,k)=0. end do end do do j=1,mp+1 do i=1,np+1 d11(i,j,k)=0. d12(i,j,k)=0. enddo cdel enddo cdel do j=1,mp+1 do i=1,np d22(i,j,k)=0. enddo enddo ENDDO cdel nm1L1 = n*(m+1)*(L+1) DO K=1,L+1 do j=1,mp+1 do i=1,np d23(i,j,k)=0. enddo enddo do j=1,mp do i=1,np+1 d13(i,j,k)=0. enddo enddo ENDDO c surface fluxes --------> do j=1,mp do i=1,np hx=-s13(i,j)/gi(i,j)*zb hy=-s23(i,j)/gi(i,j)*zb vtng=sqrt( (u(i,j,1)+hx*w(i,j,1))**2/(1.+hx**2) . +(v(i,j,1)+hy*w(i,j,1))**2/(1.+hy**2) ) tauw(i,j)=cdrg*vtng*rho(i,j,1) enddo enddo compute velocity z-derivatives. note du/dz is in d13, dv/dz is in d23 do k=2,l do j=1,mp do i=1,np d13(i,j,k)=dzi*(u(i,j,k)-u(i,j,k-1)) d23(i,j,k)=dzi*(v(i,j,k)-v(i,j,k-1)) end do end do end do if(ibcz.eq.0) then Constraints for "free-slip" boundaries: c in 2D: [ d13*(1.-hx**2)=(d11-d33)*hx ] c in 3D: (1-hx**2)*d13- hx*hy*d23=(d11-d33)*hx+d12*hy c in 3D: -hx*hy*d13+(1-hy**2)*d23=(d22-d33)*hy+d12*hx c where di3 denotes stress' elements; these conditions lead c to auxiliary conditions on dui/dz denoted by di3 temporarily c note that top boundary is assumed to be flat #if (POLES == 0) jllim = 1 + (j3-ibcy)*botedge julim = mp + (ibcy-j3)*topedge #else jllim = 1 julim = mp #endif do j=jllim,julim #if (POLES == 0) if (topedge.eq.1 .and. j.eq.mp) then if (ibcy.eq.1) then jp1 = mp + 2 else jp1 = mp end if else jp1 = j + j3 end if if (botedge.eq.1 .and. j.eq.1) then if (ibcy.eq.1) then jm1 = -1 else jm1 = 1 end if else jm1 = j - j3 end if cvec jp1=(j+j3-j/m*(m-1))*ibcy+(1-ibcy)*min0(j+j3,m) cvec jm1=(j-j3+(m-j)/(m-j3)*(m-j3))*ibcy+(1-ibcy)*max0(j-j3,1) dyil=hdyi if ((ibcy.eq.0) .and. (j.eq.1 .and. botedge.eq.1)) dyil=dyi if ((ibcy.eq.0) .and. (j.eq.mp .and. topedge.eq.1)) dyil=dyi cvec if((ibcy.eq.0) .and. (j.eq.1.or.j.eq.m) ) dyil=dyi #else jp1 = j + j3 jm1 = j - j3 dyil=hdyi #endif do i=1,np #if (POLES == 0) if (rightedge.eq.1 .and. i.eq.np) then if (ibcx.eq.1) then ip1 = np + 2 else ip1 = np end if else ip1 = i + 1 end if if (leftedge.eq.1 .and. i.eq.1) then if (ibcx.eq.1) then im1 = -1 else im1 = 1 end if else im1 = i - 1 end if cvec ip1=(i+1-i/n*(n-1))*ibcx+(1-ibcx)*min0(i+1,n) cvec im1=(i-1+(n-i)/(n-1)*(n-1))*ibcx+(1-ibcx)*max0(i-1,1) dxil=hdxi if ((ibcx.eq.0) .and. (i.eq.1 .and. leftedge.eq.1)) dxil=dxi if ((ibcx.eq.0) .and. (i.eq.np .and. rightedge.eq.1)) dxil=dxi cvec if((ibcx.eq.0) .and. (i.eq.1.or.i.eq.n) ) dxil=dxi #else ip1 = i + 1 im1 = i - 1 dxil=hdxi #endif hx=-s13(i,j)/gi(i,j)*zb hy=-s23(i,j)/gi(i,j)*zb btt=1.+hx**2+hy**2 gmm=1-hx**2 dlt=1-hy**2 cc=1./gi(i,j)/btt d13(i,j,1)=cc*(-gmm*(w(ip1,j,1)-w(im1,j,1))*dxil . -hx/cc*(3.*w(i,j,2)-2.*w(i,j,1)-w(i,j,3))*dzi . +( 2.*hx*(u(ip1,j,1)-u(im1,j,1))*dxil . + hy*( (u(i,jp1,1)-u(i,jm1,1))*dyil . +(v(ip1,j,1)-v(im1,j,1))*dxil ) . +hx*hy*(w(i,jp1,1)-w(i,jm1,1))*dyil )) .+tauw(i,j)*(u(i,j,1)+hx*w(i,j,1))/sqrt(btt) d23(i,j,1)=cc*(-dlt*(w(i,jp1,1)-w(i,jm1,1))*dyil . -hy/cc*(3.*w(i,j,2)-2.*w(i,j,1)-w(i,j,3))*dzi . +( 2.*hy*(v(i,jp1,1)-v(i,jm1,1))*dyil . + hx*( (u(i,jp1,1)-u(i,jm1,1))*dyil . +(v(ip1,j,1)-v(im1,j,1))*dxil ) . +hx*hy*(w(ip1,j,1)-w(im1,j,1))*dxil )) .+tauw(i,j)*(v(i,j,1)+hy*w(i,j,1))/sqrt(btt) d13(i,j,1)=2.*d13(i,j,1)-d13(i,j,2) d23(i,j,1)=2.*d23(i,j,1)-d23(i,j,2) d13(i,j,l+1)=-d13(i,j,l) d23(i,j,l+1)=-d23(i,j,l) enddo enddo close free-slip constraint else do j=1,mp do i=1,np d13(i,j,1)=d13(i,j,L) d23(i,j,1)=d23(i,j,L) d13(i,j,L+1)=d13(i,j,2) d23(i,j,L+1)=d23(i,j,2) end do end do endif compute divergence of the wind vector: div(V)=-1/rho*w*drho/dzbar do k=2,l do j=1,mp do i=1,np dv(i,j,k)=-dzi*(rho(i,j,k)-rho(i,j,k-1))*gi(i,j)* * (w(i,j,k)+w(i,j,k-1))/(rho(i,j,k)+rho(i,j,k-1)) end do end do end do do j=1,mp do i=1,np dv(i,j,1 )=(1-ibcz)*(2.*dv(i,j,2)-dv(i,j, 3 ))+ibcz*dv(i,j,L) dv(i,j,L+1)=(1-ibcz)*(2.*dv(i,j,L)-dv(i,j,L-1))+ibcz*dv(i,j,2) end do end do c c save off divergence temporarily in ri do k=1,L do j=1,mp do i=1,np ri(i,j,k)=dv(i,j,k) end do end do end do c compute d11 at (i +- 1/2, j, k) if (rightedge.eq.0 .and. topedge.eq.0) then call update2(dv,np,mp,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update2(dv,np+1,mp,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update2(dv,np,mp+1,l+1,np+1,mp+1,1) else call update2(dv,np+1,mp+1,l+1,np+1,mp+1,1) end if if (rightedge.eq.0) then call update(d13,np,mp,l+1,np+1,mp,1) else call update(d13,np+1,mp,l+1,np+1,mp,1) end if #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,L do j=1,mp do i=illim,iulim g13=gmul(k)*0.5*(s13(i-1,j)+s13(i,j)) uza=0.25*(d13(i-1,j,k)+d13(i,j,k)+ 1 d13(i-1,j,k+1)+d13(i,j,k+1)) dva=0.25*(dv(i-1,j,k)+dv(i,j,k)+dv(i-1,j,k+1)+dv(i,j,k+1)) uxa=dxi*(u(i,j,k)-u(i-1,j,k)) d11(i,j,k) = 2.*( uxa + g13*uza - dva/dii ) end do end do end do #if (POLES == 0) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(d11,np,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(d11,np+1,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(d11,np,mp+1,l,np+1,mp+1,iupx) else call updatelr(d11,np+1,mp+1,l,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do j=1,mp do k=1,l d11(1,j,k) =(ibcx-1)*d11(2,j,k) + ibcx*d11(-1,j,k) end do end do end if if (rightedge.eq.1) then do j=1,mp do k=1,l d11(np+1,j,k) =(ibcx-1)*d11(np,j,k) + ibcx*d11(np+3,j,k) end do end do end if #endif compute contribution of d11 to Def**2 if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(d11,np,mp,l,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(d11,np+1,mp,l,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(d11,np,mp+1,l,np+1,mp+1,1) else call updatelr(d11,np+1,mp+1,l,np+1,mp+1,1) end if do k=1,L do j=1,mp do i=1,np d11a = 0.5*(d11(i,j,k)**2 + d11(i+1,j,k)**2 ) d11b =amax1(d11(i,j,k)**2 , d11(i+1,j,k)**2 ) d11a=.5*(d11a+d11b) defsq(i,j,k) = 0.5*d11a end do end do end do compute d33 at (i, j, k +- 1/2) do j=1,mp do i=1,np do k=2,L wza = dzi*(w(i,j,k)-w(i,j,k-1)) d33(i,j,k) = 2.*( gi(i,j)*wza - dv(i,j,k)/dii ) end do end do end do create boundary conditions at k=1 if(ibcz.eq.0) then do j=1,mp do i=1,np wza = dzi*(3.*w(i,j,2)-2.*w(i,j,1)-w(i,j,3)) d33(i,j,1) = 2.*( gi(i,j)*wza - dv(i,j,1)/dii ) end do end do else do j=1,mp do i=1,np d33(i,j,1) = d33(i,j,L) end do end do endif compute contribution of d33 to def**2 if(ibcz.eq.0) then do j=1,mp do i=1,np do k=1,L-1 d33a = 0.5 *(d33(i,j,k)**2 + d33(i,j,k+1)**2 ) d33b = amax1(d33(i,j,k)**2 , d33(i,j,k+1)**2 ) d33a=.5*(d33a+d33b) defsq(i,j,k) = defsq(i,j,k) + 0.5*d33a end do corporate b.c. by extrapolation to obtain d33 at k=L+1 d33Lp1 = 2.*d33(i,j,L)-d33(i,j,L-1) d33a = 0.5 *(d33(i,j,L)**2 + d33Lp1**2 ) d33b = amax1(d33(i,j,L)**2 , d33Lp1**2 ) d33a=.5*(d33a+d33b) defsq(i,j,L) = defsq(i,j,L) + 0.5*d33a end do end do else do j=1,mp do i=1,np do k=1,l-1 d33a = 0.5 *(d33(i,j,k)**2 + d33(i,j,k+1)**2 ) d33b = amax1(d33(i,j,k)**2 , d33(i,j,k+1)**2 ) d33a=.5*(d33a+d33b) defsq(i,j,k) = defsq(i,j,k) + 0.5*d33a end do corporate b.c. by extrapolation to obtain d33 at k=L+1 defsq(i,j,l) = defsq(i,j,1) end do end do endif c add in d22, d12, d23 if 3D problem if (topedge.eq.0) then call update(d23,np,mp,l+1,np,mp+1,1) else call update(d23,np,mp+1,l+1,np,mp+1,1) end if if (j3.eq.1) then compute d22 at (i, j +- 1/2, k) #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp #endif do k=1,L do j=jllim,julim do i=1,np g23=0.5*gmul(k)*(s23(i,j-j3)+s23(i,j)) vza=0.25*(d23(i,j-j3,k )+d23(i,j,k )+ . d23(i,j-j3,k+1)+d23(i,j,k+1) ) dva=0.25*(dv(i,j-j3,k )+dv(i,j,k )+ . dv(i,j-j3,k+1)+dv(i,j,k+1) ) vya=dyi*(v(i,j,k)-v(i,j-j3,k)) d22(i,j,k) = 2.*( vya + g23*vza - j3*dva/dii ) end do end do end do #if (POLES == 0) if (topedge.eq.0) then call updatebt(d22,np,mp,l,np,mp+1,iupy) else call updatebt(d22,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l do i=1,np d22(i,1,k) = (ibcy-1)*d22(i,2,k) + ibcy*d22(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np d22(i,mp+1,k) = (ibcy-1)*d22(i,mp,k) + . ibcy*d22(i,mp+3,k) end do end do end if #endif compute contribution of d22 to def**2 if (topedge.eq.0) then call updatebt(d22,np,mp,l,np,mp+1,1) else call updatebt(d22,np,mp+1,l,np,mp+1,1) end if do k=1,L do j=1,mp do i=1,np d22a = 0.5 *(d22(i,j,k)**2 + d22(i,j+1,k)**2 ) d22b = amax1(d22(i,j,k)**2 , d22(i,j+1,k)**2 ) d22a=.5*(d22a+d22b) defsq(i,j,k) = defsq(i,j,k) + 0.5*d22a end do end do end do endif compute d12 at (i +- 1/2, j+- 1/2, k) jllim = 1 + j3*botedge julim = mp illim = 1 + leftedge iulim = np do k=1,L do j=jllim,julim do i=illim,iulim g13=gmul(k)*0.25*( s13(i-1,j-j3) + s13(i,j-j3) . + s13(i-1,j ) + s13(i,j ) ) g23=gmul(k)*0.25*( s23(i-1,j-j3) + s23(i,j-j3) . + s23(i-1,j ) + s23(i,j ) ) uya=hdyi*((u(i-1,j,k)-u(i-1,j-j3,k))+(u(i,j,k)-u(i,j-j3,k))) vxa=hdxi*((v(i,j-j3,k)-v(i-1,j-j3,k))+(v(i,j,k)-v(i-1,j,k))) uza=0.125*( d13(i-1,j-j3,k )+d13(i,j-j3,k ) . + d13(i-1,j ,k )+d13(i,j ,k ) . + d13(i-1,j-j3,k+1)+d13(i,j-j3,k+1) . + d13(i-1,j ,k+1)+d13(i,j ,k+1) ) vza=0.125*( d23(i-1,j-j3,k )+d23(i,j-j3,k ) . + d23(i-1,j ,k )+d23(i,j ,k ) . + d23(i-1,j-j3,k+1)+d23(i,j-j3,k+1) . + d23(i-1,j ,k+1)+d23(i,j ,k+1) ) d12(i,j,k) = uya + g23*uza + vxa + g13*vza end do end do end do #if (POLES == 0) create boundary conditions at i=1 and n+1 (for j=1+j3,m) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(d12,np,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(d12,np+1,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(d12,np,mp+1,l,np+1,mp+1,iupx) else call updatelr(d12,np+1,mp+1,l,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do j=jllim,julim do k=1,l d12( 1,j,k)=(ibcx-1)*d12(2,j,k)+ibcx*d12( -1,j,k) end do end do end if if (rightedge.eq.1) then do j=jllim,julim do k=1,l d12(np+1,j,k)=(ibcx-1)*d12(np,j,k)+ibcx*d12(np+3,j,k) end do end do end if create boundary conditions at j=1 and m+1 (for i=1,n+1) if (rightedge.eq.0 .and. topedge.eq.0) then call updatebt(d12,np,mp,l,np+1,mp+1,iupy) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(d12,np+1,mp,l,np+1,mp+1,iupy) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(d12,np,mp+1,l,np+1,mp+1,iupy) else call updatebt(d12,np+1,mp+1,l,np+1,mp+1,iupy) end if illim = 1 iulim = np + 1*rightedge if (botedge.eq.1) then do k=1,l do i=illim,iulim d12(i,1 ,k)=(ibcy-1)*d12(i,2 ,k)+ibcy*d12(i,-1 ,k) end do end do end if if (topedge.eq.1) then do k=1,l do i=illim,iulim d12(i,mp+1,k)=(ibcy-1)*d12(i,mp,k)+ibcy*d12(i,mp+3,k) end do end do end if #endif compute contribution of d12 to def**2 if (rightedge.eq.0 .and. topedge.eq.0) then call update(d12,np,mp,l,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(d12,np+1,mp,l,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(d12,np,mp+1,l,np+1,mp+1,1) else call update(d12,np+1,mp+1,l,np+1,mp+1,1) end if do k=1,l do j=1,mp do i=1,np d12a = 0.25*(d12(i,j,k)**2 + d12(i+1,j,k)**2 . + d12(i,j+1,k)**2 + d12(i+1,j+1,k)**2 ) d12b = amax1(d12(i,j,k)**2 , d12(i+1,j,k)**2 . , d12(i,j+1,k)**2 , d12(i+1,j+1,k)**2 ) d12a=.5*(d12a+d12b) defsq(i,j,k) = defsq(i,j,k) + d12a end do end do end do compute d23 at (i, j +- 1/2, k +- 1/2) c note d23 is logically equivalenced to vz so j loop must descend jllim = 1 + j3*botedge julim = mp do k=2,l do j=julim,jllim,-1 do i=1,np gii=0.5*(gi(i,j-j3)+gi(i,j)) g23=0.25*(gmul(k-1)+gmul(k))*(s23(i,j-j3)+s23(i,j)) wya=hdyi*((w(i,j,k-1)-w(i,j-1,k-1))+(w(i,j,k)-w(i,j-1,k))) vza=0.5*(d23(i,j-j3,k)+d23(i,j,k)) wza=hdzi*((w(i,j-j3,k)-w(i,j-j3,k-1))+ 1 (w(i,j ,k)-w(i,j ,k-1))) d23(i,j,k) = ( gii*vza + wya + g23*wza ) end do end do end do create boundary conditions at k=1 and L+1 (for j=2,m) if (topedge.eq.0) then call updatebt(d23,np,mp,l+1,np,mp+1,1) else call updatebt(d23,np,mp+1,l+1,np,mp+1,1) end if if(ibcz.eq.0) then do j=julim,jllim,-1 do i=1,np gii=0.5*(gi(i,j-j3)+gi(i,j)) g23=.25*(3.*gmul(1)-gmul(2))*(s23(i,j-j3)+s23(i,j)) wya=hdyi*(3.*(w(i,j,1)-w(i,j-j3,1))-(w(i,j,2)-w(i,j-j3,2))) vza=0.5*(d23(i,j-j3,1)+d23(i,j,1)) wza=(3.*w(i,j ,2)-2.*w(i,j ,1)-w(i,j ,3))*hdzi 1 +(3.*w(i,j-j3,2)-2.*w(i,j-j3,1)-w(i,j-j3,3))*hdzi d23(i,j,1) = ( gii*vza+ wya+ g23*wza) d23(i,j,L+1) = 0.5*(d23(i,j-j3,L+1)+d23(i,j,L+1)) end do end do else do j=julim,jllim,-1 do i=1,np d23(i,j, 1 ) = d23(i,j,L) d23(i,j,L+1) = d23(i,j,2) end do end do endif #if (POLES == 0) create boundary conditions at j=1 and m+1 (for k=1,L+1) if (topedge.eq.0) then call updatebt(d23,np,mp,l+1,np,mp+1,iupy) else call updatebt(d23,np,mp+1,l+1,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l+1 do i=1,np d23(i,1 ,k)=(ibcy-1)*d23(i,2 ,k)+ibcy*d23(i,-1 ,k) end do end do end if if (topedge.eq.1) then do k=1,l+1 do i=1,np d23(i,mp+1,k)=(ibcy-1)*d23(i,mp,k)+ibcy*d23(i,mp+3,k) end do end do end if #endif compute contribution of d23 to def**2 if (topedge.eq.0) then call updatebt(d23,np,mp,l+1,np,mp+1,1) else call updatebt(d23,np,mp+1,l+1,np,mp+1,1) end if do k=1,l do j=1,mp do i=1,np d23a = 0.25*(d23(i,j,k )**2 + d23(i,j+1,k )**2 . + d23(i,j,k+1)**2 + d23(i,j+1,k+1)**2 ) d23b = amax1(d23(i,j,k )**2 , d23(i,j+1,k )**2 . , d23(i,j,k+1)**2 , d23(i,j+1,k+1)**2 ) d23a=.5*(d23a+d23b) defsq(i,j,k) = defsq(i,j,k) + d23a end do end do end do compute d13 at (i +- 1/2,j,k +- 1/2) c note d13 is logically equivalenced to uz so i loop must descend illim = 1 + leftedge iulim = np do k=2,l do j=1,mp do i=iulim,illim,-1 gii=0.5*(gi(i-1,j)+gi(i,j)) g13=0.25*(gmul(k-1)+gmul(k))*(s13(i-1,j)+s13(i,j)) wxa=hdxi*((w(i,j,k-1)-w(i-1,j,k-1))+(w(i,j,k)-w(i-1,j,k))) uza=0.5*(d13(i-1,j,k)+d13(i,j,k)) wza=hdzi*((w(i-1,j,k)-w(i-1,j,k-1))+(w(i,j,k)-w(i,j,k-1))) d13(i,j,k) = gii*uza + wxa + g13*wza end do end do end do create boundary conditions at k=1 and L+1 (for i=2,n) if (rightedge.eq.0) then call updatelr(d13,np,mp,l+1,np+1,mp,1) else call updatelr(d13,np+1,mp,l+1,np+1,mp,1) end if if(ibcz.eq.0) then do j=1,mp do i=iulim,illim,-1 gii=0.5*(gi(i-1,j)+gi(i,j)) g13=.25*(3.*gmul(1)-gmul(2))*(s13(i-1,j)+s13(i,j)) wxa=hdxi*(3.*(w(i,j,1)-w(i-1,j,1))-(w(i,j,2)-w(i-1,j,2))) uza=0.5*(d13(i-1,j,1)+d13(i,j,1)) wza=(3.*w(i ,j,2)-2.*w(i ,j,1)-w(i ,j,3))*hdzi 1 +(3.*w(i-1,j,2)-2.*w(i-1,j,1)-w(i-1,j,3))*hdzi d13(i,j,1) = ( gii*uza+ wxa+ g13*wza) d13(i,j,L+1) = 0.5*(d13(i-1,j,L+1)+d13(i,j,L+1)) end do end do else do j=1,mp do i=iulim,illim,-1 d13(i,j, 1 ) = d13(i,j,L) d13(i,j,L+1) = d13(i,j,2) end do end do endif #if (POLES == 0) create boundary conditions at i=1 and n+1 (for k=1,l+1) if (rightedge.eq.0) then call updatelr(d13,np,mp,l+1,np+1,mp,iupx) else call updatelr(d13,np+1,mp,l+1,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,mp do k=1,l+1 d13( 1,j,k)=(ibcx-1)*d13(2 ,j,k)+ibcx*d13(-1 ,j,k) end do end do end if if (rightedge.eq.1) then do j=1,mp do k=1,l+1 d13(np+1,j,k)=(ibcx-1)*d13(np,j,k)+ibcx*d13(np+3,j,k) end do end do end if #endif compute contribution of d13 to def**2 if (rightedge.eq.0) then call updatelr(d13,np,mp,l+1,np+1,mp,1) else call updatelr(d13,np+1,mp,l+1,np+1,mp,1) end if do k=1,l do j=1,mp do i=1,np d13a = 0.25*(d13(i,j,k )**2 + d13(i+1,j,k )**2 . + d13(i,j,k+1)**2 + d13(i+1,j,k+1)**2 ) d13b = amax1(d13(i,j,k )**2 , d13(i+1,j,k )**2 . , d13(i,j,k+1)**2 , d13(i+1,j,k+1)**2 ) d13a=.5*(d13a+d13b) defsq(i,j,k) = defsq(i,j,k) + d13a end do end do end do compute stability on A grid and store temporarily in dv if (moist.eq.1) then !moist case eps = Rg/Rv ! eps=Rd/Rv=0.622 ee = (1.-eps)/eps ! =0.61 c1=hlat/rg ! c1=L/Rd c2=hlat/cp ! c2=L/cp c3=eps*c2*c1 ! c3=eps*L**2/(cp*Rd) do k=2,L do j=1,mp do i=1,np compute stability for unsaturated portions as N**2 = dln(thetav)/dz c (e.g., Emanuel, Atmospheric Convection (6.1.7)) where thetav is the c virtual potential temp, thetav = thetad*(1+ee*qv), where c ee=(1-eps)/eps, eps=Rd/Rv c N**2 = dln(thetad)/dz + (ee/(1+ee*qv))*dqv/dz dqv = (qv(i,j,k)-qv(i,j,k-1)) qva = 0.5*(qv(i,j,k)+qv(i,j,k-1)) dThd = (th(i,j,k) - th(i,j,k-1))/ . (0.5*(th0(i,j,k) + th0(i,j,k-1))) N2unsat = dThd + (ee/(1.+ee*qva))*dqv compute stability for saturated portions according to Durran and Klemp, c JAS 1982, p. 2152, eq(36). The local temperature Ta is approximated c by T/Te = theta/thetae Tk = tme(i,j,k)*(th(i,j,k)/the(i,j,k)) Tkm1= tme(i,j,k-1)*(th(i,j,k-1)/the(i,j,k-1)) Ta = 0.5*(Tk + Tkm1) dqw = (qv(i,j,k)+qc(i,j,k)) - (qv(i,j,k-1)+qc(i,j,k-1)) rgam = (1.+c1*qva/Ta)/(1.+c3*qva/(Ta*Ta)) N2sat = rgam*(dThd + c2*dqv/Ta) - dqw dv(i,j,k)=g*dzi*gi(i,j)*cvmgmxx(N2unsat,N2sat, . 0.5*(qc(i,j,k)+qc(i,j,k-1))-1.e-6) end do end do end do c else ! dry case do k=2,L do j=1,mp do i=1,np dv(i,j,k)=( ( th(i,j,k)- th(i,j,k-1))/ . ((th0(i,j,k)+th0(i,j,k-1))*0.5) )* . g*dzi*gi(i,j) end do end do end do endif c do j=1,mp do i=1,np dv(i,j, 1 )=(1-ibcz)*dv(i,j,2)+ibcz*dv(i,j,L) dv(i,j,L+1)=(1-ibcz)*dv(i,j,L)+ibcz*dv(i,j,2) end do end do c compute stability at A-grid points do j=1,mp do i=1,np do k=1,L stab(i,j,k)=0.5*(dv(i,j,k)+dv(i,j,k+1)) end do end do end do c c copy back divergence temporarily stored in ri for output #if (HP > 0) C do k=1,l ! This loops C do j=1,mp ! Dont work with C do i=1,np ! +O3,+O4 optimalization on HP do j=1,mp do i=1,np do k=1,l #else do k=1,L do j=1,mp do i=1,np #endif dv(i,j,k)=ri(i,j,k) end do end do end do do j=1,mp do i=1,np dv(i,j,L+1)=(1-ibcz)*(2.*dv(i,j,L)-dv(i,j,L-1)) . +ibcz*dv(i,j,2) end do end do c c smooth resultant defsq field if(ismoth.ge.2) then call filstr(defsq) endif c do k=1,l do j=1,mp do i=1,np ri(i,j,k) = stab(i,j,k)/amax1(defsq(i,j,k),1.0e-15) th(i,j,k)=th(i,j,k)-the(i,j,k) enddo enddo enddo c c smooth resultant Ri field if(ismoth.ge.1) then call filstr(ri) ! ri updated inside filstr else call update(ri,np,mp,l,np,mp,1) ! update ri endif #if (TIMEPLT == 1) call ttend(49) #endif return end subroutine filstr(a) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) dimension sx(np),sy(mp),sz(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(29) #endif call updatelr(a,np,mp,l,np,mp,iupx) #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge ibox=1-ibcx iboy=1-ibcy iboz=1-ibcz #else illim = 1 iulim = np iboz=1-ibcz #endif do k=1,l do j=1,mp do i=illim,iulim sx(i)=0.25*(a(i+1,j,k)+2.*a(i,j,k)+a(i-1,j,k)) enddo #if (POLES == 0) if (leftedge.eq.1) then sx(1)=ibcx*0.25*(a(2,j,k)+2.*a(1,j,k)+a(-1,j,k))+ibox*a(1,j,k) end if if (rightedge.eq.1) then temp=0.25*(a(np+2,j,k)+2.*a(np+1,j,k)+a(np-1,j,k)) sx(np)=ibcx*temp+ibox*a(np,j,k) end if #endif do i=1,np a(i,j,k)=sx(i) enddo enddo enddo if(j3.eq.1) then call updatebt(a,np,mp,l,np,mp,iupy) #if (POLES == 0) jllim=1 + j3*botedge julim=mp - j3*topedge #else jllim=1 julim=mp #endif do k=1,l do i=1,np do j=jllim,julim sy(j)=0.25*(a(i,j+j3,k)+2.*a(i,j,k)+a(i,j-j3,k)) enddo #if (POLES == 0) if (botedge.eq.1) then sy(1)=ibcy*0.25*(a(i,1+j3,k)+2.*a(i,1,k)+a(i,-j3,k)) . +iboy*a(i,1,k) end if if (topedge.eq.1) then temp=0.25*(a(i,mp+1+j3,k)+2.*a(i,mp+1,k)+a(i,mp-j3,k)) sy(mp)=ibcy*temp+iboy*a(i,mp,k) end if #endif do j=1,mp a(i,j,k)=sy(j) enddo enddo enddo endif do j=1,mp do i=1,np do k=2,l-1 sz(k)=0.25*(a(i,j,k+1)+2.*a(i,j,k)+a(i,j,k-1)) enddo if(ibcz.eq.0) then sz(1)=a(i,j,1) sz(l)=a(i,j,l) else sz(1)=0.25*(a(i,j,2)+2.*a(i,j,1)+a(i,j,l-1)) sz(l)=0.25*(a(i,j,2)+2.*a(i,j,l)+a(i,j,l-1)) endif do k=1,l a(i,j,k)=sz(k) enddo enddo enddo call update(a,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(29) #endif return end subroutine filstr2(a) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih) dimension sx(np),sy(mp) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(29) #endif call updatelr(a,np,mp,1,np,mp,iupx) illim = 1 + leftedge iulim = np - rightedge ibox=1-ibcx iboy=1-ibcy do j=1,mp do i=illim,iulim sx(i)=0.25*(a(i+1,j)+2.*a(i,j)+a(i-1,j)) enddo if (leftedge.eq.1) then sx(1)=ibcx*0.25*(a(2,j)+2.*a(1,j)+a(-1,j))+ibox*a(1,j) end if if (rightedge.eq.1) then temp=0.25*(a(np+2,j)+2.*a(np+1,j)+a(np-1,j)) sx(np)=ibcx*temp+ibox*a(np,j) end if do i=1,np a(i,j)=sx(i) enddo enddo if(j3.eq.1) then call updatebt(a,np,mp,1,np,mp,iupy) jllim=1 + j3*botedge julim=mp - j3*topedge do i=1,np do j=jllim,julim sy(j)=0.25*(a(i,j+j3)+2.*a(i,j)+a(i,j-j3)) enddo if (botedge.eq.1) then sy(1)=ibcy*0.25*(a(i,1+j3)+2.*a(i,1)+a(i,-j3)) . +iboy*a(i,1) end if if (topedge.eq.1) then temp=0.25*(a(i,mp+1+j3)+2.*a(i,mp+1)+a(i,mp-j3)) sy(mp)=ibcy*temp+iboy*a(i,mp) end if do j=1,mp a(i,j)=sy(j) enddo enddo endif call update(a,np,mp,1,np,mp,1) #if (TIMEPLT == 1) call ttend(29) #endif return end #if (ANALIZE == 0 || ENERGY == 1) #if (SGS == 1) subroutine dissip(u0,v0,w0,th,chm,qv,qc,qr,tke, 1 fx,fy,fz,ft,fchm, 1 qia,qib,fqia,fqib, fqv,fqc,fqr,ftke, 2 fox,foy,foz,pfx,pfy,pfz,u1,v1,w1,ox1,oy1,oz1) include 'param.nml' include 'msg.inc' dimension u0(1-ih:np+ih,1-ih:mp+ih,l), . v0(1-ih:np+ih,1-ih:mp+ih,l), . w0(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension chm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc), . fchm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc) dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke) dimension fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . pfx(1-ih:np+ih,1-ih:mp+ih,l), . pfy(1-ih:np+ih,1-ih:mp+ih,l), . pfz(1-ih:np+ih,1-ih:mp+ih,l), . u1(1-ih:np+ih,1-ih:mp+ih,l), . v1(1-ih:np+ih,1-ih:mp+ih,l), . w1(1-ih:np+ih,1-ih:mp+ih,l), . ox1(1-ih:np+ih,1-ih:mp+ih,l), . oy1(1-ih:np+ih,1-ih:mp+ih,l), . oz1(1-ih:np+ih,1-ih:mp+ih,l) #if (TIMEPLT == 1) call ttbeg(40) #endif data ismoo/0/ call rical(u0,v0,w0,th,qv,qc,ismoo) !Ri, def, stability call tkefrc(tke,ftke,pfx,pfy,pfz) !Km & TKE rhs call stress(u0,v0,w0,th,chm,qv,qc,qr,qia,qib, !diffusive rhs 1 fx,fy,fz,foz,u1,v1,w1,oz1, 1 ft,fchm,fqv,fqc,fqr,fqia,fqib,pfx,pfy,pfz) #if (TIMEPLT == 1) call ttend(40) #endif return end subroutine tkefrc(tke,ftke,Prinv,Km,scr1) ! Calculation of eddy viscosity. If itkes=itke=0, Smagorinky's ! approach is adopted. If itke=1, the scheme applies the TKE-equation ! with Schumann's parameterization (see, eg. Sorbjan, 1996,JAS,January) ! The subroutine calls the subroutine lapdf to calculate ! diffusion terms in the TKE equation. ! On input scr1 contains pfz, scr2 contains Ri, scr3 contains N**2, ! scr4 contains divergence; all are destroyed on output !-------------------------------------------------------------------- include 'param.nml' include 'msg.inc' real tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke), 1 Prinv(1-ih:np+ih, 1-ih:mp+ih, l), . Km(1-ih:np+ih, 1-ih:mp+ih, l), . scr1(1-ih:np+ih, 1-ih:mp+ih, l) common/blank/ scr2(1-ih:np+ih, 1-ih:mp+ih, l), . scr3(1-ih:np+ih, 1-ih:mp+ih, l), . Defsq(1-ih:np+ih, 1-ih:mp+ih, l), . d33(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l), . scr11(1-ih:np+ih, 1-ih:mp+ih, l, 11) parameter(iblank=11*(np+2*ih)*(mp+2*ih)*l) parameter(idd1=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id12=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id22=(np+2*ih) *(mp+2*ih+1) *l) parameter(id23=(np+2*ih) *(mp+2*ih+1) *(l+1)) parameter(id13=(np+2*ih+1)*(mp+2*ih) *(l+1)) parameter(icr4=(np+2*ih+1)*(mp+2*ih+1) *(l+1)) parameter(ifree=iblank-idd1-id12-id22-id23-id13-icr4) common /stress2/ d11(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . d12(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . d22(1-ih:np+ih, 1-ih:mp+ih+1, l), * d23(1-ih:np+ih, 1-ih:mp+ih+1, l+1), . d13(1-ih:np+ih+1, 1-ih:mp+ih, l+1), * scr4(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/stresd/ primx,primn,priav,prisd, * kmmx,kmmn,kmav,kmsd, * ivis,irid,itstr real kmmx,kmmn,kmav,kmsd common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/sgscnst/ ceps,cL,cm,cs,prndt real cii,cLz,deltl,diva,Diss,E,eps,lambda,Kmij,kmmax,isot,Nsq real globmax,globmin,globsum #if (TIMEPLT == 1) call ttbeg(46) #endif coefficients if(j3.eq.1) then !3D case cii=1./3. deltl=(dx+dy+dz)/3. else !2D case cii=1./2. deltl=sqrt(dx*dz) endif pri=1./prndt ce=2. grkm=(j3*amin1(dx,dy,dz)**2+(1-j3)*amin1(dx,dz)**2)*dti kmmax=-1.e15 eps=1.e-10 Compute the mixing coefficient if(itkes.eq.1) then epkm=1.e-5*grkm do k=1,Lke do j=1,mkep do i=1,nkep cLz=cL*amax1(float(k-1),1.)*dz/gi(i,j) lambda=(1-ibcz)*amin1(cLz,deltl)+ibcz*deltl ! mixing length cmL=cm*lambda sqrtE=amax1(epkm/cml,tke(i,j,k)) ! E>epsilon E=sqrtE*sqrtE Kmij=cmL*sqrtE ! Km=cm*L*sqrt(E) Nsq=scr3(i,j,k) denomin=E+0.3*deltl*deltl*amax1(0.0,Nsq) prndti=pri*E/denomin ! 1/Prandt cspec prndti=pri ! 1/Prandt SPB=(cmL/2.)*(defsq(i,j,k) - Nsq*prndti) ! S+B diva=0.5*(scr4(i,j,k)+scr4(i,j,k+1)) ! divergence isot=cii*sqrtE*diva ! (1/deltaii)*E*div Diss=ceps*E/(2.*lambda) ! Dissipation ftke(i,j,k)=SPB-isot-Diss ! RHS of tke eqn tke(i,j,k)=sqrtE Prinv(i,j,k)=prndti/pri ! variable part of kmmax=amax1(kmmax,Kmij) ! max of Km CBS Km(i,j,k)=2.*ce*cmL*E ! exact Km(i,j,k)=Kmij ! Deardorff approx enddo enddo enddo if(ibcz.eq.0) then ke=1+itkes do j=1,mkep do i=1,nkep Km(i,j,1)= Km(i,j,ke) tke(i,j,1)= tke(i,j,ke) ftke(i,j,1)= ftke(i,j,ke) Prinv(i,j,1)=Prinv(i,j,ke) enddo enddo endif c compute the flux divergence term, (1/(2sqrt(E))*d/dxj(ce*Km*dE/dxj). c Following Deardorff(BLM,18,495-527,1980), this term is approximated c as d/dxj(ce*Km*dsqrt(E)/dxj). Since ce is a constant we can call LAPDF c to compute d/dxj(Km*dsqrt(E)/dxj), and then multiply by the result by ce. c note scr3 which contained N**2 is destroyed by the output of lapdf. c scr1,scr2,defsq,and scr4 are work arrays and are destroyed. [For exact c call LAPDF to compute d/dxj(2*ce*cm*lambda*E*dsqrt(E)/dxj), where c 2*ce*cm*lambda*E is temproarily in Km, and divide by 2sqrtE afterwards.] do k=1,l do j=1,mp do i=1,np scr3(i,j,k)=1. enddo enddo enddo call lapdf(tke,scr3,Km,scr3,scr1,scr2,defsq,scr4,0) compute RHS in the TKE-equation =2*(Sr+Bu-Ds+Diff) and recompute Km c note the factor 2 comes from the implicit time differencing used in the c main routine do k=1,Lke do j=1,mkep do i=1,nkep CBS cLz=cL*amax1(float(k-1),1.)*dz/gi(i,j) CBS lambda=(1-ibcz)*amin1(cLz,deltl)+ibcz*deltl ! mixing length CBS cmL=cm*lambda CBS Km(i,j,k)=cmL*tke(i,j,k) ! Km=cm*L*sqrt(E) CBS denomin = 2.*tke(i,j,k) CBS Diff = scr3(i,j,k)/amax1(eps,denomin) Diff = ce*scr3(i,j,k) ftke(i,j,k)=2.*(ftke(i,j,k)+Diff) ! RHS of tke eqn enddo enddo enddo else prndti=pri epkm=1.e-5*grkm do k=1,Lkv do j=1,mkvp do i=1,nkvp cLz=cL*amax1(float(k-1),1.)*dz/gi(i,j) lambda=(1-ibcz)*amin1(cLz,deltl)+ibcz*deltl ! mixing length SPB=Defsq(i,j,k) - scr3(i,j,k)*prndti ! Def**2-(Kh/Km)*N**2 Prinv(i,j,k)=1. Kmij=(cs*lambda)**2 *sqrt(amax1(SPB,0.0)) ! Smgr-sky's Km Kmij=amax1(Kmij,epkm) Kmij=1.004e-6 Km(i,j,k)=Kmij tke(i,j,k)=Kmij/(cm*lambda) ! sqrt(E)=Km/(c*L) kmmax=amax1(kmmax,Kmij) ! max of Km enddo enddo enddo if(ibcz.eq.0) then kv=1+ivs0 do j=1,mkvp do i=1,nkvp Km(i,j,1)= Km(i,j,kv) tke(i,j,1)=tke(i,j,kv) enddo enddo endif endif compute diagnostics kmmax=globmax(kmmax,1,1,1,1,1,1,1,1,1,1,1,1) dcr1=kmmax*dt*(dxi**2+j3*dyi**2+dzi**2) if(dcr1.gt.0.5) then if(mype.eq.0) print 201,itstr,dcr1 201 format(2x,'it, difcr:',i5,e11.4) stop 'tkefrc cfl' endif if((itstr/noutp)*noutp.eq.itstr) then nml=n*m*l primx=-1.e15 primn= 1.e15 priav=0. kmmx=-1.e15 kmmn= 1.e15 kmav=0. primx = globmax(Prinv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) primn = globmin(Prinv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) priav = globsum(Prinv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) kmmx = globmax(Km,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) kmmn = globmin(Km,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) kmav = globsum(Km,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) priav=priav/float(nml) kmav=kmav/float(nml) prisd=0. kmsd=0. do k=1,l do j=1,mp do i=1,np temp(i,j,k) = (Prinv(i,j,k)-priav)**2 end do end do end do prisd = globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) prisd = sqrt(prisd/float(nml)) do k=1,l do j=1,mp do i=1,np temp(i,j,k) = (Km(i,j,k)-kmav)**2 end do end do end do kmsd = globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) kmsd = sqrt(kmsd/float(nml)) endif #if (TIMEPLT == 1) call ttend(46) #endif return end subroutine stress(u,v,w,th,chm,qv,qc,qr,qia,qib,fx,fy,fz,fomeg, . fu,fv,fw,fo,ft,fchm,fqv,fqc,fqr,fqia,fqib,Prinv,Km,scr1) include 'param.nml' include 'msg.inc' real u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . fx(1-ih:np+ih, 1-ih:mp+ih, l), . fy(1-ih:np+ih, 1-ih:mp+ih, l), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . fu(1-ih:np+ih, 1-ih:mp+ih, l), . fv(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l), . fo(1-ih:np+ih, 1-ih:mp+ih, l), . ft(1-ih:np+ih, 1-ih:mp+ih, l), . Prinv(1-ih:np+ih, 1-ih:mp+ih, l), . Km(1-ih:np+ih, 1-ih:mp+ih, l), . scr1(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fomeg(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . chm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc), . fchm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc) common/blank/ scr3(1-ih:np+ih, 1-ih:mp+ih, l), . scr2(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . f33(1-ih:np+ih, 1-ih:mp+ih, l), . scr12(1-ih:np+ih, 1-ih:mp+ih, l, 12) parameter(iblank=12*(np+2*ih)*(mp+2*ih)*l) parameter(idd1=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id12=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id22=(np+2*ih) *(mp+2*ih+1) *l) parameter(id23=(np+2*ih) *(mp+2*ih+1) *(l+1)) parameter(id13=(np+2*ih+1)*(mp+2*ih) *(l+1)) parameter(icr4=(np+2*ih+1)*(mp+2*ih+1) *(l+1)) parameter(ifree=iblank-idd1-id12-id22-id23-id13-icr4) common /stress2/ f11(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . f12(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . f22(1-ih:np+ih, 1-ih:mp+ih+1, l), * f23(1-ih:np+ih, 1-ih:mp+ih+1, l+1), . f13(1-ih:np+ih+1, 1-ih:mp+ih, l+1), * temp(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) c Calculation of the RHS in the prognostic equations, c diffusion terms obtained using km from the TKE-equation (sub."tkefrc") c inputs include Prinv = 1/Pr/pri, Km, f11,...,f23, containing the six c components of the deformation tensor. scr1, scr2, scr3, and temp c are work arrays. c Output: fu,fv,fw,ft,fqv,fqc,fqr. c Note that the subroutine is called only when ivisc=1 and itke=1. c This subroutine calls subroutines lapdf to calculate diffusion terms. common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/stresd/ diagstr(8),ivis,irid,itstr common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/slip/ noslip common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm real den,Kma,tau13,tau23,tau33,tc #if (TIMEPLT == 1) call ttbeg(47) #endif tc=1. compute components of stress tensor tauij c note that terms 2/3 dE/dxi are formally included in pressure terms dP/dxi c and therefore are not present in terms d11, d22, and d33 below: compute G*tau11=d*km*d11 at (i +- 1/2, j, k) call update(Km,np,mp,l,np,mp,1) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,L do j=1,mp do i=illim,iulim Kma=0.5*(Km(i-1,j,k)+Km(i,j,k)) den=0.5*(rho(i-1,j,k)+rho(i,j,k)) d11=f11(i,j,k) f11(i,j,k)=den*Kma*d11 end do end do end do #if (POLES == 0) create boundary conditions at i=1 and n+1 if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(f11,np,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(f11,np+1,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(f11,np,mp+1,l,np+1,mp+1,iupx) else call updatelr(f11,np+1,mp+1,l,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do j=1,mp do k=1,l f11(1,j,k)=(ibcx-1)*f11(2,j,k) + ibcx*f11(-1,j,k) end do end do end if if (rightedge.eq.1) then do j=1,mp do k=1,l f11(np+1,j,k)=(ibcx-1)*f11(np,j,k) + ibcx*f11(np+3,j,k) end do end do end if #endif compute G*tau12=d*km*d12 at (i +- 1/2, j+- 1/2, k) #if (POLES == 0) jllim = 1 + j3*botedge julim = mp illim = 1 + leftedge iulim = np #else jllim = 1 julim = mp + j3*topedge illim = 1 iulim = np #endif do k=1,l do j=jllim,julim do i=illim,iulim Kma=0.25*( Km(i-1,j-j3,k)+Km(i,j-j3,k) . + Km(i-1,j ,k)+Km(i,j ,k) ) den=0.25*(rho(i-1,j-j3,k)+rho(i,j-j3,k) . +rho(i-1,j ,k)+rho(i,j ,k)) d12=f12(i,j,k) f12(i,j,k)=den*Kma*d12 end do end do end do #if (POLES == 0) create boundary conditions at i=1 and n+1 (for j=1+j3,m) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(f12,np,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(f12,np+1,mp,l,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(f12,np,mp+1,l,np+1,mp+1,iupx) else call updatelr(f12,np+1,mp+1,l,np+1,mp+1,iupx) end if if (leftedge.eq.1) then do j=jllim,julim do k=1,l f12( 1,j,k) = (ibcx-1)*f12(2,j,k) + ibcx*f12(-1,j,k) end do end do end if if (rightedge.eq.1) then do j=jllim,julim do k=1,l f12(np+1,j,k) = (ibcx-1)*f12(np,j,k) + . ibcx*f12(np+3,j,k) end do end do end if create boundary conditions at j=1 and m+1 (for i=1,n+1) if (rightedge.eq.0 .and. topedge.eq.0) then call updatebt(f12,np,mp,l,np+1,mp+1,iupy) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(f12,np+1,mp,l,np+1,mp+1,iupy) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(f12,np,mp+1,l,np+1,mp+1,iupy) else call updatebt(f12,np+1,mp+1,l,np+1,mp+1,iupy) end if illim = 1 iulim = np + 1*rightedge if (botedge.eq.1) then do k=1,l do i=illim,iulim f12(i,1 ,k)=(ibcy-1)*f12(i,2,k)+ibcy*f12(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,l do i=illim,iulim f12(i,mp+1,k)=(ibcy-1)*f12(i,mp,k)+ibcy*f12(i,mp+3,k) end do end do end if #endif compute G*tau13=d*km*d13 at (i +- 1/2, j, k +- 1/2) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=2,l do j=1,mp do i=illim,iulim den=0.25*(rho(i-1,j,k-1)+rho(i,j,k-1) . +rho(i-1,j,k )+rho(i,j,k )) Kma=0.25*(Km(i-1,j,k-1)+Km(i,j,k-1) . +Km(i-1,j,k )+Km(i,j,k )) d13 = f13(i,j,k) f13(i,j,k) = den*Kma*d13 end do end do end do create boundary conditions at k=1 and l+1 (for i=1,n+1) if(ibcz.eq.0) then do j=1,mp do i=illim,iulim den=0.25*(3.*(rho(i-1,j,2)+rho(i,j,2)) . -(rho(i-1,j,1)+rho(i,j,1)) ) Kma=0.25*(Km(i-1,j,1)+Km(i,j,1)+Km(i-1,j,2)+Km(i,j,2)) f13(i,j,1) = den*Kma*f13(i,j,1) den=0.25*(3.*(rho(i-1,j,L )+rho(i,j,L )) . -(rho(i-1,j,L-1)+rho(i,j,L-1)) ) Kma=0.25*(Km(i-1,j,L)+Km(i,j,L)+Km(i-1,j,L-1)+Km(i,j,L-1)) f13(i,j,L+1) = den*Kma*f13(i,j,L+1) end do end do else do j=1,mp do i=illim,iulim f13(i,j, 1 ) = f13(i,j,L) f13(i,j,L+1) = f13(i,j,2) end do end do endif #if (POLES == 0) create boundary conditions for i=1 and n+1 (for k=2,l) if (rightedge.eq.0) then call updatelr(f13,np,mp,l+1,np+1,mp,iupx) else call updatelr(f13,np+1,mp,l+1,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,mp do k=1,l+1 f13( 1,j,k) = (ibcx-1)*f13(2,j,k) + ibcx*f13(-1,j,k) end do end do end if if (rightedge.eq.1) then do j=1,mp do k=1,l+1 f13(np+1,j,k) = (ibcx-1)*f13(np,j,k) + . ibcx*f13(np+3,j,k) end do end do end if #endif compute G*tau22=d*km*d22 at (i, j +- 1/2, k) if (j3.eq.1) then #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp +j3*topedge #endif do k=1,l do j=jllim,julim do i=1,np den=0.5*(rho(i,j-j3,k)+rho(i,j,k)) Kma=0.5*(Km(i,j-j3,k)+Km(i,j,k)) d22 = f22(i,j,k) f22(i,j,k) = den*Kma*d22 end do end do end do #if (POLES == 0) create boundary conditions at j=1 and m+1 if (topedge.eq.0) then call updatebt(f22,np,mp,l,np,mp+1,iupy) else call updatebt(f22,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l do i=1,np f22(i,1 ,k)=(ibcy-1)*f22(i,2 ,k)+ibcy*f22(i,-1 ,k) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np f22(i,mp+1,k)=(ibcy-1)*f22(i,mp,k)+ibcy*f22(i,mp+3,k) end do end do end if #endif else jllim = 1 julim = mp + j3*topedge do k=1,l do j=jllim,julim do i=1,np f22(i,j,k)=0. end do end do end do end if compute d23 and G*tau23=d*km*d23 at (i, j +- 1/2, k +- 1/2) #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp + j3*topedge #endif do k=2,l do j=jllim,julim do i=1,np den=0.25*(rho(i,j-j3,k-1)+rho(i,j,k-1) . +rho(i,j-j3,k )+rho(i,j,k )) Kma=0.25*(Km(i,j-j3,k-1)+Km(i,j,k-1) . +Km(i,j-j3,k )+Km(i,j,k )) d23 = f23(i,j,k) f23(i,j,k) = den*Kma*d23 end do end do end do create boundary condition at k=1 and l+1 (for j=1,m+1) if(ibcz.eq.0) then do j=jllim,julim do i=1,np den=0.25*(3.*(rho(i,j,2)+rho(i,j-j3,2)) . -(rho(i,j,1)+rho(i,j-j3,1)) ) Kma=0.25*(Km(i,j-j3,1)+Km(i,j,1)+Km(i,j-j3,2)+Km(i,j,2)) f23(i,j,1) = den*Kma*f23(i,j,1) den=0.25*(3.*(rho(i,j,L )+rho(i,j-j3,L )) . -(rho(i,j,L-1)+rho(i,j-j3,L-1)) ) Kma=0.25*(Km(i,j-j3,L)+Km(i,j,L)+Km(i,j-j3,L-1)+Km(i,j,L-1)) f23(i,j,L+1) = den*Kma*f23(i,j,L+1) end do end do else do j=jllim,julim do i=1,np f23(i,j, 1 ) = f23(i,j,L) f23(i,j,L+1) = f23(i,j,2) end do end do endif #if (POLES == 0) create boundary conditions at j=1 and m+1 (for k=2,l) if (topedge.eq.0) then call updatebt(f23,np,mp,l+1,np,mp+1,iupy) else call updatebt(f23,np,mp+1,l+1,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,l+1 do i=1,np f23(i,1 ,k)=(ibcy-1)*f23(i,2 ,k)+ibcy*f23(i,-1 ,k) end do end do end if if (topedge.eq.1) then do k=1,l+1 do i=1,np f23(i,mp+1,k)=(ibcy-1)*f23(i,mp,k)+ibcy*f23(i,mp+3,k) end do end do end if #endif compute d33 and G*tau33=d*km*d33 at (i, j, k +- 1/2) do k=2,L do j=1,mp do i=1,np den=0.5*(rho(i,j,k-1)+rho(i,j,k)) Kma=0.5*(Km(i,j,k-1)+Km(i,j,k)) d33 = f33(i,j,k) f33(i,j,k) = den*Kma*d33 end do end do end do create boundary conditions at k=1 if(ibcz.eq.0) then do j=1,mp do i=1,np den=0.5*(3.*rho(i,j,1)-rho(i,j,2)) Kma=0.5*(Km(i,j,1)+Km(i,j,2)) f33(i,j,1) = den*Kma*f33(i,j,1) end do end do else do j=1,mp do i=1,np f33(i,j,1) = f33(i,j,L) end do end do endif Compute stress force compute z-component of stress force compute tau33=gi*G*tau33 + g13*G*tau13 + g23*G*tau23 at (i,j,k+-1/2) if (rightedge.eq.0) then call updatelr(f13,np,mp,l+1,np+1,mp,1) else call updatelr(f13,np+1,mp,l+1,np+1,mp,1) end if if (topedge.eq.0) then call updatebt(f23,np,mp,l+1,np,mp+1,1) else call updatebt(f23,np,mp+1,l+1,np,mp+1,1) end if do k=2,L do j=1,mp do i=1,np tau33 =gi(i,j)*f33(i,j,k) . +0.5*(gmul(k-1)+gmul(k))*s13(i,j)* . 0.5*(f13(i,j ,k)+f13(i+1,j ,k)) . +0.5*(gmul(k-1)+gmul(k))*s23(i,j)* . 0.5*(f23(i,j ,k)+f23(i ,j+1,k)) temp(i,j,k)=tau33 end do end do end do if(ibcz.eq.0) then do j=1,mp do i=1,np tau331 =gi(i,j)*f33(i,j,1) . +0.5*(3.*gmul(1)-gmul(2))*s13(i,j)* . 0.5*(f13(i,j ,1)+f13(i+1,j ,1)) . +0.5*(3.*gmul(1)-gmul(2))*s23(i,j)* . 0.5*(f23(i,j ,1)+f23(i ,j+1,1)) temp(i,j, 1 )=tau331 temp(i,j,L+1) = 2.*temp(i,j,L)-temp(i,j,L-1) scr1(i,j,1)=0.5*(temp(i,j,1)+temp(i,j,2)) !store for bcs end do end do else do j=1,mp do i=1,np temp(i,j, 1 ) = temp(i,j,L) temp(i,j,L+1) = temp(i,j,2) scr1(i,j,1)=0.5*(temp(i,j,1)+temp(i,j,2)) !store for bcs end do end do endif do k=1,L do j=1,mp do i=1,np fw(i,j,k) = fw(i,j,k) + . ( 0.5*tc*dxi*( f13(i+1,j ,k) + f13(i+1,j ,k+1) . - f13(i ,j ,k) - f13(i ,j ,k+1) ) . +0.5*tc*dyi*( f23(i ,j+1,k) + f23(i ,j+1,k+1) . - f23(i ,j ,k) - f23(i ,j ,k+1) )*j3 . + tc*dzi*(temp(i,j,k+1)-temp(i,j,k)) )/rho(i,j,k) end do end do end do if (itraj.eq.1) then do k=1,L do j=1,mp do i=1,np fo(i,j,k) = fo(i,j,k) + gi(i,j)*fw(i,j,k) end do end do end do end if compute x-component of stress force compute tau13=gi*G*tau13 + g13*G*tau11 + g23*G*tau12 at (i,j,k+-1/2) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(f11,np,mp,l,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(f11,np+1,mp,l,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(f11,np,mp+1,l,np+1,mp+1,1) else call updatelr(f11,np+1,mp+1,l,np+1,mp+1,1) end if if (rightedge.eq.0 .and. topedge.eq.0) then call update(f12,np,mp,l,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(f12,np+1,mp,l,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(f12,np,mp+1,l,np+1,mp+1,1) else call update(f12,np+1,mp+1,l,np+1,mp+1,1) end if do k=2,L do j=1,mp do i=1,np tau13 =0.5*gi(i,j)*(f13(i,j,k)+f13(i+1,j,k)) . +0.5*(gmul(k-1)+gmul(k))*s13(i,j)* . 0.25*( f11(i,j,k-1)+f11(i+1,j,k-1) . +f11(i,j,k )+f11(i+1,j,k ) ) . +0.5*(gmul(k-1)+gmul(k))*s23(i,j)* . 0.125*( f12(i,j ,k-1)+f12(i+1,j ,k-1) . +f12(i,j+1,k-1)+f12(i+1,j+1,k-1) . +f12(i,j ,k )+f12(i+1,j ,k ) . +f12(i,j+1,k )+f12(i+1,j+1,k ) ) temp(i,j,k)=tau13 end do end do end do complete with boundary condition if(ibcz.eq.0) then do j=1,mp ! tau13=stress*sin(a) - hx*tau33 do i=1,np hx=-s13(i,j)/gi(i,j)*zb !hx=-G*G13, at z=0 hy=-s23(i,j)/gi(i,j)*zb !hy=-G*G23, at z=0 hn=sqrt(1.+hx**2+hy**2) !===G*G33**1/2 taul=hn*tauw(i,j)*gi(i,j)*(u(i,j,1)+hx*w(i,j,1)) temp(i,j,1)=2.*(taul-hx*scr1(i,j,1))-temp(i,j,2) temp(i,j,l+1) = -temp(i,j,l) enddo enddo else do j=1,mp do i=1,np temp(i,j, 1 ) = temp(i,j,L) temp(i,j,L+1) = temp(i,j,2) enddo enddo endif do k=1,l do j=1,mp do i=1,np fu(i,j,k) = fu(i,j,k) + . ( tc*dxi*( f11(i+1,j ,k) - f11(i ,j ,k) ) . + 0.5*tc*dyi*( f12(i ,j+1,k) + f12(i+1,j+1,k) . - f12(i ,j ,k) - f12(i+1,j ,k) )*j3 . + tc*dzi*(temp(i,j,k+1)-temp(i,j,k)) )/rho(i,j,k) end do end do end do if (itraj.eq.1) then do k=1,l do j=1,mp do i=1,np g13=gmul(k)*s13(i,j) fo(i,j,k) = fo(i,j,k) + g13*fu(i,j,k) end do end do end do end if compute y-component of stress force compute tau23=gi*G*tau23 + g13*G*tau12 + g23*G*tau22 at (i,j,k+-1/2) if (topedge.eq.0) then call updatebt(f22,np,mp,l,np,mp+1,1) else call updatebt(f22,np,mp+1,l,np,mp+1,1) end if do k=2,l do j=1,mp do i=1,np tau23 =0.5*gi(i,j)*(f23(i,j,k)+f23(i,j+1,k)) . +0.5*(gmul(k-1)+gmul(k))*s13(i,j)* . 0.125*( f12(i,j ,k-1)+f12(i+1,j ,k-1) . + f12(i,j+1,k-1)+f12(i+1,j+1,k-1) . + f12(i,j ,k )+f12(i+1,j ,k ) . + f12(i,j+1,k )+f12(i+1,j+1,k ) ) . +0.5*(gmul(k-1)+gmul(k))*s23(i,j)* . 0.25* ( f22(i,j,k-1)+f22(i,j+1,k-1) . + f22(i,j,k )+f22(i,j+1,k ) ) temp(i,j,k)=tau23 end do end do end do if(ibcz.eq.0) then complete with boundary condition do j=1,mp ! tau23=stress*cos(a) - hy*tau33 do i=1,np hx=-s13(i,j)/gi(i,j)*zb !hx=-G*G13, at z=0 hy=-s23(i,j)/gi(i,j)*zb !hy=-G*G23, at z=0 hn=sqrt(1.+hx**2+hy**2) !===G*G33**1/2 taul=hn*tauw(i,j)*gi(i,j)*(v(i,j,1)+hy*w(i,j,1)) temp(i,j,1)=2.*(taul-hy*scr1(i,j,1))-temp(i,j,2) temp(i,j,l+1) = -temp(i,j,l) enddo enddo else do j=1,mp do i=1,np temp(i,j, 1 ) = temp(i,j,L) temp(i,j,L+1) = temp(i,j,2) enddo enddo endif do k=1,L do j=1,mp do i=1,np fv(i,j,k) = fv(i,j,k) + . (0.5*tc*dxi*( f12(i+1,j ,k) + f12(i+1,j+1,k) . - f12(i ,j ,k) - f12(i ,j+1,k) ) . + tc*dyi*( f22(i ,j+1,k) - f22(i ,j ,k) ) . + tc*dzi*(temp(i,j,k+1)-temp(i,j,k)))/rho(i,j,k) end do end do end do if (j3.eq.1) then if (itraj.eq.1) then do k=1,L do j=1,mp do i=1,np g23=gmul(k)*s23(i,j) fo(i,j,k) = fo(i,j,k) + g23*fv(i,j,k) end do end do end do end if end if if(noslip.eq.1) then #if (POLES == 0) if(leftedge.eq.1) then do k=1,l do j=1,mp c fu(1,j,k)=0. fv(1,j,k)=0. fw(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp c fu(np,j,k)=0. fv(np,j,k)=0. fw(np,j,k)=0. enddo enddo endif #endif c noslip lower boundary do j=1,mp do i=1,np fu(i,j,1)=0. fv(i,j,1)=0. fw(i,j,1)=0. c fu(i,j,l)=0. c fv(i,j,l)=0. c fw(i,j,l)=0. enddo enddo endif do k=1,l do j=1,mp do i=1,np fx(i,j,k)=fx(i,j,k)+2.*fu(i,j,k) fy(i,j,k)=fy(i,j,k)+2.*fv(i,j,k) fz(i,j,k)=fz(i,j,k)+2.*fw(i,j,k) enddo enddo enddo if(itraj.eq.1) then do k=1,l do j=1,mp do i=1,np fomeg(i,j,k)=fomeg(i,j,k)+2.*fo(i,j,k) enddo enddo enddo endif compute subgrid-scale forcings for scalar variables c note scr1,scr2,f33,and temp are work arrays and are destroyed. do k=1,l do j=1,mp do i=1,np th(i,j,k)=th(i,j,k)+the(i,j,k) enddo enddo enddo call lapdf(th,scr3,Km,Prinv,scr1,scr2,f33,temp,1) do k=1,l do j=1,mp do i=1,np ft(i,j,k)=ft(i,j,k)+2.*scr3(i,j,k) th(i,j,k)=th(i,j,k)-the(i,j,k) enddo enddo enddo call update(th,np,mp,l,np,mp,1) call update(fu,np,mp,l,np,mp,1) call update(fv,np,mp,l,np,mp,1) call update(fw,np,mp,l,np,mp,1) call update(ft,np,mp,l,np,mp,1) if(ichm.eq.1) then do ispc=1,nspc call lapdf(chm(1-ih,1-ih,1,ispc), . scr3,Km,Prinv,scr1,scr2,f33,temp,0) do k=1,l do j=1,mp do i=1,np fchm(i,j,k,ispc)=fchm(i,j,k,ispc)+2.*scr3(i,j,k) enddo enddo enddo call update(fchm(1-ih,1-ih,1,ispc),np,mp,l,np,mp,1) enddo endif #if (MOISTMOD > 0) if(moist.eq.1) then call lapdf(qv,scr3,Km,Prinv,scr1,scr2,f33,temp,-1) do k=1,l do j=1,mp do i=1,np fqv(i,j,k)=fqv(i,j,k)+2.*scr3(i,j,k) enddo enddo enddo call lapdf(qc,scr3,Km,Prinv,scr1,scr2,f33,temp,-2) do k=1,l do j=1,mp do i=1,np fqc(i,j,k)=fqc(i,j,k)+2.*scr3(i,j,k) enddo enddo enddo call lapdf(qr,scr3,Km,Prinv,scr1,scr2,f33,temp,-3) do k=1,l do j=1,mp do i=1,np fqr(i,j,k)=fqr(i,j,k)+2.*scr3(i,j,k) enddo enddo enddo call update(fqv,np,mp,l,np,mp,1) call update(fqc,np,mp,l,np,mp,1) call update(fqr,np,mp,l,np,mp,1) #if (MOISTMOD == 2) if(iceab.eq.1) then call lapdf(qia,scr3,Km,Prinv,scr1,scr2,f33,temp,-2) do k=1,l do j=1,mp do i=1,np fqia(i,j,k)=fqia(i,j,k)+2.*scr3(i,j,k) enddo enddo end do call lapdf(qib,scr3,Km,Prinv,scr1,scr2,f33,temp,-2) do k=1,l do j=1,mp do i=1,np fqib(i,j,k)=fqib(i,j,k)+2.*scr3(i,j,k) enddo enddo end do call update(fqia,np,mp,l,np,mp,1) call update(fqib,np,mp,l,np,mp,1) endif #endif endif #endif c #if (TIMEPLT == 1) call ttend(47) #endif return end subroutine stress0(u,v,w,th,qv,qc,qr,qia,qib,fx,fy,fz,fomeg, 1 fu,fv,fw,fo,ft,fqv,fqc,fqr,fqia,fqib,Prinv,Km,scr1) include 'param.nml' include 'msg.inc' real u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . fx(1-ih:np+ih, 1-ih:mp+ih, l), . fy(1-ih:np+ih, 1-ih:mp+ih, l), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . fu(1-ih:np+ih, 1-ih:mp+ih, l), . fv(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l), . fo(1-ih:np+ih, 1-ih:mp+ih, l), . ft(1-ih:np+ih, 1-ih:mp+ih, l), . Prinv(1-ih:np+ih, 1-ih:mp+ih, l), . Km(1-ih:np+ih, 1-ih:mp+ih, l), . scr1(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fomeg(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts) common/blank/ scr3(1-ih:np+ih, 1-ih:mp+ih, l), . scr2(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . f33(1-ih:np+ih, 1-ih:mp+ih, l), . scr12(1-ih:np+ih, 1-ih:mp+ih, l, 12) parameter(iblank=12*(np+2*ih)*(mp+2*ih)*l) parameter(idd1=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id12=(np+2*ih+1)*(mp+2*ih+1) *l) parameter(id22=(np+2*ih) *(mp+2*ih+1) *l) parameter(id23=(np+2*ih) *(mp+2*ih+1) *(l+1)) parameter(id13=(np+2*ih+1)*(mp+2*ih) *(l+1)) parameter(icr4=(np+2*ih+1)*(mp+2*ih+1) *(l+1)) parameter(ifree=iblank-idd1-id12-id22-id23-id13-icr4) common /stress2/ f11(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . f12(1-ih:np+ih+1, 1-ih:mp+ih+1, l), . f22(1-ih:np+ih, 1-ih:mp+ih+1, l), * f23(1-ih:np+ih, 1-ih:mp+ih+1, l+1), . f13(1-ih:np+ih+1, 1-ih:mp+ih, l+1), * temp(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) c Calculation of the RHS in the prognostic equations, c diffusion terms obtained using km from the TKE-equation (sub."tkefrc") c inputs include Prinv = 1/Pr/pri, Km, f11,...,f23, containing the six c components of the deformation tensor. scr1, scr2, scr3, and temp c are work arrays. c Output: fu,fv,fw,ft,fqv,fqc,fqr. c Note that the subroutine is called only when ivisc=1 and itke=1. c This subroutine calls subroutines lapdf to calculate diffusion terms. common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/stresd/ diagstr(8),ivis,irid,itstr common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/slip/ noslip common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm real den,Kma,tau13,tau23,tau33,tc #if (TIMEPLT == 1) call ttbeg(47) #endif c fourth order diffusion == - , + 2x lapdf c tc=-2. c simple Laplacian tc=2. c make sure to change bc in lapdf do 1 k=1,l do 1 j=1,mp do 1 i=1,np c Prinv(i,j,k)=1. c Km(i,j,k)=200. c Km(i,j,k)=100. c Km(i,j,k)= 50. c Km(i,j,k)= 25. c for stratified flows, different vertical diffusion from horizontal c Prinv(i,j,k)=1.e-30 c Km(i,j,k)=18257.4186 c Km(i,j,k)=89442.7191 Kmij=1.004e-6 Km(i,j,k)=Kmij u(i,j,k)=u(i,j,k)-ue(i,j,k) v(i,j,k)=v(i,j,k)-ve(i,j,k) 1 continue call lapdf(u,scr3,Km,Prinv,scr1,scr2,f33,temp,0) ccc call lapdf(scr3,scr3,Km,Prinv,scr1,scr2,f33,temp,0) if(noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp scr3(1,j,k)=0. enddo enddo endif c if(rightedge.eq.1) then c do k=1,l c do j=1,mp c scr3(np,j,k)=0. c enddo c enddo c endif endif do 10 k=1,l do 10 j=1,mp do 10 i=1,np fx(i,j,k)=fx(i,j,k)+tc*scr3(i,j,k) 10 u(i,j,k)=u(i,j,k)+ue(i,j,k) call lapdf(v,scr3,Km,Prinv,scr1,scr2,f33,temp,0) ccc call lapdf(scr3,scr3,Km,Prinv,scr1,scr2,f33,temp,0) if(noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp scr3(1,j,k)=0. enddo enddo endif c if(rightedge.eq.1) then c do k=1,l c do j=1,mp c scr3(np,j,k)=0. c enddo c enddo c endif endif do 11 k=1,l do 11 j=1,mp do 11 i=1,np fy(i,j,k)=fy(i,j,k)+tc*scr3(i,j,k) 11 v(i,j,k)=v(i,j,k)+ve(i,j,k) call lapdf(w,scr3,Km,Prinv,scr1,scr2,f33,temp,0) ccc call lapdf(scr3,scr3,Km,Prinv,scr1,scr2,f33,temp,0) if(noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp scr3(1,j,k)=0. enddo enddo endif c if(rightedge.eq.1) then c do k=1,l c do j=1,mp c scr3(np,j,k)=0. c enddo c enddo c endif endif do 12 k=1,l do 12 j=1,mp do 12 i=1,np 12 fz(i,j,k)=fz(i,j,k)+tc*scr3(i,j,k) compute subgrid-scale forcings for scalar variables c note scr1,scr2,f33,and temp are work arrays and are destroyed. call lapdf(th,scr3,Km,Prinv,scr1,scr2,f33,temp,0) ccc call lapdf(scr3,scr3,Km,Prinv,scr1,scr2,f33,temp,0) do 13 k=1,l do 13 j=1,mp do 13 i=1,np 13 ft(i,j,k)=ft(i,j,k)+tc*scr3(i,j,k) #if (MOISTMOD > 0) if(moist.eq.1) then call lapdf(qv,scr3,Km,Prinv,scr1,scr2,f33,temp,-1) do 14 k=1,l do 14 j=1,mp do 14 i=1,np 14 fqv(i,j,k)=fqv(i,j,k)+tc*scr3(i,j,k) call lapdf(qc,scr3,Km,Prinv,scr1,scr2,f33,temp,-2) do 15 k=1,l do 15 j=1,mp do 15 i=1,np 15 fqc(i,j,k)=fqc(i,j,k)+tc*scr3(i,j,k) call lapdf(qr,scr3,Km,Prinv,scr1,scr2,f33,temp,-3) do 16 k=1,l do 16 j=1,mp do 16 i=1,np 16 fqr(i,j,k)=fqr(i,j,k)+tc*scr3(i,j,k) endif #endif c #if (TIMEPLT == 1) call ttend(47) #endif return end #endif /* endif SGS == 1 */ #if (SGS == 2) subroutine dissip(ox,oy,oz,u0,v0,w0,th,qv,qc,qr,tke,fx,fy,fz,ft 1 ,fqv,fqc,fqr,ftke,fox,foy,foz,pfx,pfy,pfz,u1,v1,w1,ox1,oy1,oz1) include 'param.nml' include 'msg.inc' dimension ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . u0(1-ih:np+ih,1-ih:mp+ih,l), . v0(1-ih:np+ih,1-ih:mp+ih,l), . w0(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke) dimension fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . pfx(1-ih:np+ih,1-ih:mp+ih,l), . pfy(1-ih:np+ih,1-ih:mp+ih,l), . pfz(1-ih:np+ih,1-ih:mp+ih,l), . u1(1-ih:np+ih,1-ih:mp+ih,l), . v1(1-ih:np+ih,1-ih:mp+ih,l), . w1(1-ih:np+ih,1-ih:mp+ih,l), . ox1(1-ih:np+ih,1-ih:mp+ih,l), . oy1(1-ih:np+ih,1-ih:mp+ih,l), . oz1(1-ih:np+ih,1-ih:mp+ih,l) dimension us(1-ih:np+ih,1-ih:mp+ih,l), !variables for cycling . vs(1-ih:np+ih,1-ih:mp+ih,l), . ws(1-ih:np+ih,1-ih:mp+ih,l), . oxs(1-ih:np+ih,1-ih:mp+ih,l), . oys(1-ih:np+ih,1-ih:mp+ih,l), . ozs(1-ih:np+ih,1-ih:mp+ih,l), . ths(1-ih:np+ih,1-ih:mp+ih,l), . fts(1-ih:np+ih,1-ih:mp+ih,l) real *8 thdp(1-ih:np+ih,1-ih:mp+ih,l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), !CHECK LOCATION OF COSA . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/mihaistr/ acns,beta,dzb,hpsl,kst common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/sgscnst/ ceps,cL,cm,css,prndt common/stresd/ diagstr(8),ivis,irid,itstr common/dslip/ cdrgx(2),cdrgy(2),cdrgz(2), * tauxy(mp,l ,2),tauxz(mp,l ,2),tauyz(np,l ,2), * tauyx(np,l ,2),tauzx(np,mp,2),tauzy(np,mp,2), * hflz(np,mp,2), hflx(mp,l ,2), hfly(np,l ,2), * qflz(nmsp,mmsp,2), * qflx(mmsp,lms,2), * qfly(nmsp,lms,2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/slip/ noslip common/diffus/ sk(l),skr(l),sls common/refstprof/ trs(l),thrs(l),prs(l),rhors(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z #if (TIMEPLT == 1) call ttbeg(40) #endif c ... determine the number of iterations for viscous term pi=acos(-1.) dya=pi/float(m) ym=-pi/2.+(m-.5)*dya dli=1./dz**2+1./dy**2+1./(cos(ym)*dx)**2 dlstb=1./dli cstab=0.25*dti*dlstb c00 = maxval(sk) rtau=c00/cstab ntau=ifix(rtau+1.) dtau=dt/ntau rat=2.*(dtau/dt) c ------------------------------ c --- SPECIFY DRAG COEFFICIENTS cdrgx(1)=1. cdrgx(2)=1. cdrgy(1)=0. cdrgy(2)=0. cdrgz(1)=1. cdrgz(2)=1. c ------------------------------ c --- specify (eddy/molecular) kinematic viscosity abscl=5.7e3 * 3. do k=1,lkv do j=1-ih,mkvp+ih do i=1-ih,nkvp+ih rhon=1. tke(i,j,k)=sk(k)*rhon enddo enddo enddo call indexdef call normalv c treat radiative, momentum and temp. diffusion iradt=0 if(iradt.eq.1) then !treat radiative, momentum and temp. diffusion do k=1,l do j=1,mp do i=1,np us(i,j,k)=u0(i,j,k) vs(i,j,k)=v0(i,j,k) ws(i,j,k)=w0(i,j,k) oxs(i,j,k)=ox(i,j,k) oys(i,j,k)=oy(i,j,k) ozs(i,j,k)=oz(i,j,k) ths(i,j,k)=th(i,j,k) enddo enddo enddo DO itr=1,ntau call strainst(oxs,oys,ozs,us,vs,ws,pfy,pfz,tke) c call strainst(ox,oy,oz,u0,v0,w0,pfy,pfz,tke) call stressdv(u1,v1,w1,pfx,pfy,pfz) if(icylind.eq.1.and.noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp c u1(1,j,k)=0. v1(1,j,k)=0. w1(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp v1(np,j,k)=0. w1(np,j,k)=0. enddo enddo endif c noslip lower boundary do j=1,mp do i=1,np u1(i,j,1)=0. v1(i,j,1)=0. u1(i,j,l)=0. v1(i,j,l)=0. enddo enddo endif c ------------------------------ c ---- adjust momentum forcings for viscous effect do k=1,l do j=1,mp do i=1,np c fx(i,j,k)=fx(i,j,k)+2.*u1(i,j,k) c fy(i,j,k)=fy(i,j,k)+2.*v1(i,j,k) c fz(i,j,k)=fz(i,j,k)+2.*w1(i,j,k) fx(i,j,k)=fx(i,j,k)+rat*u1(i,j,k) fy(i,j,k)=fy(i,j,k)+rat*v1(i,j,k) fz(i,j,k)=fz(i,j,k)+rat*w1(i,j,k) if(itr.ne.ntau) then us(i,j,k)= us(i,j,k)+dtau*u1(i,j,k) vs(i,j,k)= vs(i,j,k)+dtau*v1(i,j,k) ws(i,j,k)= ws(i,j,k)+dtau*w1(i,j,k) g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) oxs(i,j,k)=g11*us(i,j,k)+g21*vs(i,j,k) oys(i,j,k)=g12*us(i,j,k)+g22*vs(i,j,k) ozs(i,j,k)=g13*us(i,j,k)+g23*vs(i,j,k)+g33*ws(i,j,k) oxs(i,j,k)=oxs(i,j,k)+strxd(i,j) oys(i,j,k)=oys(i,j,k)+stryd(i,j) ozs(i,j,k)=ozs(i,j,k)-gmul(k)*zsd(i,j)/zb*g33 . +(gmul(k)/zb-1.)*zhd(i,j)*g33 endif enddo enddo enddo ENDDO !itr=1,ntau endif !iradt if(itraj.eq.1) then ! if using RK time integration do k=1,l do j=1,mp do i=1,np g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ox1(i,j,k)=g11*u1(i,j,k)+g21*v1(i,j,k) oy1(i,j,k)=g12*u1(i,j,k)+g22*v1(i,j,k) oz1(i,j,k)=g13*u1(i,j,k)+g23*v1(i,j,k)+g33*w1(i,j,k) enddo enddo enddo if(tt.le.tend) call vstrhat(ox1,oy1,oz1,-1) do k=1,l do j=1,mp do i=1,np fox(i,j,k)=fox(i,j,k)+2.*ox1(i,j,k) foy(i,j,k)=foy(i,j,k)+2.*oy1(i,j,k) foz(i,j,k)=foz(i,j,k)+2.*oz1(i,j,k) enddo enddo enddo endif c ------------------------------ c ---- specify surface fluxes for diffusive scalar field (heat...) do j=1,mp do i=1,np hflz(i,j,1)= 0. hflz(i,j,2)= 0. enddo enddo do k=1,l do j=1,mp hflx(j,k,1)=0. hflx(j,k,2)=0. enddo enddo do k=1,l do i=1,np hfly(i,k,1)=0. hfly(i,k,2)=0. enddo enddo c ... working with full theta or just with perturbation c ifull=1 ifull=0 do k=1,l do j=1,mp do i=1,np ths(i,j,k)=th(i,j,k) enddo enddo enddo if(iradt.eq.1) then !treat radiative, momentum and temp. diffusion c ... determine the number of iterations for diffusion term pri=1./prndt c00 = pri*maxval(sk) rtau=c00/cstab ntau=ifix(rtau+1.) dtau=dt/ntau rat=2.*(dtau/dt) DO itr=1,ntau do k=1,lkv do j=1,mkvp do i=1,nkvp tke(i,j,k)=pri*sk(k)*trs(k)/the(i,j,k) thdp(i,j,k)=ifull*the(i,j,k) thdp(i,j,k)=thdp(i,j,k)+ths(i,j,k) ths(i,j,k)=thdp(i,j,k) enddo enddo enddo call fckflxdv(ths,v1,tke,pfx,pfy,pfz,hflx,hfly,hflz) do k=1,lkv do j=1,mkvp do i=1,nkvp c ft(i,j,k)=ft(i,j,k)+2.*v1(i,j,k)*the(i,j,k)/trs(k) ft(i,j,k)=ft(i,j,k)+rat*v1(i,j,k)*the(i,j,k)/trs(k) c division by rho is made in routine fckflxdv thdp(i,j,k)=thdp(i,j,k)-ifull*the(i,j,k) ths(i,j,k)=thdp(i,j,k) ths(i,j,k)= ths(i,j,k)+dtau*v1(i,j,k) enddo enddo enddo ENDDO !itr=1,ntau endif !iradt c ... determine the number of iterations for radiative diffusion term c00 = maxval(skr) rtau=c00/cstab ntau=ifix(rtau+1.) dtau=dt/ntau rat=2.*(dtau/dt) do k=1,lkv do j=1,mkvp do i=1,nkvp tke(i,j,k)=skr(k) enddo enddo enddo DO itr=1,ntau do k=1,lkv do j=1-ih,mkvp+ih do i=1-ih,nkvp+ih c u1(i,j,k)=trs(k)*(ifull+ths(i,j,k)/the(i,j,k)) u1(i,j,k)=trs(k)*(ifull+ths(i,j,k)/thrs(k)) enddo enddo enddo call fckflxdv(u1,v1,tke,pfx,pfy,pfz,hflx,hfly,hflz) do k=1,lkv do j=1,mkvp do i=1,nkvp c ft(i,j,k)=ft(i,j,k)+2.*v1(i,j,k)*the(i,j,k)/trs(k) c ft(i,j,k)=ft(i,j,k)+rat*v1(i,j,k)*the(i,j,k)/trs(k) ft(i,j,k)=ft(i,j,k)+rat*v1(i,j,k)*thrs(k)/trs(k) c division by rho is made in routine fckflxdv if(itr.ne.ntau) then ths(i,j,k)= ths(i,j,k)+dtau*v1(i,j,k) endif enddo enddo enddo ENDDO !itr=1,ntau #if (TIMEPLT == 1) call ttend(40) #endif return end subroutine dissis(ox,oy,oz,u0,v0,w0,th, qv,qc,qr,tke, fx,fy,fz,ft, 1 fqv,fqc,fqr,ftke,fox,foy,foz,pfx,pfy,pfz,u1,v1,w1,ox1,oy1,oz1) include 'param.nml' include 'msg.inc' dimension ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . u0(1-ih:np+ih,1-ih:mp+ih,l), . v0(1-ih:np+ih,1-ih:mp+ih,l), . w0(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke) dimension fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . pfx(1-ih:np+ih,1-ih:mp+ih,l), . pfy(1-ih:np+ih,1-ih:mp+ih,l), . pfz(1-ih:np+ih,1-ih:mp+ih,l), . u1(1-ih:np+ih,1-ih:mp+ih,l), . v1(1-ih:np+ih,1-ih:mp+ih,l), . w1(1-ih:np+ih,1-ih:mp+ih,l), . ox1(1-ih:np+ih,1-ih:mp+ih,l), . oy1(1-ih:np+ih,1-ih:mp+ih,l), . oz1(1-ih:np+ih,1-ih:mp+ih,l) dimension us(1-ih:np+ih,1-ih:mp+ih,l), !variables for cycling . vs(1-ih:np+ih,1-ih:mp+ih,l), . ws(1-ih:np+ih,1-ih:mp+ih,l), . oxs(1-ih:np+ih,1-ih:mp+ih,l), . oys(1-ih:np+ih,1-ih:mp+ih,l), . ozs(1-ih:np+ih,1-ih:mp+ih,l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), !CHECK LOCATION OF COSA . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/mihaistr/ acns,beta,dzb,hpsl,kst common/stresd/ diagstr(8),ivis,irid,itstr common/dslip/ cdrgx(2),cdrgy(2),cdrgz(2), * tauxy(mp,l ,2),tauxz(mp,l ,2),tauyz(np,l ,2), * tauyx(np,l ,2),tauzx(np,mp,2),tauzy(np,mp,2), * hflz(np,mp,2), hflx(mp,l ,2), hfly(np,l ,2), * qflz(nmsp,mmsp,2), * qflx(mmsp,lms,2), * qfly(nmsp,lms,2) common/dissbc/ cstab,c00,c0h,dlstb,dtah,dtau,ntah,ntau common/sgscnst/ ceps,cL,cm,css,prndt common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/slip/ noslip common/diffus/ sk(l),skr(l),sls common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/refstprof/ trs(l),thrs(l),prs(l),rhors(l) #if (TIMEPLT == 1) call ttbeg(40) #endif pi=acos(-1.) dya=pi/float(m) ym=-pi/2.+(m-.5)*dya dli=1./dz**2+1./dy**2+1./(cos(ym)*dx)**2 dlstb=1./dli cstab=0.25*dti*dlstb c00 =-1.e-10 do k=1,L c00=amax1(c00,sk(k)) enddo rtau=c00/cstab ntau=ifix(rtau+1.) dtau=dt/ntau ratq=2.*(dtau/dt) c0h=-1.e-10 do k=1,L c c0h=amax1(c0h,sk(k)*(trs(k)/the(1,1,k))) c0h=amax1(c0h,sk(k)) enddo c0h=c0h/prndt rtah=c0h/cstab ntah=ifix(rtah+1.) dtah=dt/ntah rath=2.*(dtah/dt) c ------------------------------ c --- SPECIFY DRAG COEFFICIENTS cdrgx(1)=0. cdrgx(2)=0. cdrgy(1)=0. cdrgy(2)=0. cdrgz(1)=0. cdrgz(2)=0. c ------------------------------ c --- specify (eddy/molecular) kinematic viscosity do k=1,lkv do j=1-ih,mkvp+ih do i=1-ih,nkvp+ih c rhon=1. c rhon=(rho(i,j,lkv-k+1)/rho(i,j,1))**2 c rhon=sqrt(rho(i,j,lkv-k+1)/rho(i,j,1)) c tke(i,j,k)=c00*rhon tke(i,j,k)=sk(k) enddo enddo enddo call indexdef call normalv do k=1,l do j=1,mp do i=1,np us(i,j,k)=u0(i,j,k) vs(i,j,k)=v0(i,j,k) ws(i,j,k)=w0(i,j,k) oxs(i,j,k)=ox(i,j,k) oys(i,j,k)=oy(i,j,k) ozs(i,j,k)=oz(i,j,k) enddo enddo enddo isclrdf=1 DO itr=1,ntau if(isclrdf.eq.0) then call strainst(oxs,oys,ozs,us,vs,ws,pfy,pfz,tke) call stressdv(u1,v1,w1,pfx,pfy,pfz) else do k=1,l do j=1,mp hflx(j,k,1)=0. hflx(j,k,2)=0. enddo enddo do k=1,l do i=1,np hfly(i,k,1)=0. hfly(i,k,2)=0. enddo enddo do j=1,mp do i=1,np hflz(i,j,1)= 0. hflz(i,j,2)= 0. enddo enddo c call fckflxdv_V(us,u1,tke,pfx,pfy,pfz,hflx,hfly,hflz) c call fckflxdv_V(vs,v1,tke,pfx,pfy,pfz,hflx,hfly,hflz) c call fckflxdv_V(ws,w1,tke,pfx,pfy,pfz,hflx,hfly,hflz) endif if(noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp v1(1,j,k)=0. w1(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp v1(np,j,k)=0. w1(np,j,k)=0. enddo enddo endif c noslip lower boundary do j=1,mp do i=1,np u1(i,j,1)=0. v1(i,j,1)=0. enddo enddo endif c ------------------------------ c ---- adjust momentum forcings for viscous effect do k=1,l do j=1,mp do i=1,np fx(i,j,k)=fx(i,j,k)+ratq*u1(i,j,k) fy(i,j,k)=fy(i,j,k)+ratq*v1(i,j,k) fz(i,j,k)=fz(i,j,k)+ratq*w1(i,j,k) if(itr.ne.ntau) then us(i,j,k)= us(i,j,k)+dtau*u1(i,j,k) vs(i,j,k)= vs(i,j,k)+dtau*v1(i,j,k) ws(i,j,k)= ws(i,j,k)+dtau*w1(i,j,k) g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) oxs(i,j,k)=g11*us(i,j,k)+g21*vs(i,j,k) oys(i,j,k)=g12*us(i,j,k)+g22*vs(i,j,k) ozs(i,j,k)=g13*us(i,j,k)+g23*vs(i,j,k)+g33*ws(i,j,k) oxs(i,j,k)=oxs(i,j,k)+strxd(i,j) oys(i,j,k)=oys(i,j,k)+stryd(i,j) ozs(i,j,k)=ozs(i,j,k)-gmul(k)*zsd(i,j)/zb*g33 . +(gmul(k)/zb-1.)*zhd(i,j)*g33 endif enddo enddo enddo if(itraj.eq.1) then ! if using RK time integration do k=1,l do j=1,mp do i=1,np g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ox1(i,j,k)=g11*u1(i,j,k)+g21*v1(i,j,k) oy1(i,j,k)=g12*u1(i,j,k)+g22*v1(i,j,k) oz1(i,j,k)=g13*u1(i,j,k)+g23*v1(i,j,k)+g33*w1(i,j,k) enddo enddo enddo if(tt.le.tend) call vstrhat(ox1,oy1,oz1,-1) do k=1,l do j=1,mp do i=1,np fox(i,j,k)=fox(i,j,k)+ratq*ox1(i,j,k) foy(i,j,k)=foy(i,j,k)+ratq*oy1(i,j,k) foz(i,j,k)=foz(i,j,k)+ratq*oz1(i,j,k) enddo enddo enddo endif ENDDO !itr=1,ntau c--------------------------------------- c diffusion of heat c--------------------------------------- c ---- specify surface fluxes for diffusive scalar field (heat...) do k=1,l do j=1,mp hflx(j,k,1)=0. hflx(j,k,2)=0. enddo enddo do k=1,l do i=1,np hfly(i,k,1)=0. hfly(i,k,2)=0. enddo enddo ifull=0. hflbt= sls/(cp*4*pi*rds**2)*ifull hfltp= sls/(cp*4*pi*(rds+(l-1)*dz)**2)*ifull do k=1,l do j=1,mp do i=1,np ws(i,j,k)=th(i,j,k)+ifull*the(i,j,k) us(i,j,k)=ws(i,j,k)*(trs(k)/the(i,j,k)) enddo enddo enddo DO itr=1,ntah do j=1,mp do i=1,np hflz(i,j,1)= 0. hflz(i,j,2)= 0. enddo enddo do k=1,l do j=1,mp do i=1,np tke(i,j,k)=skr(k) c tke(i,j,k)=skr(j,k) enddo enddo enddo call fckflxdv(us,vs,tke,pfx,pfy,pfz,hflx,hfly,hflz) do j=1,mp do i=1,np hflz(i,j,1)= hflbt hflz(i,j,2)= hfltp enddo enddo do k=1,lkv do j=1-ih,mkvp+ih do i=1-ih,nkvp+ih tke(i,j,k)=sk(k)*(trs(k)/the(i,j,k)) enddo enddo enddo call fckflxdv(ws,vs,tke,pfx,pfy,pfz,hflx,hfly,hflz) do k=1,l do j=1,mp do i=1,np vs(i,j,k)=vs(i,j,k)*(the(i,j,k)/trs(k)) ft(i,j,k)=ft(i,j,k)+rath*vs(i,j,k) if(itr.ne.ntah) then ws(i,j,k)= ws(i,j,k)+dtah*vs(i,j,k) us(i,j,k)=ws(i,j,k)*(trs(k)/the(i,j,k)) endif enddo enddo enddo ENDDO !itr=1,ntah #if (TIMEPLT == 1) call ttend(40) #endif return end subroutine balhfl(a,d) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, 2), . d(1-ih:np+ih, 1-ih:mp+ih, l), . tmp1(1-ih:np+ih, 1-ih:mp+ih), . tmp2(1-ih:np+ih, 1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc C#if (PARALLEL > 0) #if (SUMR16 == 1) real*16 sum #else c real*8 sum real sum #endif real globsum !modgs c real*8 globsum illim=1+ibcx*leftedge jllim=1+ibcy*botedge do j=1,mp do i=1,np tmp1(i,j)=0. tmp2(i,j)=0. enddo enddo do j=jllim,mp do i=illim,np tmp1(i,j)=a(i,j,1)*d(i,j,1) tmp2(i,j)=a(i,j,1)*d(i,j,l) enddo enddo if(ibcx.eq.0 .and. leftedge.eq.1) then do j=jllim,mp tmp1(1,j)=tmp1(1,j)-0.5*a(1,j,1)*d(1,j,1) tmp2(1,j)=tmp2(1,j)-0.5*a(1,j,1)*d(1,j,l) enddo endif if(ibcx.eq.0 .and. rightedge.eq.1) then do j=jllim,mp tmp1(np,j)=tmp1(np,j)-0.5*a(np,j,1)*d(np,j,1) tmp2(np,j)=tmp2(np,j)-0.5*a(np,j,1)*d(np,j,l) enddo endif if(ibcy.eq.0 .and. botedge.eq.1) then do i=illim,np tmp1(i,1)=tmp1(i,1)-0.5*a(i,1,1)*d(i,1,1) tmp2(i,1)=tmp2(i,1)-0.5*a(i,1,1)*d(i,1,l) enddo endif if(ibcy.eq.0 .and. topedge.eq.1) then do i=illim,np tmp1(i,mp)=tmp1(i,mp)-0.5*a(i,mp,1)*d(i,mp,1) tmp2(i,mp)=tmp2(i,mp)-0.5*a(i,mp,1)*d(i,mp,l) enddo endif sumbt=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,1, . illim,iulim,jllim,julim,1,1) sumtp=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,1, . illim,iulim,jllim,julim,1,1) do j=1,mp do i=1,np a(i,j,2)= a(i,j,1)*(sumbt/sumtp) enddo enddo return end subroutine dissipB(u0,v0,w0,tke,fx,fy,fz,pfx,pfy,pfz, . u1,v1,w1,ox1,oy1,oz1) include 'param.nml' include 'msg.inc' dimension u0(1-ih:np+ih,1-ih:mp+ih,l), . v0(1-ih:np+ih,1-ih:mp+ih,l), . w0(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv) dimension pfx(1-ih:np+ih,1-ih:mp+ih,l), . pfy(1-ih:np+ih,1-ih:mp+ih,l), . pfz(1-ih:np+ih,1-ih:mp+ih,l), . u1(1-ih:np+ih,1-ih:mp+ih,l), . v1(1-ih:np+ih,1-ih:mp+ih,l), . w1(1-ih:np+ih,1-ih:mp+ih,l), . ox1(1-ih:np+ih,1-ih:mp+ih,l), . oy1(1-ih:np+ih,1-ih:mp+ih,l), . oz1(1-ih:np+ih,1-ih:mp+ih,l) dimension us(1-ih:np+ih,1-ih:mp+ih,l), !variables for cycling . vs(1-ih:np+ih,1-ih:mp+ih,l), . ws(1-ih:np+ih,1-ih:mp+ih,l), . oxs(1-ih:np+ih,1-ih:mp+ih,l), . oys(1-ih:np+ih,1-ih:mp+ih,l), . ozs(1-ih:np+ih,1-ih:mp+ih,l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), !CHECK LOCATION OF COSA . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/stresd/ diagstr(8),ivis,irid,itstr common/dslip/ cdrgx(2),cdrgy(2),cdrgz(2), * tauxy(mp,l ,2),tauxz(mp,l ,2),tauyz(np,l ,2), * tauyx(np,l ,2),tauzx(np,mp,2),tauzy(np,mp,2), * hflz(np,mp,2), hflx(mp,l ,2), hfly(np,l ,2), * qflz(nmsp,mmsp,2), * qflx(mmsp,lms,2), * qfly(nmsp,lms,2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/slip/ noslip common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/diffus/ sk(l),skr(l),sls common/refstprof/ trs(l),thrs(l),prs(l),rhors(l) #if (TIMEPLT == 1) call ttbeg(40) #endif rhon=1.0 c rhon=100. c rhon=0.01 pi=acos(-1.) dya=pi/float(m) ym=-pi/2.+(m-.5)*dya dli=1./dz**2+1./dy**2+1./(cos(ym)*dx)**2 dlstb=1./dli cstab=0.25*dti*dlstb c00 =rhon*maxval(sk) rtau=c00/cstab ntau=ifix(rtau+1.) dtau=dt/ntau rat=2.*(dtau/dt) c print *,'rtau=',rtau,'cstab=',cstab,'ntau=',ntau c pause 'dissip' c ------------------------------ c --- SPECIFY DRAG COEFFICIENTS cdrgx(1)=0. cdrgx(2)=0. cdrgy(1)=0. cdrgy(2)=0. cdrgz(1)=0. cdrgz(2)=0. c ------------------------------ c --- specify (eddy/molecular) kinematic viscosity do k=1,lkv do j=1-ih,mkvp+ih do i=1-ih,nkvp+ih c rhon=(rho(i,j,lkv-k+1)/rho(i,j,1))**2 c rhon=sqrt(rho(i,j,lkv-k+1)/rho(i,j,1)) c tke(i,j,k)=c00*rhon c tke(i,j,k)=sk(k) tke(i,j,k)=sk(k)*rhon enddo enddo enddo call indexdef call normalv do k=1,l do j=1,mp do i=1,np us(i,j,k)=u0(i,j,k) vs(i,j,k)=v0(i,j,k) ws(i,j,k)=w0(i,j,k) g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) oxs(i,j,k)=g11*us(i,j,k)+g21*vs(i,j,k) oys(i,j,k)=g12*us(i,j,k)+g22*vs(i,j,k) ozs(i,j,k)=g13*us(i,j,k)+g23*vs(i,j,k)+g33*ws(i,j,k) enddo enddo enddo DO itr=1,ntau call strainst(oxs,oys,ozs,us,vs,ws,pfy,pfz,tke) call stressdv(u1,v1,w1,pfx,pfy,pfz) if(noslip.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp c u1(1,j,k)=0. v1(1,j,k)=0. w1(1,j,k)=0. enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp v1(np,j,k)=0. w1(np,j,k)=0. enddo enddo endif c noslip lower boundary do j=1,mp do i=1,np u1(i,j,1)=0. v1(i,j,1)=0. c u1(i,j,l)=0. c v1(i,j,l)=0. enddo enddo endif c ------------------------------ c ---- adjust momentum forcings for viscous effect do k=1,l do j=1,mp do i=1,np fx(i,j,k)=fx(i,j,k)+rat*u1(i,j,k) fy(i,j,k)=fy(i,j,k)+rat*v1(i,j,k) fz(i,j,k)=fz(i,j,k)+rat*w1(i,j,k) if(itr.ne.ntau) then us(i,j,k)= us(i,j,k)+dtau*u1(i,j,k) vs(i,j,k)= vs(i,j,k)+dtau*v1(i,j,k) ws(i,j,k)= ws(i,j,k)+dtau*w1(i,j,k) g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) oxs(i,j,k)=g11*us(i,j,k)+g21*vs(i,j,k) oys(i,j,k)=g12*us(i,j,k)+g22*vs(i,j,k) ozs(i,j,k)=g13*us(i,j,k)+g23*vs(i,j,k)+g33*ws(i,j,k) endif enddo enddo enddo c ------------------------------ ENDDO !itr=1,ntau do k=1,l do j=1,mp do i=1,np u1(i,j,k)=u0(i,j,k) v1(i,j,k)=v0(i,j,k) w1(i,j,k)=w0(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(40) #endif return end subroutine extremum(ugx,ugy,ugz,vgx,vgy,vgz,wgx,wgy,wgz) include 'param.nml' include 'msg.inc' dimension ugx(1-ih:np+ih,1-ih:mp+ih,l), * ugy(1-ih:np+ih,1-ih:mp+ih,l), * ugz(1-ih:np+ih,1-ih:mp+ih,0:l), * vgx(1-ih:np+ih,1-ih:mp+ih,l), * vgy(1-ih:np+ih,1-ih:mp+ih,l), * vgz(1-ih:np+ih,1-ih:mp+ih,0:l), * wgx(1-ih:np+ih,1-ih:mp+ih,l), * wgy(1-ih:np+ih,1-ih:mp+ih,l), * wgz(1-ih:np+ih,1-ih:mp+ih,0:l) umx=-1.e15 umn= 1.e15 vmx=-1.e15 vmn= 1.e15 wmx=-1.e15 wmn= 1.e15 il=1-leftedge do k=1,l do j=1,mp do i=il,np umx=amax1(umx,ugx(i,j,k)) umn=amin1(umn,ugx(i,j,k)) vmx=amax1(vmx,vgx(i,j,k)) vmn=amin1(vmn,vgx(i,j,k)) wmx=amax1(wmx,wgx(i,j,k)) wmn=amin1(wmn,wgx(i,j,k)) enddo enddo enddo umx=globmax(umx,1,1,1,1,1,1,1,1,1,1,1,1) umn=globmin(umn,1,1,1,1,1,1,1,1,1,1,1,1) vmx=globmax(vmx,1,1,1,1,1,1,1,1,1,1,1,1) vmn=globmin(vmn,1,1,1,1,1,1,1,1,1,1,1,1) wmx=globmax(wmx,1,1,1,1,1,1,1,1,1,1,1,1) wmn=globmin(wmn,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) print 201,umx,umn,vmx,vmn,wmx,wmn umx=-1.e15 umn= 1.e15 vmx=-1.e15 vmn= 1.e15 wmx=-1.e15 wmn= 1.e15 jb=1-botedge do k=1,l do j=jb,mp do i=1,np umx=amax1(umx,ugy(i,j,k)) umn=amin1(umn,ugy(i,j,k)) vmx=amax1(vmx,vgy(i,j,k)) vmn=amin1(vmn,vgy(i,j,k)) wmx=amax1(wmx,wgy(i,j,k)) wmn=amin1(wmn,wgy(i,j,k)) enddo enddo enddo umx=globmax(umx,1,1,1,1,1,1,1,1,1,1,1,1) umn=globmin(umn,1,1,1,1,1,1,1,1,1,1,1,1) vmx=globmax(vmx,1,1,1,1,1,1,1,1,1,1,1,1) vmn=globmin(vmn,1,1,1,1,1,1,1,1,1,1,1,1) wmx=globmax(wmx,1,1,1,1,1,1,1,1,1,1,1,1) wmn=globmin(wmn,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) print 202,umx,umn,vmx,vmn,wmx,wmn umx=-1.e15 umn= 1.e15 vmx=-1.e15 vmn= 1.e15 wmx=-1.e15 wmn= 1.e15 do k=0,l do j=1,mp do i=1,np umx=amax1(umx,ugz(i,j,k)) umn=amin1(umn,ugz(i,j,k)) vmx=amax1(vmx,vgz(i,j,k)) vmn=amin1(vmn,vgz(i,j,k)) wmx=amax1(wmx,wgz(i,j,k)) wmn=amin1(wmn,wgz(i,j,k)) if(umx.eq.ugz(i,j,k)) then iumx=i jumx=j kumx=k end if if(umn.eq.ugz(i,j,k)) then iumn=i jumn=j kumn=k end if enddo enddo enddo umxg=globmax(umx,1,1,1,1,1,1,1,1,1,1,1,1) umng=globmin(umn,1,1,1,1,1,1,1,1,1,1,1,1) vmxg=globmax(vmx,1,1,1,1,1,1,1,1,1,1,1,1) vmng=globmin(vmn,1,1,1,1,1,1,1,1,1,1,1,1) wmxg=globmax(wmx,1,1,1,1,1,1,1,1,1,1,1,1) wmng=globmin(wmn,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) then print 203,umxg,umng,vmxg,vmng,wmxg,wmng endif if(umx.eq.umxg) print*,mype,' umx: (i,j,k) = ',iumx,jumx,kumx if(umn.eq.umng) print*,mype,' umn: (i,j,k) = ',iumn,jumn,kumn 201 format(1x,'ugxmx, ugxmn:',2e11.4/ . 1x,'vgxmx, vgxmn:',2e11.4/ . 1x,'wgxmx, wgxmn:',2e11.4) 202 format(1x,'ugymx, ugymn:',2e11.4/ . 1x,'vgymx, vgymn:',2e11.4/ . 1x,'wgymx, wgymn:',2e11.4) 203 format(1x,'ugzmx, ugzmn:',2e11.4/ . 1x,'vgzmx, vgzmn:',2e11.4/ . 1x,'wgzmx, wgzmn:',2e11.4) return end subroutine strainst(ox,oy,oz,u,v,w,ug,vg,eta) C C ******************************************* c * computes strain rate & viscous stress * c * elements in generalized coordinates * C ******************************************* c c eij - initially covariant strain rates; c finally contravariant stresses c eta - kinematic viscosity c ox, oy, oz - contravariant "xbar,ybar,zbar" components of c velocities in transformed coordinates c u, v, w - physical "x,y,z" components of velocity c in physical coordinates c ug - auxilliary velocity u*(gamma*cos(phi)) c v2 - auxilliary velocity v*gamma c C ******************************************* include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . ug(1-ih:np+ih,1-ih:mp+ih,l), . vg(1-ih:np+ih,1-ih:mp+ih,l), . eta(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . etai( nkvp, mkvp, lkv) common/strainc/ e11(1-ih:np+ih,1-ih:mp+ih,L), * e12(1-ih:np+ih,1-ih:mp+ih,L), * e13(1-ih:np+ih,1-ih:mp+ih,L), * e21(1-ih:np+ih,1-ih:mp+ih,L), * e22(1-ih:np+ih,1-ih:mp+ih,L), * e23(1-ih:np+ih,1-ih:mp+ih,L), * e31(1-ih:np+ih,1-ih:mp+ih,L), * e32(1-ih:np+ih,1-ih:mp+ih,L), * e33(1-ih:np+ih,1-ih:mp+ih,L), * e11bx(mp,l,2),e11by(np,l,2),e11bz(np,mp,2), * e12bx(mp,l,2),e12by(np,l,2),e12bz(np,mp,2), * e13bx(mp,l,2),e13by(np,l,2),e13bz(np,mp,2), * e21bx(mp,l,2),e21by(np,l,2),e21bz(np,mp,2), * e22bx(mp,l,2),e22by(np,l,2),e22bz(np,mp,2), * e23bx(mp,l,2),e23by(np,l,2),e23bz(np,mp,2), * e31bx(mp,l,2),e31by(np,l,2),e31bz(np,mp,2), * e32bx(mp,l,2),e32by(np,l,2),e32bz(np,mp,2), * e33bx(mp,l,2),e33by(np,l,2),e33bz(np,mp,2) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iarrl1=(np+2*ih)*(mp+2*ih)*(l+1)) ! size of ugz,vgz,wgz parameter(iarrrh=(np+2)*(mp+2)*(l+2)) ! size of rh parameter(ifree=10*iarray-3*iarrl1-iarrrh) common/blank/ * ugx(1-ih:np+ih,1-ih:mp+ih,l), * ugy(1-ih:np+ih,1-ih:mp+ih,l), * ugz(1-ih:np+ih,1-ih:mp+ih,0:l), * vgx(1-ih:np+ih,1-ih:mp+ih,l), * vgy(1-ih:np+ih,1-ih:mp+ih,l), * vgz(1-ih:np+ih,1-ih:mp+ih,0:l), * wgx(1-ih:np+ih,1-ih:mp+ih,l), * wgy(1-ih:np+ih,1-ih:mp+ih,l), * wgz(1-ih:np+ih,1-ih:mp+ih,0:l), * rh(0:np+1,0:mp+1,0:l+1),src(ifree) common/indexpar/ imm(np),ipp(np), * jmm(mp),jpp(mp), * kmm(l ),kpp(l ), * ibox,iboy,iboz common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), !CHECK LOCATION OF COSA . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/normals/ tnxx(mp,l ,2),tnxy(mp,l ,2),tnxz(mp,l ,2), * tnyx(np,l ,2),tnyy(np,l ,2),tnyz(np,l ,2), * tnzx(np,mp,2),tnzy(np,mp,2),tnzz(np,mp,2) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/dslip/ cdrgx(2),cdrgy(2),cdrgz(2), * tauxy(mp,l ,2),tauxz(mp,l ,2),tauyz(np,l ,2), * tauyx(np,l ,2),tauzx(np,mp,2),tauzy(np,mp,2), * hflz(np,mp,2), hflx(mp,l ,2), hfly(np,l ,2), * qflz(nmsp,mmsp,2), * qflx(mmsp,lms,2), * qfly(nmsp,lms,2) common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/slip/ noslip common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/stresd/ diagstr(8),ivis,irid,itstr common/cmoist/ rv,t00,ee0,hlat #if (TIMEPLT == 1) call ttbeg(41) #endif compute some local constants ep=1.e-15 !bulk viscosity: Stoke's hypothesis c NOTE: 2nd law requires these are only MINIMUM values if(j3.eq.1) dii=-2./3. if(j3.eq.0) dii=-2./2. j3t=j3 !for eddy viscosity j3t may be set to 1 ied=0 !ied 0,1 for 1 and 2d representation of edges do k=1,l do j=1,mp do i=1,np etai(i,j,k)=1./amax1(eta(i,j,k),ep) enddo enddo enddo if(tt.le.tend) call vstrhat(ox,oy,oz, 1) ! make solendoidal vel. call update(u,np,mp,l,np,mp,iup) call update(v,np,mp,l,np,mp,iup) call update(w,np,mp,l,np,mp,iup) call update2(ox,np,mp,l,np,mp,iup) call update2(oy,np,mp,l,np,mp,iup) call update2(oz,np,mp,l,np,mp,iup) c initialize output variables #if (POLES == 0) illim= 0-(iupx-1)*leftedge ! iulim=np+1+(iupx-1)*rightedge ! fill additional point jllim= 1-j3*(1+(iupy-1)*botedge) ! when ibcx=1 or ibcy=1 julim=mp+j3*(1+(iupy-1)*topedge) ! #else illim= 0 iulim=np+1 jllim= 1-j3 julim=mp+j3 #endif do k=1,l do j=jllim,julim do i=illim,iulim ug(i,j,k)=u(i,j,k)* . (1-icylind)*(cosa(i,j)*gmm(i,j,k))+icylind*1. ! update u,v,cosa,gmm vg(i,j,k)=v(i,j,k)*gmm(i,j,k) ! before this loop enddo enddo enddo #if (POLES == 0) illim= 0+leftedge iulim=np+1-rightedge jllim= 1-j3*(1-botedge) julim=mp+j3*(1-topedge) #endif do k=1,l do j=jllim,julim do i=illim,iulim rh(i,j,k)=rho(i,j,k) ! rho must be updated enddo enddo enddo #if (POLES == 0) c extend rho if(ibcx.eq.0) then if(leftedge.eq.1) then do k=1,l do j=jllim,julim rh( 0 ,j,k)=rh(1 ,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=jllim,julim rh(np+1,j,k)=rh(np,j,k) enddo enddo endif else if(leftedge.eq.1) then do k=1,l do j=jllim,julim rh( 0 ,j,k)=rho(-1 ,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=jllim,julim rh(np+1,j,k)=rho(np+2,j,k) enddo enddo endif endif if(ibcy.eq.0) then if(botedge.eq.1) then do k=1,l do i=0,np+1 rh(i,1-j3,k)=rh(i,1,k) enddo enddo endif if(topedge.eq.1) then do k=1,l do i=0,np+1 rh(i,mp+j3,k)=rh(i,mp,k) enddo enddo endif else if(botedge.eq.1) then do k=1,l do i=illim,iulim rh(i,1-j3,k)=rho(i,1-2*j3,k) enddo enddo if(leftedge.eq.1) then do k=1,l rh(0,1-j3,k)=rho(-1,1-2*j3,k) enddo endif if(rightedge.eq.1) then do k=1,l rh(np+1,1-j3,k)=rho(np+2,1-2*j3,k) enddo endif endif if(topedge.eq.1) then do k=1,l do i=illim,iulim rh(i,mp+j3,k)=rho(i,mp+2*j3,k) enddo enddo if(leftedge.eq.1) then do k=1,l rh(0,mp+j3,k)=rho(-1,mp+2*j3,k) enddo endif if(rightedge.eq.1) then do k=1,l rh(np+1,mp+j3,k)=rho(np+2,mp+2*j3,k) enddo endif endif endif #endif do j=0,mp+1 do i=0,np+1 rh(i,j, 0 )=ibcz*rh(i,j,l-1)+(1-ibcz)*rh(i,j,1) rh(i,j,l+1)=ibcz*rh(i,j, 2 )+(1-ibcz)*rh(i,j,l) enddo enddo c ---------------------------------------------- c --- initialize staggered velocity derivatives c ---------------------------------------------- c c --- x-gradients do k=1,L do j=1,mp #if (POLES == 0) do i=0+leftedge,np-rightedge #else do i=0,np #endif ugx(i,j,k)= dxi*(ug(i+1,j,k)-ug(i,j,k)) vgx(i,j,k)= dxi*(vg(i+1,j,k)-vg(i,j,k)) wgx(i,j,k)= dxi*( w(i+1,j,k)- w(i,j,k)) enddo enddo enddo #if (POLES == 0) if(ibcx.eq.0) then if(leftedge.eq.1) then do k=1,L do j=1,mp ugx(0,j,k)= ugx(1,j,k) vgx(0,j,k)= vgx(1,j,k) wgx(0,j,k)= wgx(1,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,L do j=1,mp ugx(np,j,k)= ugx(np-1,j,k) vgx(np,j,k)= vgx(np-1,j,k) wgx(np,j,k)= wgx(np-1,j,k) enddo enddo endif else if(leftedge.eq.1) then do k=1,L do j=1,mp ugx(0,j,k)= dxi*(ug(1,j,k)-ug(-1,j,k)) vgx(0,j,k)= dxi*(vg(1,j,k)-vg(-1,j,k)) wgx(0,j,k)= dxi*( w(1,j,k)- w(-1,j,k)) enddo enddo endif if(rightedge.eq.1) then do k=1,L do j=1,mp ugx(np,j,k)= dxi*(ug(np+2,j,k)-ug(np,j,k)) vgx(np,j,k)= dxi*(vg(np+2,j,k)-vg(np,j,k)) wgx(np,j,k)= dxi*( w(np+2,j,k)- w(np,j,k)) enddo enddo endif endif #endif c --- y-gradients do k=1,L #if (POLES == 0) do j=0,mp-j3*topedge #else do j=0,mp #endif do i=1,np ugy(i,j,k)= dyi*(ug(i,j+j3,k)-ug(i,j,k)) vgy(i,j,k)= dyi*(vg(i,j+j3,k)-vg(i,j,k)) wgy(i,j,k)= dyi*( w(i,j+j3,k)- w(i,j,k)) enddo enddo enddo #if (POLES == 0) if(ibcy.eq.0) then if(botedge.eq.1) then do k=1,L do i=1,np ugy(i,0,k)= ugy(i,1,k) vgy(i,0,k)= vgy(i,1,k) wgy(i,0,k)= wgy(i,1,k) enddo enddo endif if(topedge.eq.1) then do k=1,L do i=1,np ugy(i,mp,k)= ugy(i,mp-j3,k) vgy(i,mp,k)= vgy(i,mp-j3,k) wgy(i,mp,k)= wgy(i,mp-j3,k) enddo enddo endif else if(botedge.eq.1) then do k=1,L do i=1,np ugy(i,0,k)= dyi*(ug(i,1,k)-ug(i,1-2*j3,k)) vgy(i,0,k)= dyi*(vg(i,1,k)-vg(i,1-2*j3,k)) wgy(i,0,k)= dyi*( w(i,1,k)- w(i,1-2*j3,k)) enddo enddo endif if(topedge.eq.1) then do k=1,L do i=1,np ugy(i,mp,k)= dyi*(ug(i,mp+2*j3,k)-ug(i,mp,k)) vgy(i,mp,k)= dyi*(vg(i,mp+2*j3,k)-vg(i,mp,k)) wgy(i,mp,k)= dyi*( w(i,mp+2*j3,k)- w(i,mp,k)) enddo enddo endif endif #endif c --- z-gradients do k=1,L-1 do j=1,mp do i=1,np ugz(i,j,k)= dzi*(ug(i,j,k+1)-ug(i,j,k)) vgz(i,j,k)= dzi*(vg(i,j,k+1)-vg(i,j,k)) wgz(i,j,k)= dzi*( w(i,j,k+1)- w(i,j,k)) enddo enddo enddo klt=L*(1-ibcz) krt=L*ibcz do j=1,mp do i=1,np ugz(i,j,klt)= ugz(i,j,l-1) ugz(i,j,krt)= ugz(i,j, 1 ) vgz(i,j,klt)= vgz(i,j,l-1) vgz(i,j,krt)= vgz(i,j, 1 ) wgz(i,j,klt)= wgz(i,j,l-1) wgz(i,j,krt)= wgz(i,j, 1 ) enddo enddo call updatebtw(ugx,0,np,1,mp,l,1,np,1,mp,iupy) call updatebtw(vgx,0,np,1,mp,l,1,np,1,mp,iupy) ! call updatebtw(wgx,0,np,1,mp,l,1,np,1,mp,iupy) ! call updatelrw(ugy,1,np,0,mp,l,1,np,1,mp,iupx) ! call updatelrw(vgy,1,np,0,mp,l,1,np,1,mp,iupx) call updatelrw(wgy,1,np,0,mp,l,1,np,1,mp,iupx) ! call update(ugz,np,mp,l+1,np,mp,iup) call update(vgz,np,mp,l+1,np,mp,iup) call update(wgz,np,mp,l+1,np,mp,iup) c ---------------------------------------------- c --- completes staggered velocity derivatives with simple bcs c write (6,*) '**** strain: after initializations ****' c call extremum(ugx,ugy,ugz,vgx,vgy,vgz,wgx,wgy,wgz) c ---------------------------------------------- c ---------------------------------------------- c --- compute surface vel. derivatives using drag c ---------------------------------------------- #if (POLES == 0) c --- left and right surfaces IF(IBCX.EQ.0) THEN IF(icylind.eq.1.and.noslip.eq.1) THEN ! utilize noslip BC do i=1,np,np-1 ! values are 1 or np if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then isign=(np+1-2*i)/(np-1) ! values are 1 or -1 im=i+(np+1-2*i)/(np-1) ! values are 2 or np-1 iu=i+2*isign ! values are 3 or np-2 is=(i-1)/(np-1)*np ! values are 0 or 1 do j=1+j3-ibcy,mp-j3+ibcy do k=2-ibcz,l-1+ibcz vgx(is,j,k)=-(2.*vg(i,j,k)-3.*vg(im,j,k)+vg(iu,j,k))*dxi*isign*j3 wgx(is,j,k)=-(2.* w(i,j,k)-3.* w(im,j,k)+ w(iu,j,k))*dxi*isign end do end do endif end do ELSE ! utilize drag force law (partial or full slip) j1ed=1+(j3-ibcy)*botedge*ied !ied option j2ed=mp-(j3-ibcy)*topedge*ied k1ed=1+(1-ibcz)*ied k2ed=l+(ibcz-1)*ied do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np is=(i-1)/(np-1)*np ik=((np-2)*i+1)/(np-1) isign=(np+1-2*i)/(np-1) c --- compute vgx and wgx on left and right surfaces do 10 j=j1ed,j2ed do 10 k=k1ed,k2ed c do 10 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge c do 10 k=2-ibcz,l-1+ibcz gf110=(1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1. gf11=strxx(i,j) gf12=stryx(i,j) gf13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gf21=strxy(i,j) gf22=stryy(i,j) gf23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) gf33=gi(i,j)*gmus(k) gnr=sqrt(1.+gf21**2) pnx= 1./gnr*isign ! components of unit normal pny=gf21/gnr*isign pnz= 0.*isign vln=u(i,j,k)*pnx+v(i,j,k)*pny+w(i,j,k)*pnz !normal vel. vlt=max(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2-vln**2,0.0) vlt=sqrt(vlt) !tangent vel. tauxy(j,k,ii)=cdrgx(ii)*vlt*(v(i,j,k)-vln*pny) !drag force y tauxz(j,k,ii)=cdrgx(ii)*vlt*(w(i,j,k)-vln*pnz) !drag force z drhdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k )) + /(rh(i+1,j ,k )+rh(i-1,j ,k )+ep) drhdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k )) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k )+ep) drhdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcn=-ox(i,j,k)*drhdxb-oy(i,j,k)*drhdyb-oz(i,j,k)*drhdzb !dilatation ay1=gf11*pnx+2.*gf21*pny*gf110/gmm(i,j,k) az2=gf11*pnx+gf21*pny*gf110/gmm(i,j,k) ugx0=0.5*(ugx(i,j,k)+ugx(i-1,j ,k )) ugy0=0.5*(ugy(i,j,k)+ugy(i ,j-j3,k )) ugz0=0.5*(ugz(i,j,k)+ugz(i ,j ,k-1)) vgy0=0.5*(vgy(i,j,k)+vgy(i ,j-j3,k )) vgz0=0.5*(vgz(i,j,k)+vgz(i ,j ,k-1)) wgy0=0.5*(wgy(i,j,k)+wgy(i ,j-j3,k )) wgz0=0.5*(wgz(i,j,k)+wgz(i ,j ,k-1)) ry=tauxy(j,k,ii)*gmm(i,j,k)*gf110*etai(i,j,k) . -dii*pny*dvcn*gmm(i,j,k)*gf110*j3t c ry=tauxy(j,k,ii)*gmm(i,j,k)*gf110/eta(i,j,k) c . -dii*pny*dvcn*gmm(i,j,k)*gf110 . -pnx*(gf21*ugx0+gf22*ugy0+gf23*ugz0+gf12*vgy0+gf13*vgz0) . -2.*pny*gf110*(gf22*vgy0+gf23*vgz0)/gmm(i,j,k) . -rdsi*(2.*pnx*u(i,j,k)*gmm(i,j,k)*sina(i,j) . +2.*pny*w(i,j,k)*gmm(i,j,k)*cosa(i,j))*(1-icylind) . -icylind*rdsi*(2.*pny*u(i,j,k)-pnx*v(i,j,k)) rz=tauxz(j,k,ii)*gf110*etai(i,j,k) c rz=tauxz(j,k,ii)*gf110/eta(i,j,k) . -pnx*(gf33*ugz0+gf12*wgy0+gf13*wgz0) . -pny*gf110*(gf33*vgz0+gf22*wgy0+gf23*wgz0)/gmm(i,j,k) . +rdsi*(2.*pnx*u(i,j,k)*cosa(i,j) . +2.*pny*v(i,j,k)*cosa(i,j))*(1-icylind) vgx0=ry/ay1*j3 ! d(vg)/dxb at surface wgx0=rz/az2 ! d(wg)/dxb at surface vgx(is,j,k)=2.*vgx0-vgx(ik,j,k)*j3 wgx(is,j,k)=2.*wgx0-wgx(ik,j,k) 10 continue endif enddo END IF ! noslip END IF c --- front and back surfaces IF(IBCY.EQ.0.and.J3.EQ.1) THEN IF(noslip.eq.1) THEN ! utilize noslip BC do j=1,mp,mp-j3 ! values are 1 or np if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jsign=(mp+1-2*j)/(mp-1) ! values are 1 or -1 jm=j+ jsign ! values are 2 or mp-1 ju=j+2*jsign ! values are 3 or mp-2 js=(j-1)/(mp-1)*mp ! values are 0 or mp do i=1,np do k=1,l ugy(i,js,k)=-(2.*vg(i,j,k)-3.*vg(i,jm,k)+vg(i,ju,k))*dyi*jsign wgy(i,js,k)=-(2.* w(i,j,k)-3.* w(i,jm,k)+ w(i,ju,k))*dyi*jsign end do end do endif end do ELSE ! utilize drag force law (partial or full slip) i1ed= 1+(1-ibcx)*leftedge*ied !ied option i2ed=np-(1-ibcx)*rightedge*ied k1ed=1+(1-ibcz)*ied k2ed=l+(ibcz-1)*ied do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp js=(j-j3)/(mp-j3)*mp jk=((mp-1-j3)*j+1)/(mp-j3) jsign=(mp+1-2*j)/(mp-1) c --- compute ugy and wgy on front and back surfaces do 20 k=k1ed,k2ed do 20 i=i1ed,i2ed c do 20 k=2-ibcz,l-1+ibcz c do 20 i=1+(1-ibcx)*leftedge,np-(1-ibcx)*rightedge gf11=strxx(i,j) gf12=stryx(i,j) gf13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gf21=strxy(i,j) gf22=stryy(i,j) gf23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) gf33=gi(i,j)*gmus(k) gnr=sqrt(gf12**2+1.) pnx=gf12/gnr*jsign ! components of unit normal pny= 1./gnr*jsign pnz= 0.*jsign vln=u(i,j,k)*pnx+v(i,j,k)*pny+w(i,j,k)*pnz !normal vel. vlt=max(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2-vln**2,0.0) vlt=sqrt(vlt) !tangent vel. tauyx(i,k,jj)=cdrgy(jj)*vlt*(u(i,j,k)-vln*pnx) !drag force x tauyz(i,k,jj)=cdrgy(jj)*vlt*(w(i,j,k)-vln*pnz) !drag force z drhdxb=dxi*(rh(i+1,j,k)-rh(i-1,j,k)) + /(rh(i+1,j,k)+rh(i-1,j,k)+ep) drhdyb=dyi*(rh(i,j+j3,k)-rh(i,j-j3,k)) + /(rh(i,j+j3,k)+rh(i,j-j3,k)+ep) drhdzb=dzi*(rh(i,j,k+1)-rh(i,j,k-1)) + /(rh(i,j,k+1)+rh(i,j,k-1)+ep) dvcn=-ox(i,j,k)*drhdxb-oy(i,j,k)*drhdyb-oz(i,j,k)*drhdzb !dilatation ax1=2.*gf12*pnx/cosa(i,j)+gf22*pny az2=gf12*pnx/cosa(i,j)+gf22*pny ugx0=0.5*(ugx(i,j,k)+ugx(i-1,j ,k )) ugz0=0.5*(ugz(i,j,k)+ugz(i ,j ,k-1)) vgx0=0.5*(vgx(i,j,k)+vgx(i-1,j ,k )) vgy0=0.5*(vgy(i,j,k)+vgy(i ,j-j3,k )) vgz0=0.5*(vgz(i,j,k)+vgz(i ,j ,k-1)) wgx0=0.5*(wgx(i,j,k)+wgx(i-1,j ,k )) wgz0=0.5*(wgz(i,j,k)+wgz(i ,j ,k-1)) rx=tauyx(i,k,jj)*gmm(i,j,k)**2*cosa(i,j)*etai(i,j,k) c rx=tauyx(i,k,jj)*gmm(i,j,k)**2*cosa(i,j)/eta(i,j,k) . -dii*pnx*dvcn*gmm(i,j,k)**2*cosa(i,j) . -2.*pny*gmm(i,j,k)*sina(i,j)*rdsi*u(i,j,k) . -2.*pnx*rdsi*gmm(i,j,k)*cosa(i,j)* . (w(i,j,k)-v(i,j,k)*tnga(i,j)) . -2.*pnx*(gf11*ugx0+gf13*ugz0)/cosa(i,j) . -pny*(gf11*vgx0+gf12*vgy0+gf13*vgz0+gf21*ugx0+gf23*ugz0) rz=tauyz(i,k,jj)*gmm(i,j,k)*etai(i,j,k) c rz=tauyz(i,k,jj)*gmm(i,j,k)/eta(i,j,k) . +2.*rdsi*(pnx*u(i,j,k)+pny*v(i,j,k)) . -pny*(gf21*wgx0+gf23*wgz0+gf33*vgz0) . -pnx*(gf11*wgx0+gf13*wgz0+gf33*ugz0)/cosa(i,j) ugy0=rx/ax1*j3 ! d(ug)/dyb at surface wgy0=rz/az2*j3 ! d(wg)/dyb at surface ugy(i,js,k)=2.*ugy0-ugy(i,jk,k) wgy(i,js,k)=2.*wgy0-wgy(i,jk,k) 20 continue endif enddo END IF !noslip END IF #endif c --- bottom and top surfaces IF(IBCZ.EQ.0) THEN ! IF(icylind.eq.1.and.noslip.eq.1) THEN ! utilize noslip BC ! do k=1,l,l-1 do k=1,1,1 ! only do lower surface ksign=(l+1-2*k)/(l-1) km=k+(l+1-2*k)/(l-1) ! values are 2 or np-1 ku=k+2*ksign ! values are 3 or np-2 ks=(k-1)/(l-1)*l ! values are 0 or 1 do j=1,mp do i=1,np ugz(i,j,ks)=-(2.*ug(i,j,k)-3.*ug(i,j,km)+ug(i,j,ku))*dzi*ksign vgz(i,j,ks)=-(2.*vg(i,j,k)-3.*vg(i,j,km)+vg(i,j,ku))*dzi*ksign*j3 end do end do enddo ! ELSE ! use drag force calculation ! special Nils ! do 30 k=1,l,l-1 i1ed= 1+(1-ibcx)*leftedge*ied !ied option i2ed=np-(1-ibcx)*rightedge*ied j1ed=1+(j3-ibcy)*botedge*ied !ied option j2ed=mp-(j3-ibcy)*topedge*ied do 30 k=l,l,l-1 ! only do top kk=1+k/l ks=(k-1)/(l-1)*l ki=((l-2)*k+1)/(l-1) ksign=(l+1-2*k)/(l-1) c --- compute ugz and vgz on bottom and top surfaces #if (POLES == 0) do 30 j=j1ed,j2ed do 30 i=i1ed,i2ed c do 30 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge c do 30 i=1+(1-ibcx)*leftedge,np-(1-ibcx)*rightedge #else do 30 j=1,mp do 30 i=1,np #endif gf110=(1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1. gf11=strxx(i,j) gf12=stryx(i,j) gf13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gf21=strxy(i,j) gf22=stryy(i,j) gf23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) gf33=gi(i,j)*gmus(k) zsx=-gf13/gf33 zsy=-gf23/gf33 gnr=sqrt(1.+zsx**2+zsy**2) pnx=-zsx/gnr*ksign ! components of unit normal pny=-zsy/gnr*ksign pnz= 1./gnr*ksign vln=u(i,j,k)*pnx+v(i,j,k)*pny+w(i,j,k)*pnz !normal vel. vlt=max(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2-vln**2,0.0) vlt=sqrt(vlt) !tangent vel. tauzx(i,j,kk)=cdrgz(kk)*vlt*(u(i,j,k)-vln*pnx) !drag force x tauzy(i,j,kk)=cdrgz(kk)*vlt*(v(i,j,k)-vln*pny) !drag force y drhdxb=dxi*(rh(i+1,j,k)-rh(i-1,j,k)) + /(rh(i+1,j,k)+rh(i-1,j,k)+ep) drhdyb=dyi*(rh(i,j+j3,k)-rh(i,j-j3,k)) + /(rh(i,j+j3,k)+rh(i,j-j3,k)+ep) drhdzb=dzi*(rh(i,j,k+1)-rh(i,j,k-1)) + /(rh(i,j,k+1)+rh(i,j,k-1)+ep) dvcn=-ox(i,j,k)*drhdxb-oy(i,j,k)*drhdyb-oz(i,j,k)*drhdzb !dilatation ax1=2.*gf13*pnx/gf110+gf23*pny/gmm(i,j,k) . +gf33*pnz ax2=gf13*pny/gmm(i,j,k) ay1=gf23*pnx/gf110 ay2=gf13*pnx/gf110+2.*gf23*pny/gmm(i,j,k) . +gf33*pnz ugx0=0.5*(ugx(i,j,k)+ugx(i-1,j ,k )) vgx0=0.5*(vgx(i,j,k)+vgx(i-1,j ,k )) wgx0=0.5*(wgx(i,j,k)+wgx(i-1,j ,k )) ugy0=0.5*(ugy(i,j,k)+ugy(i ,j-j3,k )) vgy0=0.5*(vgy(i,j,k)+vgy(i ,j-j3,k )) wgy0=0.5*(wgy(i,j,k)+wgy(i ,j-j3,k )) wgz0=0.5*(wgz(i,j,k)+wgz(i ,j ,k-1)) rx=tauzx(i,j,kk)*gf110*etai(i,j,k) c rx=tauzx(i,j,kk)*gf110/eta(i,j,k) . -dii*gf110*pnx*dvcn . -pnz*(gf11*wgx0+gf12*wgy0+gf13*wgz0) . -2.*pnx*(gf11*ugx0+gf12*ugy0)/gf110 . -pny*(gf21*ugx0+gf22*ugy0+gf11*vgx0+gf12*vgy0)/gmm(i,j,k) . +(u(i,j,k)*(pnz-tnga(i,j)*pny) . -pnx*(w(i,j,k)-v(i,j,k)*tnga(i,j))) . *rdsi*2.*cosa(i,j)*(1-icylind) . +icylind*pny*v(i,j,k)*rdsi/gmm(i,j,k) ry=tauzy(i,j,kk)*gmm(i,j,k)*etai(i,j,k) . -dii*gmm(i,j,k)*pny*dvcn*j3t c ry=tauzy(i,j,kk)*gmm(i,j,k)/eta(i,j,k) c . -dii*gmm(i,j,k)*pny*dvcn . -pnz*(gf21*wgx0+gf22*wgy0+gf23*wgz0) . -2.*pny*(gf21*vgx0+gf22*vgy0)/gmm(i,j,k) . -pnx*(gf21*ugx0+gf22*ugy0+gf11*vgx0+gf12*vgy0)/gf110 . +(2.*rdsi*(pnz*v(i,j,k)-pny*w(i,j,k)-pnx*u(i,j,k)*tnga(i,j))) . *(1-icylind)+icylind*2.*rdsi*(pnx*v(i,j,k)-pny*u(i,j,k)) ugz0= (ay2*rx-ax2*ry)/(ax1*ay2-ax2*ay1) ! d(ug)/dzb at surface vgz0=-(ay1*rx-ax1*ry)/(ax1*ay2-ax2*ay1)*j3 ! d(vg)/dzb at surface ugz(i,j,ks)=2.*ugz0-ugz(i,j,ki) vgz(i,j,ks)=2.*vgz0-vgz(i,j,ki) 30 continue ! END IF ! noslip END IF #if (POLES == 0) c ---------------------------------------------- IF(J3.EQ.1) THEN c c --- compute edge vel. derivatives using drag c --- and Taylor series extrapolation c ---------------------------------------------- IF(IBCX+IBCY.EQ.0) THEN c --- compute vgx, wgx, ugy, and wgy on vertical edges do 1 i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np is=(i-1)/(np-1)*np ik=((np-2)*i+1)/(np-1) im=i+(np+1-2*i)/(np-1) isign=(np+1-2*i)/(np-1) do 11 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp jj=j3+j/mp js=(j-j3)/(mp-j3)*mp jk=((mp-1-j3)*j+1)/(mp-j3) jm=j+(mp+1-2*j)/(mp-j3) jsign=(mp+1-2*j)/(mp-1) do 111 k=2-ibcz,l-1+ibcz vgx(is,j,k)=vgx(is,jm,k)-vgx(ik,jm,k)+vgx(ik,j,k) wgx(is,j,k)=wgx(is,jm,k)-wgx(ik,jm,k)+wgx(ik,j,k) ugy(i,js,k)=ugy(im,js,k)-ugy(im,jk,k)+ugy(i,jk,k) wgy(i,js,k)=wgy(im,js,k)-wgy(im,jk,k)+wgy(i,jk,k) 111 continue endif 11 continue endif 1 continue END IF IF(IBCY+IBCZ.EQ.0) THEN c --- compute ugy, wgy, ugz, and vgz on horizontal front/back edges do 2 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp jm=j+(mp+1-2*j)/(mp-j3) js=(j-j3)/(mp-j3)*mp jk=((mp-1-j3)*j+1)/(mp-j3) jsign=(mp+1-2*j)/(mp-1) do 21 k=1,l,l-1 kk=1+k/l km=k+(l+1-2*k)/(l-1) ks=(k-1)/(l-1)*l ki=((l-2)*k+1)/(l-1) ksign=(l+1-2*k)/(l-1) do 211 i=1+(1-ibcx)*leftedge,np-(1-ibcx)*rightedge ugy(i,js,k)=ugy(i,jk,k)-ugy(i,jk,km)+ugy(i,js,km) wgy(i,js,k)=wgy(i,jk,k)-wgy(i,jk,km)+wgy(i,js,km) ugz(i,j,ks)=ugz(i,jm,ks)-ugz(i,jm,ki)+ugz(i,j,ki) vgz(i,j,ks)=vgz(i,jm,ks)-vgz(i,jm,ki)+vgz(i,j,ki) 211 continue 21 continue endif 2 continue END IF END IF ! J3.eq.1 IF(IBCX+IBCZ.EQ.0) THEN c --- compute ugz, vgz, vgx, and wgx on horizontal left/right edges do 3 i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np im=i+(np+1-2*i)/(np-1) ik=((np-2)*i+1)/(np-1) is=(i-1)/(np-1)*np isign=(np+1-2*i)/(np-1) do 31 k=1,l,l-1 ki=((l-2)*k+1)/(l-1) kk=1+k/l km=k+(l+1-2*k)/(l-1) ks=(k-1)/(l-1)*l ksign=(l+1-2*k)/(l-1) do 311 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge vgx(is,j,k)=vgx(ik,j,k)-vgx(ik,j,km)+vgx(is,j,km) wgx(is,j,k)=wgx(ik,j,k)-wgx(ik,j,km)+wgx(is,j,km) ugz(i,j,ks)=ugz(im,j,ks)-ugz(im,j,ki)+ugz(i,j,ki) vgz(i,j,ks)=vgz(im,j,ks)-vgz(im,j,ki)+vgz(i,j,ki) 311 continue 31 continue endif 3 continue END IF c ---------------------------------------------- ! edges completed c ---------------------------------------------- c ---------------------------------------------- c --- Taylor series extrapolation for corners c ---------------------------------------------- IF(IBCX+IBCY+IBCZ.EQ.0) THEN do i=1,np,np-1 ! values are 1 or n if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ik=((np-2)*i+1)/(np-1) ! values are 1 or n-1 im=i+(np+1-2*i)/(np-1) ! values are 2 or n-1 is=(i-1)/(np-1)*np ! values are 0 or n do j=1,mp,mp-j3 ! values are 1 or m if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jk=((mp-1-j3)*j+1)/(mp-j3) ! values are 1 or m-j3 jm=j+(mp+1-2*j)/(mp-j3) ! values are 2 or m-j3 js=(j-j3)/(mp-j3)*mp ! values are 0 or m do k=1,l,l-1 ! values are 1 or l ki=((l-2)*k+1)/(l-1) ! values are 1 or l-1 km=k+(l+1-2*k)/(l-1) ! values are 2 or l-1 ks=(k-1)/(l-1)*l ! values are 0 or l-1 vgx(is,j,k)=0.5*(vgx(is,j ,km)+vgx(is,jm,k ) . +vgx(ik,j ,k )-vgx(ik,jm,km)) wgx(is,j,k)=0.5*(wgx(is,j ,km)+wgx(is,jm,k ) . +wgx(ik,j ,k )-wgx(ik,jm,km)) ugy(i,js,k)=0.5*(ugy(i ,js,km)+ugy(i ,jk,k ) . +ugy(im,js,k )-ugy(im,jk,km)) wgy(i,js,k)=0.5*(wgy(i ,js,km)+wgy(i ,jk,k ) . +wgy(im,js,k )-wgy(im,jk,km)) ugz(i,j,ks)=0.5*(ugz(i ,j ,ki)+ugz(i ,jm,ks) . +ugz(im,j ,ks)-ugz(im,jm,ki)) vgz(i,j,ks)=0.5*(vgz(i ,j ,ki)+vgz(i ,jm,ks) . +vgz(im,j ,ks)-vgz(im,jm,ki)) end do endif end do endif end do END IF #endif c ---------------------------------------------- c --- completes staggered velocity derivatives c ---------------------------------------------- c if(mype.eq.0) then c write (6,*) ' ' c write (6,*) '**** strain: after completing VG.s ****' c endif c call extremum(ugx,ugy,ugz,vgx,vgy,vgz,wgx,wgy,wgz) c ---------------------------------------------------------c c surface fluxes --------> c ---------------------------------------------------------c c Compute strain rates for shear components of c c viscous stress, dilatation for compressive stress, c c and add together to form viscous stress c c c c Note distinction between covariant forms _ij c c and contravariant forms ^ij c c c c Compute staggered values centered at: c c x -> i+1/2, y -> j+1/2; z -> k+1/2 c c ---------------------------------------------------------c c --------------------------------------------------------- Compute the e_11 element of the strain rate @ (i+1/2,j,k) c DO K=1,L kp=kpp(k) DO J=1,MP jp=jpp(j) DO I=1,NP ip=ipp(i) gf11=.5*(strxx(ip,j)+strxx(i,j)) gf12=.5*(stryx(ip,j)+stryx(i,j)) gf13=.5*( (s13(ip,j)*gmul(k)-h13(ip,j))*gmus(k) . +(s13( i,j)*gmul(k)-h13( i,j))*gmus(k) ) e11(i,j,k)=gf11*ugx(i,j,k) + +gf12*( ugy( i,j,k)+ugy( i,j-j3,k) + +ugy(ip,j,k)+ugy(ip,j-j3,k) )*.25 + +gf13*( ugz(ip,j,k)+ugz(ip,j,k-1) + +ugz( i,j,k)+ugz( i,j,k-1) )*.25 + +( (w(ip,j,k)-v(ip,j,k)*tnga(ip,j)) + *gmm(ip,j,k)*(cosa(ip,j))**2 + +(w( i,j,k)-v( i,j,k)*tnga( i,j)) + *gmm(i ,j,k)*(cosa(i ,j))**2)*.5*rdsi + *(1-icylind) Compute the dilatation @ (i+1/2,j,k) drhdxb=dxi*( rh(i+1,j ,k )-rh(i ,j ,k )) + /( rh(i+1,j ,k )+rh(i ,j ,k )+ep)*2. drhdyb=dyi*( rh(i+1,j+j3,k )-rh(i+1,j-j3,k ) + +rh(i ,j+j3,k )-rh(i ,j-j3,k ) ) + /( rh(i+1,j+j3,k )+rh(i+1,j-j3,k ) + +rh(i ,j+j3,k )+rh(i ,j-j3,k )+ep) drhdzb=dzi*( rh(i+1,j ,k+1)-rh(i+1,j ,k-1) + +rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /( rh(i+1,j ,k+1)+rh(i+1,j ,k-1) + +rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcn=-.5*(ox(ip,j,k)+ox(i,j,k))*drhdxb + -.5*(oy(ip,j,k)+oy(i,j,k))*drhdyb + -.5*(oz(ip,j,k)+oz(i,j,k))*drhdzb Compute the stress @ (i+1/2,j,k) diss=(eta(ip,j,k)+eta(i,j,k))*.5 ! kinematic viscosity bvis=dii*diss ! bulk viscosity gm11=.5*((gmm(ip,j,k)*cosa(ip,j))**2+(gmm(i,j,k)*cosa(i,j))**2) + *(1-icylind) + icylind*1. gt11=.5*((gmm(ip,j,k)*cosa(ip,j))**4+(gmm(i,j,k)*cosa(i,j))**4) + *(1-icylind) + icylind*1. e11(i,j,k)=2.*diss*e11(i,j,k)/gt11+bvis*dvcn/gm11 !tau^11 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP gf11b=strxx(i,j) gf12b=stryx(i,j) gf13b=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e11b=gf11b*0.5*(ugx(i,j,k)+ugx(i-1,j,k)) + +gf12b*(ugy(i,j,k)+ugy(i,j-j3,k))*.5 + +gf13b*(ugz(i,j,k)+ugz(i, j,k-1))*.5 + +(w(i,j,k)-v(i,j,k)*tnga(i,j)) + *gmm(i,j,k)*(cosa(i,j))**2*rdsi + *(1-icylind) gt11b=(gmm(i,j,k)*cosa(i,j))**4 *(1-icylind) + icylind*1. gm11b=(gmm(i,j,k)*cosa(i,j))**2 *(1-icylind) + icylind*1. c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e11bz(i,j,kk)=2.*dissb*e11b/gt11b+bvisb*dvcnb/gm11b ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP gf11b=strxx(i,j) gf12b=stryx(i,j) gf13b=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e11b=gf11b*0.5*(ugx(i,j,k)+ugx(i-1,j,k)) + +gf12b*(ugy(i,j,k)+ugy(i,j-j3,k))*.5 + +gf13b*(ugz(i,j,k)+ugz(i, j,k-1))*.5 + +(w(i,j,k)-v(i,j,k)*tnga(i,j)) + *gmm(i,j,k)*(cosa(i,j))**2*rdsi + *(1-icylind) gt11b=(gmm(i,j,k)*cosa(i,j))**4 *(1-icylind) + icylind*1. gm11b=(gmm(i,j,k)*cosa(i,j))**2 *(1-icylind) + icylind*1. c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e11by(i,k,jj)=2.*dissb*e11b/gt11b+bvisb*dvcnb/gm11b ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP gf11b=strxx(i,j) gf12b=stryx(i,j) gf13b=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e11b=gf11b*0.5*(ugx(i,j,k)+ugx(i-1,j,k)) + +gf12b*(ugy(i,j,k)+ugy(i,j-j3,k))*.5 + +gf13b*(ugz(i,j,k)+ugz(i, j,k-1))*.5 + +(w(i,j,k)-v(i,j,k)*tnga(i,j)) + *gmm(i,j,k)*(cosa(i,j))**2*rdsi + *(1-icylind) gt11b=(gmm(i,j,k)*cosa(i,j))**4 *(1-icylind) + icylind*1. gm11b=(gmm(i,j,k)*cosa(i,j))**2 *(1-icylind) + icylind*1. c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e11bx(j,k,ii)=2.*dissb*e11b/gt11b+bvisb*dvcnb/gm11b ENDDO ENDDO endif ENDDO #endif c --------------------------------------------------------- Compute the e_22 element of the strain rate @ (i,j+1/2,k) DO K=1,L kp=kpp(k) DO J=1,MP jp=jpp(j) DO I=1,NP ip=ipp(i) gf21=0.5*(strxy(i,jp)+strxy(i,j)) gf22=0.5*(stryy(i,jp)+stryy(i,j)) gf23=0.5*( (s23(i,jp)*gmul(k)-h23(i,jp))*gmus(k) . +(s23(i,j )*gmul(k)-h23(i,j ))*gmus(k) ) e22(i,j,k)=gf21*( vgx(i,jp,k)+vgx(i-1,jp,k) + +vgx(i,j ,k)+vgx(i-1,j ,k))*.25 + +gf22*vgy(i,j,k) + +gf23*( vgz(i,jp,k )+vgz(i,jp,k-1) + +vgz(i, j,k )+vgz(i, j,k-1) )*.25 + +(w(i,jp,k)*gmm(i,jp,k)+w(i,j,k)*gmm(i,j,k))*.5*rdsi + *(1-icylind) + +icylind*0.5*(gmm(i,j,k)*u(i,j,k)+gmm(i,jp,k)*u(i,jp,k))*rdsi Compute the dilatation @ (i,j+1/2,k) drhdxb=dxi*( rh(i+1,j+j3,k )-rh(i-1,j+j3,k ) + +rh(i+1,j ,k )-rh(i-1,j ,k )) + /(rh(i+1,j+j3,k )+rh(i-1,j+j3,k ) + +rh(i+1,j ,k )+rh(i-1,j ,k )+ep) drhdyb=dyi*( rh(i ,j+j3,k )-rh(i ,j ,k )) + /(rh(i ,j+j3,k )+rh(i ,j ,k )+ep)*2. drhdzb=dzi*( rh(i ,j+j3,k+1)-rh(i ,j+j3,k-1) + +rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j+j3,k+1)+rh(i ,j+j3,k-1) + +rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcn=-0.5*(ox(i,jp,k)+ox(i,j,k))*drhdxb + -0.5*(oy(i,jp,k)+oy(i,j,k))*drhdyb + -0.5*(oz(i,jp,k)+oz(i,j,k))*drhdzb Compute the stress @ (i,j+1/2,k) diss=(eta(i,jp,k)+eta(i,j,k))*.5 ! kinematic viscosity bvis=dii*diss ! bulk viscosity gm22=.5*((gmm(i,jp,k))**2+(gmm(i,j,k))**2) gt22=.5*((gmm(i,jp,k))**4+(gmm(i,j,k))**4) e22(i,j,k)=2.*diss*e22(i,j,k)/gt22+bvis*dvcn/gm22*j3t !tau^22 c e22(i,j,k)=2.*diss*e22(i,j,k)/gt22+bvis*dvcn/gm22 !tau^22 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP gf21b=strxy(i,j) gf22b=stryy(i,j) gf23b=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e22b=gf21b*(vgx(i,j,k)+vgx(i-1,j,k))*.5 + +gf22b*(vgy(i,j,k)+vgy(i,j-j3,k))*.5 + +gf23b*(vgz(i,j,k)+vgz(i,j,k-1))*.5 + +w(i,j,k)*gmm(i,j,k)*rdsi + *(1-icylind) + +icylind*gmm(i,j,k)*u(i,j,k)*rdsi gm22b=gmm(i,j,k)**2 gt22b=gmm(i,j,k)**4 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e22bz(i,j,kk)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b*j3t c e22bz(i,j,kk)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP gf21b=strxy(i,j) gf22b=stryy(i,j) gf23b=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e22b=gf21b*(vgx(i,j,k)+vgx(i-1,j,k))*.5 + +gf22b*(vgy(i,j,k)+vgy(i,j-j3,k))*.5 + +gf23b*(vgz(i,j,k)+vgz(i,j,k-1))*.5 + +w(i,j,k)*gmm(i,j,k)*rdsi + *(1-icylind) + +icylind*gmm(i,j,k)*u(i,j,k)*rdsi gm22b=gmm(i,j,k)**2 gt22b=gmm(i,j,k)**4 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e22by(i,k,jj)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b*j3t c e22by(i,k,jj)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP gf21b=strxy(i,j) gf22b=stryy(i,j) gf23b=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e22b=gf21b*(vgx(i,j,k)+vgx(i-1,j,k))*.5 + +gf22b*(vgy(i,j,k)+vgy(i,j-j3,k))*.5 + +gf23b*(vgz(i,j,k)+vgz(i,j,k-1))*.5 + +w(i,j,k)*gmm(i,j,k)*rdsi + *(1-icylind) + +icylind*gmm(i,j,k)*u(i,j,k)*rdsi gm22b=gmm(i,j,k)**2 gt22b=gmm(i,j,k)**4 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e22bx(j,k,ii)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b*j3t c e22bx(j,k,ii)=2.*dissb*e22b/gt22b+bvisb*dvcnb/gm22b ENDDO ENDDO endif ENDDO #endif c --------------------------------------------------------- Compute the e_33 element of the strain rate @ (i,j,k+1/2) c DO K=1,L kp=kpp(k) DO J=1,MP DO I=1,NP gf33=0.5*(gi(i,j)*gmus(kp)+gi(i,j)*gmus(k)) e33(i,j,k)=gf33*wgz(i,j,k) Compute the dilatation @ (i,j,k+1/2) drhdxb=dxi*( rh(i+1,j,k+1) -rh(i-1,j,k+1) + +rh(i+1,j,k) -rh(i-1,j,k) ) + /( rh(i+1,j,k+1) +rh(i-1,j,k+1) + +rh(i+1,j,k) +rh(i-1,j,k)+ep) drhdyb=dyi*( rh(i,j+j3,k+1)-rh(i,j-j3,k+1) + +rh(i,j+j3,k) -rh(i,j-j3,k) ) + /( rh(i,j+j3,k+1)+rh(i,j-j3,k+1) + +rh(i,j+j3,k) +rh(i,j-j3,k)+ep) drhdzb=dzi*( rh(i,j,k+1) -rh(i,j,k)) + /(rh(i,j,k+1) +rh(i,j,k)+ep)*2. dvcn=-0.5*(ox(i,j,kp)+ox(i,j,k))*drhdxb + -0.5*(oy(i,j,kp)+oy(i,j,k))*drhdyb + -0.5*(oz(i,j,kp)+oz(i,j,k))*drhdzb Compute the stress @ (i,j,k+1/2) diss=(eta(i,j,kp)+eta(i,j,k))*.5 ! kinematic viscosity bvis=dii*diss ! bulk viscosity gm33=1. e33(i,j,k)=2.*diss*e33(i,j,k)+bvis*dvcn*gm33 !tau_33=tau^33 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP gf33b=gi(i,j)*gmus(k) e33b=gf33b*(wgz(i,j,k)+wgz(i,j,k-1))*.5 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e33bz(i,j,kk)=2.*dissb*e33b+bvisb*dvcnb ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP gf33b=gi(i,j)*gmus(k) e33b=gf33b*(wgz(i,j,k)+wgz(i,j,k-1))*.5 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e33by(i,k,jj)=2.*dissb*e33b+bvisb*dvcnb ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP gf33b=gi(i,j)*gmus(k) e33b=gf33b*(wgz(i,j,k)+wgz(i,j,k-1))*.5 c dilatation at the boundaries dissb=eta(i,j,k) bvisb=dii*dissb drdxb=dxi*(rh(i+1,j ,k )-rh(i-1,j ,k)) * /(rh(i+1,j ,k )+rh(i-1,j ,k)+ep) drdyb=dyi*(rh(i ,j+j3,k )-rh(i ,j-j3,k)) + /(rh(i ,j+j3,k )+rh(i ,j-j3,k)+ep) drdzb=dzi*(rh(i ,j ,k+1)-rh(i ,j ,k-1)) + /(rh(i ,j ,k+1)+rh(i ,j ,k-1)+ep) dvcnb=-ox(i,j,k)*drdxb-oy(i,j,k)*drdyb-oz(i,j,k)*drdzb c dilatation done e33bx(j,k,ii)=2.*dissb*e33b+bvisb*dvcnb ENDDO ENDDO endif ENDDO #endif c --------------------------------------------------------- Compute the e_12 element of the strain rate @ (i+1/2,j+1/2,k) c DO K=1,L kp=kpp(k) DO J=1,MP jp=jpp(j) DO I=1,NP ip=ipp(i) gg11=.125*( strxx(ip,jp)+strxx(i,j ) . +strxx(ip,j )+strxx(i,jp) ) gg12=.125*( stryx(ip,jp)+stryx(i,j ) . +stryx(ip,j )+stryx(i,jp) ) gg13=.125*( ( s13(ip,jp)*gmul(k)-h13(ip,jp))*gmus(k) . +( s13(i ,j )*gmul(k)-h13(i ,j ))*gmus(k) . +( s13(ip,j )*gmul(k)-h13(ip,j ))*gmus(k) . +( s13(i ,jp)*gmul(k)-h13(i ,jp))*gmus(k) ) gg21=.125*( strxy(ip,jp)+strxy(i ,j ) . +strxy(ip,j )+strxy(i ,jp) ) gg22=.125*( stryy(ip,jp)+stryy(i ,j ) . +stryy(ip,j )+stryy(i ,jp) ) gg23=.125*( ( s23(ip,jp)*gmul(k)-h23(ip,jp))*gmus(k) . +( s23(i ,j )*gmul(k)-h23(i ,j ))*gmus(k) . +( s23(ip,j )*gmul(k)-h23(ip,j ))*gmus(k) . +( s23(i ,jp)*gmul(k)-h23(i ,jp))*gmus(k) ) e12(i,j,k)=gg21*( ugx(i ,jp,k)+ugx(i ,j ,k))*.5 . +gg22*( ugy(ip,j ,k)+ugy(i ,j ,k))*.5 . +gg23*( ugz(ip,jp,k)+ugz(ip,jp,k-1) . +ugz(i ,jp,k)+ugz(i ,jp,k-1) . +ugz(ip,j ,k)+ugz(ip,j ,k-1) . +ugz(i ,j ,k)+ugz(i ,j ,k-1) )*.125 . +gg11*( vgx(i ,jp,k)+vgx(i ,j ,k))*.5 . +gg12*( vgy(ip,j ,k)+vgy(i ,j ,k))*.5 . +gg13*( vgz(ip,jp,k)+vgz(ip,jp,k-1) . +vgz(i ,jp,k)+vgz( i,jp,k-1) . +vgz(ip,j ,k)+vgz(ip,j ,k-1) . +vgz(i ,j ,k)+vgz( i,j ,k-1) )*.125 . +( u(ip,jp,k)*sina(ip,jp)*gmm(ip,jp,k) . +u(ip,j ,k)*sina(ip,j )*gmm(ip,j ,k) . +u(i ,jp,k)*sina(i ,jp)*gmm(i ,jp,k) . +u(i ,j ,k)*sina(i ,j )*gmm(i ,j ,k) )*0.25*rdsi . *(1-icylind) . -icylind*0.25*(v(ip,j,k)+v(ip,jp,k)+v(i,jp,k)+v(i,j,k))*rdsi Compute the stress @ (i+1/2,j+1/2,k) diss=(eta(ip,jp,k)+eta(i,jp,k)+eta(ip,j,k)+eta(i,j,k))*.25 ! kin. vis. gt12=( gmm(ip,jp,k)**4*cosa(ip,jp)**2 . +gmm(i ,jp,k)**4*cosa(i ,jp)**2 . +gmm(ip,j ,k)**4*cosa(ip,j )**2 . +gmm(i ,j ,k)**4*cosa(i ,j )**2 )*.25*(1-icylind) . +( gmm(ip,jp,k)**2+gmm(i ,jp,k)**2 . + gmm(ip,j ,k)**2+gmm(i ,j ,k)**2 )*.25*icylind e12(i,j,k)=2.*diss*e12(i,j,k)/gt12 !tau^12 e21(i,j,k)=e12(i,j,k) !tau^21 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP dissb=eta(i,j,k) gg11b=.5*strxx(i,j) gg12b=.5*stryx(i,j) gg13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gg21b=.5*strxy(i,j) gg22b=.5*stryy(i,j) gg23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e12b= ( gg21b*(ugx(i,j,k)+ugx(i-1, j,k)) . +gg22b*(ugy(i,j,k)+ugy(i,j-j3,k)) . +gg23b*(ugz(i,j,k)+ugz(i, j,k-1)) . +gg11b*(vgx(i,j,k)+vgx(i-1, j,k)) . +gg12b*(vgy(i,j,k)+vgy(i,j-j3,k)) . +gg13b*(vgz(i,j,k)+vgz(i, j,k-1)) )*.5 . +u(i,j,k)*sina(i,j)*gmm(i,j,k)*rdsi . *(1-icylind)-icylind*v(i,j,k)*rdsi gt12b=gmm(i,j,k)**4*cosa(i,j)**2 *(1-icylind) . +gmm(i,j,k)**2 *icylind e12bz(i,j,kk)=2.*dissb*e12b/gt12b e21bz(i,j,kk)=e12bz(i,j,kk) ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP dissb=eta(i,j,k) gg11b=.5*strxx(i,j) gg12b=.5*stryx(i,j) gg13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gg21b=.5*strxy(i,j) gg22b=.5*stryy(i,j) gg23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e12b= ( gg21b*(ugx(i,j,k)+ugx(i-1, j,k)) . +gg22b*(ugy(i,j,k)+ugy(i,j-j3,k)) . +gg23b*(ugz(i,j,k)+ugz(i, j,k-1)) . +gg11b*(vgx(i,j,k)+vgx(i-1, j,k)) . +gg12b*(vgy(i,j,k)+vgy(i,j-j3,k)) . +gg13b*(vgz(i,j,k)+vgz(i, j,k-1)) )*.5 . +u(i,j,k)*sina(i,j)*gmm(i,j,k)*rdsi . *(1-icylind)-icylind*v(i,j,k)*rdsi gt12b=gmm(i,j,k)**4*cosa(i,j)**2*(1-icylind) . +gmm(i,j,k)**2 *icylind e12by(i,k,jj)=2.*dissb*e12b/gt12b e21by(i,k,jj)=e12by(i,k,jj) ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP dissb=eta(i,j,k) gg11b=.5*strxx(i,j) gg12b=.5*stryx(i,j) gg13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) gg21b=.5*strxy(i,j) gg22b=.5*stryy(i,j) gg23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e12b= ( gg21b*(ugx(i,j,k)+ugx(i-1, j,k)) . +gg22b*(ugy(i,j,k)+ugy(i,j-j3,k)) . +gg23b*(ugz(i,j,k)+ugz(i, j,k-1)) . +gg11b*(vgx(i,j,k)+vgx(i-1, j,k)) . +gg12b*(vgy(i,j,k)+vgy(i,j-j3,k)) . +gg13b*(vgz(i,j,k)+vgz(i, j,k-1)) )*.5 . +u(i,j,k)*sina(i,j)*gmm(i,j,k)*rdsi . *(1-icylind)-icylind*v(i,j,k)*rdsi gt12b=gmm(i,j,k)**4*cosa(i,j)**2*(1-icylind) . +gmm(i,j,k)**2 *icylind e12bx(j,k,ii)=2.*dissb*e12b/gt12b e21bx(j,k,ii)=e12bx(j,k,ii) ENDDO ENDDO endif ENDDO #endif c --------------------------------------------------------- Compute the e_13 element of the strain rate @ (i+1/2,j,k+1/2) c DO K=1,L kp=kpp(k) DO J=1,MP DO I=1,NP ip=ipp(i) gh33=0.125*( gi(ip,j)*gmus(kp)+gi(ip,j)*gmus(k ) . +gi(i ,j)*gmus(k )+gi(i ,j)*gmus(kp) ) gh11=0.125*( strxx(ip,j)+strxx(ip,j) . +strxx(i ,j)+strxx(i ,j) ) gh12=0.125*( stryx(ip,j )+stryx(ip,j ) . +stryx(i ,j )+stryx(i ,j ) ) gh13=0.125*( ( s13(ip,j)*gmul(kp)-h13(ip,j))*gmus(kp) . +( s13(ip,j)*gmul(k )-h13(ip,j))*gmus(k ) . +( s13(i ,j)*gmul(k )-h13(i ,j))*gmus(k ) . +( s13(i ,j)*gmul(kp)-h13(i ,j))*gmus(kp) ) e13(i,j,k)=gh33*(ugz(ip,j,k )+ugz(i ,j,k))*.5 + +gh11*(wgx(i ,j,kp)+wgx(i ,j,k))*.5 + +gh12*(wgy(ip,j,kp)+wgy(ip,j-j3,kp) + +wgy(ip,j, k)+wgy(ip,j-j3, k) + +wgy(i ,j,k )+wgy(i ,j-j3,k ) + +wgy(i ,j,kp)+wgy(i ,j-j3,kp) )*.125 + +gh13*(wgz(ip,j,k )+wgz(i,j,k))*.5 + -0.25*rdsi*( (u(ip,j,kp)+u(ip,j,k ))*cosa(ip,j) + +(u(i ,j,k )+u(i ,j,kp))*cosa(i ,j) )*(1-icylind) Compute the stress @ (i+1/2,j,k+1/2) diss=(eta(ip,j,kp)+eta(i,j,kp)+eta(ip,j,k)+eta(i,j,k))*.25 !kin. vis. gt13=((gmm(ip,j,kp)*cosa(ip,j))**2+(gmm(i,j,kp)*cosa(i,j))**2 + +(gmm(ip,j,k )*cosa(ip,j))**2+(gmm(i,j,k )*cosa(i,j))**2)*.25 + *(1-icylind)+icylind*1. e13(i,j,k)=2.*diss*e13(i,j,k)/gt13 !tau^13 e31(i,j,k)=e13(i,j,k) !tau^31 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP dissb=eta(i,j,k) gh33b=.5*gi(i,j)*gmus(k) gh11b=.5*strxx(i,j) gh12b=.5*stryx(i,j) gh13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e13b= ( gh33b*(ugz(i,j,k)+ugz(i,j,k-1)) + +gh11b*(wgx(i,j,k)+wgx(i-1,j,k)) + +gh12b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gh13b*(wgz(i,j,k)+wgz(i,j,k-1)) )*.5 + -rdsi*u(i,j,k)*cosa(i,j)*(1-icylind) gt13b=(gmm(i,j,k)*cosa(i,j))**2*(1-icylind)+icylind*1. e13bz(i,j,kk)=2.*dissb*e13b/gt13b e31bz(i,j,kk)=e13bz(i,j,kk) ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP dissb=eta(i,j,k) gh33b=.5*gi(i,j)*gmus(k) gh11b=.5*strxx(i,j) gh12b=.5*stryx(i,j) gh13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e13b= ( gh33b*(ugz(i,j,k)+ugz(i,j,k-1)) + +gh11b*(wgx(i,j,k)+wgx(i-1,j,k)) + +gh12b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gh13b*(wgz(i,j,k)+wgz(i,j,k-1)) )*.5 + -rdsi*u(i,j,k)*cosa(i,j)*(1-icylind) gt13b=(gmm(i,j,k)*cosa(i,j))**2*(1-icylind)+icylind*1. e13by(i,k,jj)=2.*dissb*e13b/gt13b e31by(i,k,jj)=e13by(i,k,jj) ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP dissb=eta(i,j,k) gh33b=.5*gi(i,j)*gmus(k) gh11b=.5*strxx(i,j) gh12b=.5*stryx(i,j) gh13b=.5*(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) e13b= ( gh33b*(ugz(i,j,k)+ugz(i,j,k-1)) + +gh11b*(wgx(i,j,k)+wgx(i-1,j,k)) + +gh12b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gh13b*(wgz(i,j,k)+wgz(i,j,k-1)) )*.5 + -rdsi*u(i,j,k)*cosa(i,j)*(1-icylind) gt13b=(gmm(i,j,k)*cosa(i,j))**2*(1-icylind)+icylind*1. e13bx(j,k,ii)=2.*dissb*e13b/gt13b e31bx(j,k,ii)=e13bx(j,k,ii) ENDDO ENDDO endif ENDDO #endif c --------------------------------------------------------- Compute the e_23 element of the strain rate @ (i,j+1/2,k+1/2) c DO K=1,L kp=kpp(k) DO J=1,MP jp=jpp(j) DO I=1,NP gi33=0.125*( gi(i,jp)*gmus(kp)+gi(i,jp)*gmus(k ) . +gi(i ,j)*gmus(k )+gi(i ,j)*gmus(kp) ) gi21=.125*( strxy(i,jp)+strxy(i,jp) . +strxy(i,j )+strxy(i,j ) ) gi22=0.125*( stryy(i,jp)+stryy(i,jp) . +stryy(i,j )+stryy(i,j ) ) gi23=0.125*( ( s23(i,jp)*gmul(kp)-h23(i,jp))*gmus(kp) . +( s23(i,jp)*gmul(k )-h23(i,jp))*gmus(k ) . +( s23(i,j )*gmul(k )-h23(i,j ))*gmus(k ) . +( s23(i,j )*gmul(kp)-h23(i,j ))*gmus(kp) ) e23(i,j,k)= gi33*(vgz(i,jp,k )+vgz(i,j,k))*.5 + +gi21*(wgx(i,jp,kp)+wgx(i-1,jp,kp) + +wgx(i,jp,k )+wgx(i-1,jp,k ) + +wgx(i,j ,k )+wgx(i-1,j ,k ) + +wgx(i,j ,kp)+wgx(i-1,j ,kp) )*.125 + +gi22*(wgy(i,j ,kp)+wgy(i,j,k))*.5 + +gi23*(wgz(i,jp,k )+wgz(i,j,k))*.5 + -.25*rdsi*( v(i,jp,kp)+v(i,jp,k )+v(i,j ,k )+v(i,j ,kp) ) + *(1-icylind) Compute the stress @ (i,j+1/2,k+1/2) diss=(eta(i,jp,kp)+eta(i,j,kp)+eta(i,jp,k)+eta(i,j,k))*.25 !kin. vis. gt23=( gmm(i,jp,kp)**2+gmm(i,j,kp)**2 + +gmm(i,jp,k )**2+gmm(i,j,k )**2 )*.25 e23(i,j,k)=2.*diss*e23(i,j,k)/gt23 !tau^23 e32(i,j,k)=e23(i,j,k) !tau^32 ENDDO ENDDO ENDDO DO K=1,L,L-1 kk=1+k/l DO J=1,MP DO I=1,NP dissb=eta(i,j,k) gi33b=.5*gi(i,j)*gmus(k) gi21b=.5*strxy(i,j) gi22b=.5*stryy(i,j) gi23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e23b= ( gi33b*(vgz(i,j,k)+vgz(i, j,k-1)) + +gi21b*(wgx(i,j,k)+wgx(i-1, j,k)) + +gi22b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gi23b*(wgz(i,j,k)+wgz(i, j,k-1)) )*.5 + -rdsi*v(i,j,k)*(1-icylind) gt23b=gmm(i,j,k)**2 e23bz(i,j,kk)=2.*dissb*e23b/gt23b e32bz(i,j,kk)=e23bz(i,j,kk) ENDDO ENDDO ENDDO #if (POLES == 0) DO J=1,MP,MP-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp DO K=1,L DO I=1,NP dissb=eta(i,j,k) gi33b=.5*gi(i,j)*gmus(k) gi21b=.5*strxy(i,j) gi22b=.5*stryy(i,j) gi23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e23b= ( gi33b*(vgz(i,j,k)+vgz(i, j,k-1)) + +gi21b*(wgx(i,j,k)+wgx(i-1, j,k)) + +gi22b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gi23b*(wgz(i,j,k)+wgz(i, j,k-1)) )*.5 + -rdsi*v(i,j,k)*(1-icylind) gt23b=gmm(i,j,k)**2 e23by(i,k,jj)=2.*dissb*e23b/gt23b e32by(i,k,jj)=e23by(i,k,jj) ENDDO ENDDO endif ENDDO DO I=1,NP,NP-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np DO K=1,L DO J=1,MP dissb=eta(i,j,k) gi33b=.5*gi(i,j)*gmus(k) gi21b=.5*strxy(i,j) gi22b=.5*stryy(i,j) gi23b=.5*(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) e23b= ( gi33b*(vgz(i,j,k)+vgz(i, j,k-1)) + +gi21b*(wgx(i,j,k)+wgx(i-1, j,k)) + +gi22b*(wgy(i,j,k)+wgy(i,j-j3,k)) + +gi23b*(wgz(i,j,k)+wgz(i, j,k-1)) )*.5 + -rdsi*v(i,j,k)*(1-icylind) gt23b=gmm(i,j,k)**2 e23bx(j,k,ii)=2.*dissb*e23b/gt23b e32bx(j,k,ii)=e23bx(j,k,ii) ENDDO ENDDO endif ENDDO #endif call update( e11,np,mp,l,np,mp,iup) call update( e12,np,mp,l,np,mp,iup) call updatelr(e13,np,mp,l,np,mp,iupx) call update( e21,np,mp,l,np,mp,iup) call update( e22,np,mp,l,np,mp,iup) call updatebt(e23,np,mp,l,np,mp,iupy) call update( e31,np,mp,l,np,mp,iup) call update( e32,np,mp,l,np,mp,iup) call update( e33,np,mp,l,np,mp,iup) c ---------------------------------------------------------c c End stress/strain rates computations c c ---------------------------------------------------------c if(tt.le.tend) call vstrhat(ox,oy,oz,-1) ! ret. contravariant vel. #if (TIMEPLT == 1) call ttend(41) #endif return end subroutine stressdv(fu,fv,fw,flx,fly,flz) C C *************************************************** c * computes rhs forcings due to stress divergence * C *************************************************** c c tij - contravariant stresses c fu, fv, fz - "xbar,ybar,zbar" components of stress c divergence; note they are divided by c density*Jacobian = rho(i,j,k) c C ******************************************* include 'param.nml' include 'msg.inc' dimension fu(1-ih:np+ih, 1-ih:mp+ih, l), . fv(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l), . flx(1-ih:np+ih, 1-ih:mp+ih, l), . fly(1-ih:np+ih, 1-ih:mp+ih, l), . flz(1-ih:np+ih, 1-ih:mp+ih, l) common/strainc/ t11(1-ih:np+ih,1-ih:mp+ih,L), * t12(1-ih:np+ih,1-ih:mp+ih,L), * t13(1-ih:np+ih,1-ih:mp+ih,L), * t21(1-ih:np+ih,1-ih:mp+ih,L), * t22(1-ih:np+ih,1-ih:mp+ih,L), * t23(1-ih:np+ih,1-ih:mp+ih,L), * t31(1-ih:np+ih,1-ih:mp+ih,L), * t32(1-ih:np+ih,1-ih:mp+ih,L), * t33(1-ih:np+ih,1-ih:mp+ih,L), * t11bx(mp,l,2),t11by(np,l,2),t11bz(np,mp,2), * t12bx(mp,l,2),t12by(np,l,2),t12bz(np,mp,2), * t13bx(mp,l,2),t13by(np,l,2),t13bz(np,mp,2), * t21bx(mp,l,2),t21by(np,l,2),t21bz(np,mp,2), * t22bx(mp,l,2),t22by(np,l,2),t22bz(np,mp,2), * t23bx(mp,l,2),t23by(np,l,2),t23bz(np,mp,2), * t31bx(mp,l,2),t31by(np,l,2),t31bz(np,mp,2), * t32bx(mp,l,2),t32by(np,l,2),t32bz(np,mp,2), * t33bx(mp,l,2),t33by(np,l,2),t33bz(np,mp,2) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) ! size of regular array parameter(iarrx1=(np+1)*mp*l) ! size of fx parameter(iarry1=np*(mp+1)*l) ! size of fy parameter(iarrz1=np*mp*(l+1)) ! size of fz parameter(iaryb=np*l*2) ! size of flyb parameter(iarxb=mp*l*2) ! size of flxb parameter(iarzb=np*mp*2) ! size of flxb parameter(ifree=16*iarray-iarrx1-iarry1-iarrz1-iaryb-iarxb-iarzb) common/blank/ 2 flxb(mp,l,2),flyb(np,l,2),flzb(np,mp,2), 1 fx(0:np,mp,l),fy(np,0:mp,l),fz(np,mp,0:l),src(ifree) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profrhoi/rhoi(np,mp,l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/stresd/ diagstr(8),ivis,irid,itstr common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/dslip/ cdrgx(2),cdrgy(2),cdrgz(2), * tauxy(mp,l ,2),tauxz(mp,l ,2),tauyz(np,l ,2), * tauyx(np,l ,2),tauzx(np,mp,2),tauzy(np,mp,2), * hflz(np,mp,2), hflx(mp,l ,2), hfly(np,l ,2), * qflz(nmsp,mmsp,2), * qflx(mmsp,lms,2), * qfly(nmsp,lms,2) common/indexpar/ imm(np),ipp(np), * jmm(mp),jpp(mp), * kmm(l ),kpp(l ), * ibox,iboy,iboz #if (TIMEPLT == 1) call ttbeg(42) #endif c ---------------------------------------------------------c c Compute "xbar,ybar,zbar" contributions to viscous c c fluxes in "x,y,z" directions; add them to form c c "x,y,z" viscous flux components; compute divergence c c including Christoffel terms. c c c c Note viscous stress is contravariant form ^ij c c c c Compute staggered values of fluxes centered at: c c flx -> i+1/2, fly -> j+1/2; flz -> k+1/2 c c whereas divergence and Christoffel terms are c c centered at (i,j,k) c c ---------------------------------------------------------c c --------------------------------------------------------- Compute the fu = tau^(1j)_(,j) element of the stress divergence c c -----xbar contribution to tau^(1j) averaged @ (i+1/2,j,k) do j=1,mp jm=imm(j) do i=1,np ip=ipp(i) do k=1,L g110=.5*( gmm(ip,j,k)*cosa(ip,j)+gmm(i,j,k)*cosa(i,j) ) . *(1-icylind)+icylind*1. g11 =.5*(strxx(ip,j)+strxx(i,j)) g21 =.5*(strxy(ip,j)+strxy(i,j)) flx(i,j,k)= g11*t11(i,j,k) . +g21*.5*(t12(i,j,k)+t12(i,jm,k)) flx(i,j,k)=0.5*(rho(ip,j,k)+rho(i,j,k))*flx(i,j,k)*g110 enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp g110b=gmm(i,j,k)*cosa(i,j)*(1-icylind)+icylind*1. g11b=strxx(i,j) g21b=strxy(i,j) flxb(j,k,ii)= g11b*t11bx(j,k,ii)+g21b*t12bx(j,k,ii) flxb(j,k,ii)= rho(i,j,k)*flxb(j,k,ii)*g110b enddo enddo endif enddo #endif c -----ybar contribution to tau^(1j) averaged @ (i,j+1/2,k) do j=1,mp jp=jpp(j) do i=1,np im=imm(i) do k=1,L g110=.5*( gmm(i,jp,k)*cosa(i,jp)+gmm(i,j,k)*cosa(i,j) ) . *(1-icylind)+icylind*1. g12 =.5*(stryx(i,jp)+stryx(i,j)) g22 =.5*(stryy(i,jp)+stryy(i,j)) fly(i,j,k)= g12*.25*( t11(i ,jp,k)+t11(i ,j,k) . +t11(im,jp,k)+t11(im,j,k) ) . +g22*.5*( t12(i ,j ,k)+t12(im,j,k)) fly(i,j,k)=0.5*(rho(i,jp,k)+rho(i,j,k))*fly(i,j,k)*g110 enddo enddo enddo #if (POLES == 0) do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,l do i=1,np g110b=gmm(i,j,k)*cosa(i,j)*(1-icylind)+icylind*1. g12b=stryx(i,j) g22b=stryy(i,j) flyb(i,k,jj)= g12b*t11by(i,k,jj)+g22b*t12by(i,k,jj) flyb(i,k,jj)=rho(i,j,k)*flyb(i,k,jj)*g110b enddo enddo endif enddo #endif c -----zbar contribution to tau^(1j) averaged @ (i,j,k+1/2) do k=1,L kp=kpp(k) do j=1,mp jm=jmm(j) do i=1,np im=imm(i) g110=.5*( gmm(i,j,kp)*cosa(i,j)+gmm(i,j,k)*cosa(i,j) ) . *(1-icylind)+icylind*1. g13= .5*( (s13(i,j)*gmul(kp)-h13(i,j))*gmus(kp) . +(s13(i,j)*gmul(k )-h13(i,j))*gmus(k ) ) g23= .5*( (s23(i,j)*gmul(kp)-h23(i,j))*gmus(kp) . +(s23(i,j)*gmul(k )-h23(i,j))*gmus(k ) ) g33= .5*( gi(i,j)*gmus(kp)+ gi(i,j) *gmus(k)) flz(i,j,k)= g13*.25*( t11(i ,j,kp)+t11(i , j, k) . +t11(im,j,kp)+t11(im, j, k) ) . +g23*.125*( t12(i, j, k)+t12(im, j, k) . +t12(i,jm, k)+t12(im,jm, k) . +t12(i, j,kp)+t12(im, j,kp) . +t12(i,jm,kp)+t12(im,jm,kp) ) . +g33*.5*(t13(i,j,k)+t13(im,j,k)) flz(i,j,k)=0.5*(rho(i,j,kp)+rho(i,j,k))*flz(i,j,k)*g110 enddo enddo enddo do k=1,L,L-1 kk=1+k/l do j=1,mp do i=1,np g110b=gmm(i,j,k)*cosa(i,j)*(1-icylind)+icylind*1. g13b= (s13(i,j)*gmul(k)-h13(i,j))*gmus(k) g23b= (s23(i,j)*gmul(k)-h23(i,j))*gmus(k) g33b= gi(i,j)*gmus(k) flzb(i,j,kk)= g13b*t11bz(i,j,kk)+g23b*t12bz(i,j,kk) . +g33b*t13bz(i,j,kk) flzb(i,j,kk)=rho(i,j,k)*flzb(i,j,kk)*g110b enddo enddo enddo call inject(flx,fly,flz,fx,fy,fz,flxb,flyb,flzb) c ----- compute divergence: tau^(1j)_(,j) = fu @ (i,j,k) do k=2,L-1 ! interior points #if (POLES == 0) do j=1+j3*botedge,mp-j3*topedge do i=1+leftedge,np-rightedge #else do j=1,mp do i=1,np #endif fu(i,j,k)= dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) . +rdsi*rho(i,j,k)*(cosa(i,j)*.25* . (t31(i,j,k )+t31(i-1,j,k ) . +t31(i,j,k-1)+t31(i-1,j,k-1)) . -gmm(i,j,k)*sina(i,j)*.25* . ( t21(i,j ,k)+t21(i-1,j ,k) . +t21(i,j-j3,k)+t21(i-1,j-j3,k))) . *(1-icylind) . -icylind*0.5*rho(i,j,k)*gmm(i,j,k)*rdsi* . ( t22(i,j ,k)+ t22(i,j-j3 ,k) ) fu(i,j,k)=fu(i,j,k)*rhoi(i,j,k) enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp fu(i,j,k)= dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) . +rdsi*rho(i,j,k)*(cosa(i,j)*t31bx(j,k,ii) . -gmm(i,j,k)* sina(i,j)*t21bx(j,k,ii)) . *(1-icylind) . -icylind*rho(i,j,k)*gmm(i,j,k)*rdsi*t22bx(j,k,ii) fu(i,j,k)=fu(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,L do i=1,np fu(i,j,k)= dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) . +rdsi*rho(i,j,k)*(cosa(i,j)*t31by(i,k,jj) . -gmm(i,j,k)* sina(i,j)*t21by(i,k,jj)) . *(1-icylind) . -icylind*rho(i,j,k)*gmm(i,j,k)*rdsi*t22by(i,k,jj) fu(i,j,k)=fu(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo #endif do k=1,L,L-1 kk=1+k/l do j=1,mp do i=1,np fu(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . +rdsi*rho(i,j,k)*(cosa(i,j)*t31bz(i,j,kk) . -gmm(i,j,k)* sina(i,j)*t21bz(i,j,kk)) . *(1-icylind) . -icylind*rho(i,j,k)*gmm(i,j,k)*rdsi*t22bz(i,j,kk) fu(i,j,k)=fu(i,j,k)*rhoi(i,j,k) enddo enddo enddo c ----- viscous force tau^(1j)_(,j) completed c --------------------------------------------------------- Compute the fv = tau^(2j)_(,j) element of the stress divergence c c -----xbar contribution to tau^(2j) averaged @ (i+1/2,j,k) do k=1,L do j=1,mp jm=jmm(j) do i=1,np ip=ipp(i) g220=.5*(gmm(ip,j,k)+gmm(i,j,k)) g11 =.5*(strxx(ip,j)+strxx(i,j)) g21 =.5*(strxy(ip,j)+strxy(i,j)) flx(i,j,k)= g11*.5*( t21(i ,j,k)+t21(i ,jm,k)) . +g21*.25*(t22(i ,j,k)+t22(i ,jm,k) . +t22(ip,j,k)+t22(ip,jm,k)) flx(i,j,k)=.5*(rho(ip,j,k)+rho(i,j,k))*flx(i,j,k)*g220 enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp g220b=gmm(i,j,k) g11b=strxx(i,j) g21b=strxy(i,j) flxb(j,k,ii)= g11b*t21bx(j,k,ii)+g21b*t22bx(j,k,ii) flxb(j,k,ii)= rho(i,j,k)*flxb(j,k,ii)*g220b enddo enddo endif enddo #endif c -----ybar contribution to tau^(2j) averaged @ (i,j+1/2,k) do k=1,L do j=1,mp jp=jpp(j) do i=1,np im=imm(i) g220=.5*(gmm(i,jp,k)+gmm(i,j,k)) g12 =.5*(stryx(i,jp)+stryx(i,j)) g22 =.5*(stryy(i,jp)+stryy(i,j)) fly(i,j,k)= g12*.5*(t21(i,j,k)+t21(im,j,k)) . +g22* t22(i,j,k) fly(i,j,k)=.5*(rho(i,jp,k)+rho(i,j,k))*fly(i,j,k)*g220 enddo enddo enddo #if (POLES == 0) do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,L do i=1,np g220b=gmm(i,j,k) g12b=stryx(i,j) g22b=stryy(i,j) flyb(i,k,jj)= g12b*t21by(i,k,jj)+g22b*t22by(i,k,jj) flyb(i,k,jj)=rho(i,j,k)*flyb(i,k,jj)*g220b enddo enddo endif enddo #endif c -----zbar contribution to tau^(2j) averaged @ (i,j,k+1/2) do k=1,L kp=kpp(k) do j=1,mp jm=jmm(j) do i=1,np im=imm(i) g220=.5*(gmm(i,j,kp)+gmm(i,j,k)) g13= .5*((s13(i,j)*gmul(kp)-h13(i,j))*gmus(kp) . +(s13(i,j)*gmul(k )-h13(i,j))*gmus(k ) ) g23= .5*((s23(i,j)*gmul(kp)-h23(i,j))*gmus(kp) . +(s23(i,j)*gmul(k )-h23(i,j))*gmus(k ) ) g33= .5*( gi(i,j)*gmus(kp)+ gi(i,j) *gmus(k)) flz(i,j,k)= g13*.125*( t21(i ,j ,kp)+t21(i ,j ,k) . +t21(im,j ,kp)+t21(im,j ,k) . +t21(i ,jm,kp)+t21(i ,jm,k) . +t21(im,jm,kp)+t21(im,jm,k) ) . +g23*.25*(t22(i ,j ,kp)+t22(i ,j ,kp) . +t22(i ,jm,k )+t22(i ,jm,k) ) . +g33*.5*( t23(i ,j ,k )+t23(i ,jm,k)) flz(i,j,k)=.5*(rho(i,j,kp)+rho(i,j,k))*flz(i,j,k)*g220 enddo enddo enddo do k=1,l,l-1 kk=1+k/l do j=1,mp do i=1,np g220b=gmm(i,j,k) g13b= (s13(i,j)*gmul(k)-h13(i,j))*gmus(k) g23b= (s23(i,j)*gmul(k)-h23(i,j))*gmus(k) g33b= gi(i,j)*gmus(k) flzb(i,j,kk)= g13b*t21bz(i,j,kk)+g23b*t22bz(i,j,kk) . +g33b*t23bz(i,j,kk) flzb(i,j,kk)=rho(i,j,k)*flzb(i,j,kk)*g220b enddo enddo enddo call inject(flx,fly,flz,fx,fy,fz,flxb,flyb,flzb) c ----- compute divergence: tau^(2j)_(,j) = fv @ (i,j,k) do k=2,L-1 #if (POLES == 0) do j=1+j3*botedge,mp-j3*topedge do i=1+leftedge,np-rightedge #else do j=1,mp do i=1,np #endif fv(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . +rdsi*rho(i,j,k)*( sina(i,j)*cosa(i,j)*gmm(i,j,k) . *.5*(t11(i,j,k )+t11(i-1,j,k)) . +.25*(t32(i,j,k )+t32(i,j-j3, k ) . +t32(i,j,k-1)+t32(i,j-j3,k-1) ) ) . *(1-icylind) . +icylind*rho(i,j,k)*rdsi*(2./gmm(i,j,k)-1.) . *.25*(t12(i,j,k )+t12(i-1,j, k ) . +t12(i,j-j3,k)+t12(i-1,j-j3,k) ) fv(i,j,k)=fv(i,j,k)*rhoi(i,j,k) enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp fv(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . +rdsi*rho(i,j,k)*(t32bx(j,k,ii) . +sina(i,j)*cosa(i,j)*gmm(i,j,k)*t11bx(j,k,ii) ) . *(1-icylind) . +icylind*rho(i,j,k)*rdsi*(2./gmm(i,j,k)-1.)*t12bx(j,k,ii) fv(i,j,k)=fv(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,L do i=1,np fv(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . +rdsi*rho(i,j,k)*(t32by(i,k,jj) . +sina(i,j)*cosa(i,j)*gmm(i,j,k)*t11by(i,k,jj) ) . *(1-icylind) . +icylind*rho(i,j,k)*rdsi*(2./gmm(i,j,k)-1.)*t12by(i,k,jj) fv(i,j,k)=fv(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo #endif do k=1,l,l-1 kk=1+k/l do j=1,mp do i=1,np fv(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . +rdsi*rho(i,j,k)*(t32bz(i,j,kk) . +sina(i,j)*cosa(i,j)*gmm(i,j,k)*t11bz(i,j,kk) ) . *(1-icylind) . +icylind*rho(i,j,k)*rdsi*(2./gmm(i,j,k)-1.)*t12bz(i,j,kk) fv(i,j,k)=fv(i,j,k)*rhoi(i,j,k) enddo enddo enddo c ----- viscous force tau^(2j)_(,j) completed c --------------------------------------------------------- Compute the fw = tau^(3j)_(,j) element of the stress divergence c c -----xbar contribution to tau^(3j)_(,j) averaged @ (i+1/2,j,k) do k=1,L km=kmm(k) do j=1,mp jm=jmm(j) do i=1,np ip=ipp(i) g11 =.5*(strxx(ip,j)+strxx(i,j)) g21 =.5*(strxy(ip,j)+strxy(i,j)) flx(i,j,k)= g11*.5*( t31(i ,j, k)+t31(i ,j ,km)) . +g21*.125*( t32(i ,j, k)+t32(i ,jm,k ) . +t32(ip,j, k)+t32(ip,jm,k ) . +t32(i ,j,km)+t32(i ,jm,km) . +t32(ip,j,km)+t32(ip,jm,km)) flx(i,j,k)=0.5*(rho(ip,j,k)+rho(i,j,k))*flx(i,j,k) enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp g11b=strxx(i,j) g21b=strxy(i,j) flxb(j,k,ii)= g11b*t31bx(j,k,ii)+g21b*t32bx(j,k,ii) flxb(j,k,ii)= rho(i,j,k)*flxb(j,k,ii) enddo enddo endif enddo #endif c -----ybar contribution to tau^(3j) averaged @ (i,j+1/2,k) do k=1,L km=kmm(k) do j=1,mp jp=jpp(j) do i=1,np im=imm(i) g12 =.5*(stryx(i,jp)+stryx(i,j)) g22 =.5*(stryy(i,jp)+stryy(i,j)) fly(i,j,k)= g12*.125*( t31(i,j ,k )+t31(im,j ,k ) . +t31(i,j ,km)+t31(im,j ,km) . +t31(i,jp,k )+t31(im,jp,k ) . +t31(i,jp,km)+t31(im,jp,km) ) . +g22*0.5*( t32(i,j ,k )+t32(i ,j ,km)) fly(i,j,k)=0.5*(rho(i,jp,k)+rho(i,j,k))*fly(i,j,k) enddo enddo enddo #if (POLES == 0) do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,L do i=1,np g12b=stryx(i,j) g22b=stryy(i,j) flyb(i,k,jj)= g12b*t31by(i,k,jj)+g22b*t32by(i,k,jj) flyb(i,k,jj)=rho(i,j,k)*flyb(i,k,jj) enddo enddo endif enddo #endif c -----zbar contribution to tau^(3j) averaged @ (i,j,k+1/2) do k=1,L kp=kpp(k) do j=1,mp jm=jmm(j) do i=1,np im=imm(i) g13= .5*( (s13(i,j)*gmul(kp)-h13(i,j))*gmus(kp) . +(s13(i,j)*gmul(k )-h13(i,j))*gmus(k ) ) g23= .5*( (s23(i,j)*gmul(kp)-h23(i,j))*gmus(kp) . +(s23(i,j)*gmul(k )-h23(i,j))*gmus(k ) ) g33= .5*(gi(i,j)*gmus(kp)+gi(i,j)*gmus(k)) flz(i,j,k)= g13*.5*(t31(i,j,k)+t31(im,j,k)) . +g23*.5*(t32(i,j,k)+t32(i,jm,k)) . +g33*t33(i,j,k) flz(i,j,k)=0.5*(rho(i,j,kp)+rho(i,j,k))*flz(i,j,k) enddo enddo enddo do k=1,L,L-1 kk=1+k/l do j=1,mp do i=1,np g13b= (s13(i,j)*gmul(k)-h13(i,j))*gmus(k) g23b= (s23(i,j)*gmul(k)-h23(i,j))*gmus(k) g33b= gi(i,j)*gmus(k) flzb(i,j,kk)= g13b*t31bz(i,j,kk)+g23b*t32bz(i,j,kk) . +g33b*t33bz(i,j,kk) flzb(i,j,kk)=rho(i,j,k)*flzb(i,j,kk) enddo enddo enddo call inject(flx,fly,flz,fx,fy,fz,flxb,flyb,flzb) c ----- compute tau^(3j)_(,j) = fw @ (i,j,k) do k=2,L-1 #if (POLES == 0) do j=1+j3*botedge,mp-j3*topedge do i=1+leftedge,np-rightedge #else do j=1,mp do i=1,np #endif fw(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . -rdsi*rho(i,j,k)*gmm(i,j,k)*( . cosa(i,j)**2*.5*(t11(i,j,k)+t11(i-1, j,k)) . +.5*(t22(i,j,k)+t22(i,j-j3,k)) ) . *(1-icylind) fw(i,j,k)=fw(i,j,k)*rhoi(i,j,k) enddo enddo enddo #if (POLES == 0) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,L do j=1,mp fw(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . -rdsi*rho(i,j,k)*gmm(i,j,k) . *(cosa(i,j)**2*t11bx(j,k,ii)+t22bx(j,k,ii)) . *(1-icylind) fw(i,j,k)=fw(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,L do i=1,np fw(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . -rdsi*rho(i,j,k)*gmm(i,j,k) . *(cosa(i,j)**2*t11by(i,k,jj)+t22by(i,k,jj)) . *(1-icylind) fw(i,j,k)=fw(i,j,k)*rhoi(i,j,k) enddo enddo endif enddo #endif do k=1,L,L-1 kk=1+k/l do j=1,mp do i=1,np fw(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1, j,k)) . +dyi*(fy(i,j,k)-fy(i,j-j3,k)) . +dzi*(fz(i,j,k)-fz(i, j,k-1)) ) . -rdsi*rho(i,j,k)*gmm(i,j,k) . *(cosa(i,j)**2*t11bz(i,j,kk)+t22bz(i,j,kk)) . *(1-icylind) fw(i,j,k)=fw(i,j,k)*rhoi(i,j,k) enddo enddo enddo c ----- viscous force tau^(3j)_(,j) completed c --------------------------------------------------------c c End of computation of stress divergence c c --------------------------------------------------------c c enforce cyclicity #if (POLES == 0) if(ibcx.eq.1) then call updatelr(fu,np,mp,l,np,mp,1) call updatelr(fv,np,mp,l,np,mp,1) call updatelr(fw,np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,L do j=1,mp fu(np,j,k)=fu(np+1,j,k) fv(np,j,k)=fv(np+1,j,k) fw(np,j,k)=fw(np+1,j,k) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(fu,np,mp,l,np,mp,1) call updatebt(fv,np,mp,l,np,mp,1) call updatebt(fw,np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,L do i=1,np fu(i,mp,k)=fu(i,mp+j3,k) fv(i,mp,k)=fv(i,mp+j3,k) fw(i,mp,k)=fw(i,mp+j3,k) enddo enddo endif endif #endif if(ibcz.eq.1) then do j=1,mp do i=1,np fu(i,j,l)=fu(i,j,1) fv(i,j,l)=fv(i,j,1) fw(i,j,l)=fw(i,j,1) enddo enddo endif #if (TIMEPLT == 1) call ttend(42) #endif return end subroutine inject(flx,fly,flz,fx,fy,fz,flxb,flyb,flzb) include 'param.nml' include 'msg.inc' dimension flx(1-ih:np+ih, 1-ih:mp+ih, l), . fly(1-ih:np+ih, 1-ih:mp+ih, l), . flz(1-ih:np+ih, 1-ih:mp+ih, l) dimension fx(0:np,mp,l),fy(np,0:mp,l),fz(np,mp,0:l), 2 flxb(mp,l,2),flyb(np,l,2),flzb(np,mp,2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(43) #endif call updatelr(flx,np,mp,l,np,mp,iupx) call updatebt(fly,np,mp,l,np,mp,iupy) do k=1,L do j=1,mp #if (POLES == 0) do i=0+leftedge,np-rightedge #else do i=0,np #endif fx(i,j,k)=flx(i,j,k) ! flx must be updated enddo enddo enddo #if (POLES == 0) c----------> BC for xbar component of FX flux if(ibcx.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp fx(0,j,k)=flx(-1,j,k) ! fx(n-1,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp fx(np,j,k)=flx(np+2,j,k) ! fx( 1 ,j,k) enddo enddo endif else do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np ! 1 or 2 is=(i-1)/(np-1)*np ! 0 or n ik=((np-2)*i+1)/(np-1) ! 1 or n-1 do k=1,l do j=1,mp fx(is,j,k)=2.*flxb(j,k,ii)-fx(ik,j,k) enddo enddo endif enddo endif #endif do k=1,L #if (POLES == 0) do j=0+botedge,mp-j3*topedge #else do j=0,mp #endif do i=1,np fy(i,j,k)=fly(i,j,k) enddo enddo enddo #if (POLES == 0) c----------> BC for ybar component of FY flux if(ibcy.eq.1) then if(botedge.eq.1) then do k=1,l do i=1,np fy(i,0,k)=fly(i,-1,k) enddo enddo endif if(topedge.eq.1) then do k=1,l do i=1,np fy(i,mp,k)=fly(i,mp+2,k) enddo enddo endif else do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp ! 1 or 2 js=(j-j3)/(mp-j3)*mp ! 0 or m jk=((mp-1-j3)*j+1)/(mp-j3) ! 1 or m-1 do k=1,l do i=1,np fy(i,js,k)=2.*flyb(i,k,jj)-fy(i,jk,k) enddo enddo endif enddo endif #endif do k=1,L-1 do j=1,mp do i=1,np fz(i,j,k)=flz(i,j,k) enddo enddo enddo c----------> BC for zbar component of FZ flux if(ibcz.eq.1) then do j=1,mp do i=1,np fz(i,j,0)=fz(i,j,l-1) fz(i,j,l)=fz(i,j, 1 ) enddo enddo else do k=1,l,l-1 kk=1+k/l ks=(k-1)/(l-1)*l ki=((l-2)*k+1)/(l-1) do j=1,mp do i=1,np fz(i,j,ks)=2.*flzb(i,j,kk)-fz(i,j,ki) enddo enddo enddo endif #if (TIMEPLT == 1) call ttend(43) #endif return end subroutine normalv C ******************************************* c c computes components of domain boundary unit normals in both c physical coordinates (pnx, pny, pnz) and transformed coordinates c (tnsx, tnsy, tnxz) where s=x,y,z corresponds to i=1,n; j=1,m; and c k=1,l surfaces; respectively. Only components in transformed c coordinates are passed out of subroutine. c c NOTES: c (i) in either coordinate system, same unit normal vector is c being computed, but component description is coordinate dependent. c (ii) direction of normals is along principle coordinate direction c used to define boundary; eg., into domain for lower, left, and c front boundaries, and out of domain for upper, right, and back c boundaries. c C ******************************************* include 'param.nml' include 'msg.inc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/normals/ tnxx(mp,l ,2),tnxy(mp,l ,2),tnxz(mp,l ,2), * tnyx(np,l ,2),tnyy(np,l ,2),tnyz(np,l ,2), * tnzx(np,mp,2),tnzy(np,mp,2),tnzz(np,mp,2) #if (TIMEPLT == 1) call ttbeg(44) #endif #if (POLES == 0) c-------> transformed components of the normal to i=1,n surfaces c (NOTE: boundary is defined not a function of z) do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do k=1,l do j=1,mp cx=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) cy=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) gnr=sqrt(1.+strxy(i,j)**2) pnx=1./gnr pny=strxy(i,j)*pnx tnxx(j,k,ii)=pnx*strxx(i,j)+pny*strxy(i,j) tnxy(j,k,ii)=pnx*stryx(i,j)+pny*stryy(i,j) tnxz(j,k,ii)=pnx*cx+pny*cy enddo enddo endif enddo c-------> transformed components of the normal to j=1,m surfaces c (NOTE: boundary is defined not a function of z) do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do k=1,l do i=1,np cx=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) cy=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) gnr=sqrt(stryx(i,j)**2+1.) pny=1./gnr pnx=stryx(i,j)*pny tnyx(i,k,jj)=pnx*strxx(i,j)+pny*strxy(i,j) tnyy(i,k,jj)=pnx*stryx(i,j)+pny*stryy(i,j) tnyz(i,k,jj)=pnx*cx+pny*cy enddo enddo endif enddo #endif c-------> transformed components of the normal to k=1,l surfaces do k=1,l,l-1 kk=1+k/l do j=1,mp do i=1,np cx=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) cy=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) cz=gmus(k)*gi(i,j) zsx=-cx/cz zsy=-cy/cz gnr=sqrt(1.+zsx**2+zsy**2) pnz= 1./gnr pnx=-zsx*pnz pny=-zsy*pnz tnzx(i,j,kk)=pnx*strxx(i,j)+pny*strxy(i,j) tnzy(i,j,kk)=pnx*stryx(i,j)+pny*stryy(i,j) tnzz(i,j,kk)=pnx*cx+pny*cy+pnz*cz enddo enddo enddo #if (TIMEPLT == 1) call ttend(44) #endif return end subroutine fckflxdv(p,fp,eta,f1,f2,f3,sfflx,sffly,sfflz) include 'param.nml' include 'msg.inc' dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fp(1-ih:np+ih,1-ih:mp+ih,l), . f1(1-ih:np+ih,1-ih:mp+ih,l), . f2(1-ih:np+ih,1-ih:mp+ih,l), . f3(1-ih:np+ih,1-ih:mp+ih,l), . sfflx(mp,l,2), . sffly(np,l,2), . sfflz(np,mp,2), . eta(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv) common/sgscnst/ ceps,cL,cm,css,prndt common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/normals/ tnxx(mp,l ,2),tnxy(mp,l ,2),tnxz(mp,l ,2), * tnyx(np,l ,2),tnyy(np,l ,2),tnyz(np,l ,2), * tnzx(np,mp,2),tnzy(np,mp,2),tnzz(np,mp,2) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profrhoi/rhoi(np,mp,l) common/diffus/ sk(l),skr(l),sls parameter(iarray=(np+2*ih)*(mp+2*ih)*l) ! size of regular array parameter(iarrpz=(np+2*ih)*(mp+2*ih)*(l+1)) ! size of pz parameter(iarrx1=(np+1)*mp*l) ! size of fx parameter(iarry1=np*(mp+1)*l) ! size of fy parameter(iarrz1=np*mp*(l+1)) ! size of fz parameter(iarret=np*mp*l) ! size of etai parameter(ifree=13*iarray-iarrpz-iarrx1-iarry1-iarrz1-iarret) common/blank/ px(1-ih:np+ih,1-ih:mp+ih,l), . py(1-ih:np+ih,1-ih:mp+ih,l), . pz(1-ih:np+ih,1-ih:mp+ih,0:l), 1 dvf(1-ih:np+ih,1-ih:mp+ih,l), 1 fx(0:np,mp,l),fy(np,0:mp,l),fz(np,mp,0:l), 1 etai(np,mp,l),src(ifree) common/indexpar/ imm(np),ipp(np), * jmm(mp),jpp(mp), * kmm(l ),kpp(l ), * ibox,iboy,iboz #if (TIMEPLT == 1) call ttbeg(45) #endif compute some local constants ep=1.e-10 pi=acos(-1.) call update(p,np,mp,l,np,mp,iup) ! p=th in anelas do k=1,l do j=1,mp do i=1,np etai(i,j,k)=1./amax1(eta(i,j,k),ep) enddo enddo enddo do k=1,L do j=1,mp #if (POLES == 0) do i=0+leftedge,np-rightedge #else do i=0,np #endif px(i,j,k)= dxi*(p(i+1,j,k)-p(i,j,k)) enddo enddo enddo #if (POLES == 0) if(ibcx.eq.1) then if(leftedge.eq.1) then do k=1,L do j=1,mp px(0,j,k)= dxi*(p(1,j,k)-p(-1,j,k)) ! px(0,j,k)= px(n-1,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,L do j=1,mp px(np,j,k)= dxi*(p(np+2,j,k)-p(np,j,k)) ! px(n,j,k)= px(1,j,k) enddo enddo endif endif #endif do k=1,L #if (POLES == 0) do j=0+botedge,mp-j3*topedge #else do j=0,mp #endif do i=1,np py(i,j,k)= dyi*(p(i,j+j3,k)-p(i,j,k)) enddo enddo enddo #if (POLES == 0) if(ibcy.eq.1) then if(botedge.eq.1) then do k=1,L do i=1,np py(i,0,k)= dyi*(p(i,1,k)-p(i,1-2*j3,k)) ! py(i,0,k)= py(i,m-j3,k) enddo enddo endif if(topedge.eq.1) then do k=1,L do i=1,np py(i,mp,k)= dyi*(p(i,mp+2*j3,k)-p(i,mp,k)) ! py(i,m,k)= py(i,1,k) enddo enddo endif endif #endif do k=1,L-1 do j=1,mp do i=1,np pz(i,j,k)= dzi*(p(i,j,k+1)-p(i,j,k)) enddo enddo enddo if(ibcz.eq.1) then do j=1,mp do i=1,np pz(i,j,0)= pz(i,j,l-1) pz(i,j,l)= pz(i,j, 1 ) enddo enddo endif c-------------------------------- #if (POLES == 0) if(ibcx.eq.0) then do 1 i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np is=(i-1)/(np-1)*np ik=((np-2)*i+1)/(np-1) do 10 k=2-ibcz,l-1+ibcz do 10 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge cfx= 1./tnxx(j,k,ii) cfy=tnxy(j,k,ii)/tnxx(j,k,ii) cfz=tnxz(j,k,ii)/tnxx(j,k,ii) px0=-cfx*sfflx(j,k,ii)*etai(i,j,k) + -cfy*(py(i,j,k)+py(i,j-j3,k))*0.5 + -cfz*(pz(i,j,k)+pz(i, j,k-1))*0.5 px(is,j,k)=2.*px0-px(ik,j,k) 10 continue if(ibcz.eq.0) then do 11 k=1,l,l-1 kk=1+k/l do 111 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge qx=sfflx(j,k,ii)*etai(i,j,k) qz=sfflz(i,j,kk)*etai(i,j,k) dn=tnxx(j,k,ii)*tnzz(i,j,kk)-tnxz(j,k,ii)*tnzx(i,j,kk) ed1=(tnzz(i,j,kk)*qx-tnxz(j,k,ii)*qz)/dn ed2=( tnxy(j,k,ii)*tnzz(i,j,kk) + -tnxz(j,k,ii)*tnzy(i,j,kk) )/dn px0=-ed1-ed2*(py(i,j,k)+py(i,j-j3,k))*0.5 111 px(is,j,k)=2.*px0-px(ik,j,k) if(ibcy.eq.0.and.j3.eq.1) then do 112 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp qx= sfflx(j,k,ii)*etai(i,j,k) qy= sffly(i,k,jj)*etai(i,j,k) qz= sfflz(i,j,kk)*etai(i,j,k) dn= tnxx(j,k,ii)*tnyy(i,k,jj)*tnzz(i,j,kk) . +tnxy(j,k,ii)*tnyz(i,k,jj)*tnzx(i,j,kk) . +tnxz(j,k,ii)*tnyx(i,k,jj)*tnzy(i,j,kk) . -tnxz(j,k,ii)*tnyy(i,k,jj)*tnzx(i,j,kk) . -tnxx(j,k,ii)*tnyz(i,k,jj)*tnzy(i,j,kk) . -tnxy(j,k,ii)*tnyx(i,k,jj)*tnzz(i,j,kk) d1=- qx*tnyy(i,k,jj)*tnzz(i,j,kk) . -tnxy(j,k,ii)*tnyz(i,k,jj)*qz . -tnxz(j,k,ii)* qy*tnzy(i,j,kk) . +tnxz(j,k,ii)*tnyy(i,k,jj)*qz . + qx*tnyz(i,k,jj)*tnzy(i,j,kk) . +tnxy(j,k,ii)* qy*tnzz(i,j,kk) px0=d1/dn endif ! bot or top edges 112 px(is,j,k)=2.*px0-px(ik,j,k) endif ! ibcy=0 & j3=1 11 continue endif ! ibcz=0 if(ibcy.eq.0) then do 12 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do 121 k=2,l-1 qy=sffly(i,k,jj)*etai(i,j,k) qx=sfflx(j,k,ii)*etai(i,j,k) dn=tnxx(j,k,ii)*tnyy(i,k,jj)-tnxy(j,k,ii)*tnyx(i,k,jj) ed1=(tnyy(i,k,jj)*qx-tnxy(j,k,ii)*qy)/dn ed2=( tnxz(j,k,ii)*tnyy(i,k,jj) + -tnxy(j,k,ii)*tnyz(i,k,jj) )/dn px0=-ed1-ed2*(pz(i,j,k)+pz(i,j,k-1))*0.5 121 px(is,j,k)=2.*px0-px(ik,j,k) endif ! bot or top edges 12 continue endif ! ibcy=0 endif ! left or right edges 1 continue endif ! ibcx=0 #endif c-------------------------------- #if (POLES == 0) if(ibcy.eq.0) then do 2 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp js=(j-j3)/(mp-j3)*mp jk=((mp-1-j3)*j+1)/(mp-j3) do 20 k=2-ibcz,l-1+ibcz do 20 i=1+(1-ibcx)*leftedge,np-(1-ibcx)*rightedge cfy= 1./tnyy(i,k,jj) cfx=tnyx(i,k,jj)/tnyy(i,k,jj) cfz=tnyz(i,k,jj)/tnyy(i,k,jj) py0=-cfy*sffly(i,k,jj)*etai(i,j,k) + -cfx*(px(i,j,k)+px(i-1,j,k))*0.5 + -cfz*(pz(i,j,k)+pz(i,j,k-1))*0.5 20 py(i,js,k)=2.*py0-py(i,jk,k) if(ibcx.eq.0) then do 21 i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do 211 k=2-ibcz,l-1+ibcz qx=sfflx(j,k,ii)*etai(i,j,k) qy=sffly(i,k,jj)*etai(i,j,k) dn=tnxx(j,k,ii)*tnyy(i,k,jj)-tnxy(j,k,ii)*tnyx(i,k,jj) ed1=(tnxx(j,k,ii)*qy-tnyx(i,k,jj)*qx)/dn ed2=( tnxx(j,k,ii)*tnyz(i,k,jj) + -tnxz(j,k,ii)*tnyx(i,k,jj) )/dn py0=-ed1-ed2*(pz(i,j,k)+pz(i,j,k-1))*0.5 211 py(i,js,k)=2.*py0-py(i,jk,k) if(ibcz.eq.0) then do 212 k=1,l,l-1 kk=1+k/l qx= sfflx(j,k,ii)*etai(i,j,k) qy= sffly(i,k,jj)*etai(i,j,k) qz= sfflz(i,j,kk)*etai(i,j,k) dn= tnxx(j,k,ii)*tnyy(i,k,jj)*tnzz(i,j,kk) . +tnxy(j,k,ii)*tnyz(i,k,jj)*tnzx(i,j,kk) . +tnxz(j,k,ii)*tnyx(i,k,jj)*tnzy(i,j,kk) . -tnxz(j,k,ii)*tnyy(i,k,jj)*tnzx(i,j,kk) . -tnxx(j,k,ii)*tnyz(i,k,jj)*tnzy(i,j,kk) . -tnxy(j,k,ii)*tnyx(i,k,jj)*tnzz(i,j,kk) d2=-tnxx(j,k,ii)* qy*tnzz(i,j,kk) . - qx*tnyz(i,k,jj)*tnzx(i,j,kk) . -tnxz(j,k,ii)*tnyx(i,k,jj)*qz . +tnxz(j,k,ii)* qy*tnzx(i,j,kk) . +tnxx(j,k,ii)*tnyz(i,k,jj)*qz . + qx*tnyx(i,k,jj)*tnzz(i,j,kk) py0=d2/dn 212 py(i,js,k)=2.*py0-py(i,jk,k) endif endif ! left or right edges 21 continue endif ! ibcy=0 if(ibcz.eq.0) then do 22 k=1,l,l-1 kk=1+k/l do 221 i=1+leftedge,np-rightedge qy=sffly(i,k,jj)*etai(i,j,k) qz=sfflz(i,j,kk)*etai(i,j,k) dn=tnyy(i,k,jj)*tnzz(i,j,kk)-tnyz(i,k,jj)*tnzy(i,j,kk) ed1=(tnzz(i,j,kk)*qy-tnyz(i,k,jj)*qz)/dn ed2=( tnyx(i,k,jj)*tnzz(i,j,kk) + -tnyz(i,k,jj)*tnzx(i,j,kk) )/dn py0=-ed1-ed2*(px(i,j,k)+px(i-1,j,k))*0.5 221 py(i,js,k)=2.*py0-py(i,jk,k) 22 continue endif ! ibcz=0 endif ! bot or top edges 2 continue endif ! ibcy=0 #endif c-------------------------------- if(ibcz.eq.0) then do 3 k=1,l,l-1 kk=1+k/l ks=(k-1)/(l-1)*l ki=((l-2)*k+1)/(l-1) #if (POLES == 0) do 30 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge do 30 i=1+(1-ibcx)*leftedge,np-(1-ibcx)*rightedge #else do 30 j=1,mp do 30 i=1,np #endif cfz= 1./tnzz(i,j,kk) cfx=tnzx(i,j,kk)/tnzz(i,j,kk) cfy=tnzy(i,j,kk)/tnzz(i,j,kk) pz0=-cfz*sfflz(i,j,kk)*etai(i,j,k) + -cfx*(px(i,j,k)+px(i-1, j,k))*0.5 + -cfy*(py(i,j,k)+py(i,j-j3,k))*0.5 pz(i,j,ks)=2.*pz0-pz(i,j,ki) 30 continue #if (POLES == 0) if(ibcx.eq.0) then do 31 i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np do 311 j=1+(j3-ibcy)*botedge,mp-(j3-ibcy)*topedge qx=sfflx(j,k,ii)*etai(i,j,k) qz=sfflz(i,j,kk)*etai(i,j,k) dn=tnxx(j,k,ii)*tnzz(i,j,kk)-tnxz(j,k,ii)*tnzx(i,j,kk) ed1=(tnxx(j,k,ii)*qz-tnzx(i,j,kk)*qx)/dn ed2=( tnxx(j,k,ii)*tnzy(i,j,kk) + -tnxy(j,k,ii)*tnzx(i,j,kk) )/dn pz0=-ed1-ed2*(py(i,j,k)+py(i,j-j3,k))*0.5 pz(i,j,ks)=2.*pz0-pz(i,j,ki) 311 continue if(ibcy.eq.0.and.j3.eq.1) then do 312 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp qx= sfflx(j,k,ii)*etai(i,j,k) qy= sffly(i,k,jj)*etai(i,j,k) qz= sfflz(i,j,kk)*etai(i,j,k) dn= tnxx(j,k,ii)*tnyy(i,k,jj)*tnzz(i,j,kk) . +tnxy(j,k,ii)*tnyz(i,k,jj)*tnzx(i,j,kk) . +tnxz(j,k,ii)*tnyx(i,k,jj)*tnzy(i,j,kk) . -tnxz(j,k,ii)*tnyy(i,k,jj)*tnzx(i,j,kk) . -tnxx(j,k,ii)*tnyz(i,k,jj)*tnzy(i,j,kk) . -tnxy(j,k,ii)*tnyx(i,k,jj)*tnzz(i,j,kk) d3=-tnxx(j,k,ii)*tnyy(i,k,jj)*qz . -tnxy(j,k,ii)* qy*tnzx(i,j,kk) . - qx*tnyx(i,k,jj)*tnzy(i,j,kk) . + qx*tnyy(i,k,jj)*tnzx(i,j,kk) . +tnxx(j,k,ii)* qy*tnzy(i,j,kk) . +tnxy(j,k,ii)*tnyx(i,k,jj)*qz pz0=d3/dn pz(i,j,ks)=2.*pz0-pz(i,j,ki) endif ! bot or top edges 312 continue endif ! ibcy=0 & j3=1 endif ! left or right edges 31 continue endif ! ibcx=0 if(ibcy.eq.0) then do 32 j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp do 321 i=1+leftedge,np-rightedge qy=sffly(i,k,jj)*etai(i,j,k) qz=sfflz(i,j,kk)*etai(i,j,k) dn=tnyy(i,k,jj)*tnzz(i,j,kk)-tnyz(i,k,jj)*tnzy(i,j,kk) ed1=(tnyy(i,k,jj)*qz-tnzy(i,j,kk)*qy)/dn ed2=(tnyy(i,k,jj)*tnzx(i,j,kk) + -tnyx(i,k,jj)*tnzy(i,j,kk) )/dn pz0=-ed1-ed2*(px(i,j,k)+px(i-1,j,k))*0.5 pz(i,j,ks)=2.*pz0-pz(i,j,ki) 321 continue endif ! bot or top edges 32 continue endif ! ibcy=0 #endif 3 continue endif ! ibcz=0 call updatebtw(px,0,np,1,mp,l,1,np,1,mp,iupy) call updatelrw(py,1,np,0,mp,l,1,np,1,mp,iupx) call update2(pz,np,mp,l+1,np,mp,iup) c------------> xbar component of Fickian flux at i+1/2 #if (POLES == 0) DO I=1,NP-rightedge #else DO I=1,NP #endif ip=i+1 DO K=1,L DO J=1,MP g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) g110p=1./((1-icylind)*gmm(ip,j,k)*cosa(ip,j)+icylind*1.) g220p=1./gmm(ip,j,k) g11p=strxx(ip,j)*g110 g12p=stryx(ip,j)*g110 g13p=(s13(ip,j)*gmul(k)-h13(ip,j))*gmus(k)*g110 g21p=strxy(ip,j)*g220 g22p=stryy(ip,j)*g220 g23p=(s23(ip,j)*gmul(k)-h23(ip,j))*gmus(k)*g220 g33p=gi(ip,j)*gmus(k) gf11=.5*( ( g11p**2 + g21p**2 ) . +( g11**2 + g21**2 ) ) gf12=.5*( ( g11p*g12p + g21p*g22p ) . +( g11*g12 + g21*g22 ) ) gf13=.5*( ( g11p*g13p + g21p*g23p ) . +( g11*g13 + g21*g23 ) ) f1(i,j,k)=gf11*px(i,j,k) + +gf12*( py(ip,j,k)+py(ip,j-j3,k) + +py( i,j,k)+py( i,j-j3,k) )*.25 + +gf13*( pz(ip,j,k)+pz(ip, j,k-1) + +pz( i,j,k)+pz( i, j,k-1) )*.25 diss=(eta(ip,j,k)+eta(i,j,k))*.5 ! kinematic viscosity diss=diss*(rho(ip,j,k)+rho(i,j,k))*.5 ! dynamic viscosity f1(i,j,k)=diss*f1(i,j,k) ENDDO ENDDO ENDDO c------------> ybar component of Fickian flux at j+1/2 #if (POLES == 0) DO 5 J=1,MP-j3*topedge #else DO 5 J=1,MP #endif jp=j+j3 DO K=1,L DO I=1,NP g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) g110p=1./((1-icylind)*gmm(i,jp,k)*cosa(i,jp)+icylind*1.) g220p=1./gmm(i,jp,k) g11p=strxx(i,jp)*g110 g12p=stryx(i,jp)*g110 g13p=(s13(i,jp)*gmul(k)-h13(i,jp))*gmus(k)*g110 g21p=strxy(i,jp)*g220 g22p=stryy(i,jp)*g220 g23p=(s23(i,jp)*gmul(k)-h23(i,jp))*gmus(k)*g220 g33p=gi(i,jp)*gmus(k) gf21=.5*( ( g11p*g12p + g21p*g22p ) . +( g11*g12 + g21*g22 ) ) gf22=.5*( ( g12p**2 + g22p**2 ) . +( g12**2 + g22**2 ) ) gf23=.5*( ( g12p*g13p + g22p*g23p ) . +( g12*g13 + g22*g23 ) ) f2(i,j,k)=gf21*( px(i,jp,k)+px(i-1,jp,k) + +px(i,j ,k)+px(i-1,j ,k) )*.25 + +gf22* py(i,j ,k) + +gf23*( pz(i,jp,k)+pz(i,jp,k-1) + +pz(i, j,k)+pz(i, j,k-1) )*.25 diss=(eta(i,jp,k)+eta(i,j,k))*.5 ! kinematic viscosity diss=diss*(rho(i,jp,k)+rho(i,j,k))*.5 ! dynamic viscosity f2(i,j,k)=diss*f2(i,j,k) ENDDO ENDDO 5 CONTINUE c------------> zbar component of Fickian flux at k+1/2 DO 6 K=1,L-1 kp=k+1 DO J=1,MP DO I=1,NP g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) g110p=1./((1-icylind)*gmm(i,j,kp)*cosa(i,j)+icylind*1.) g220p=1./gmm(i,j,kp) g11p=strxx(i,j)*g110 g12p=stryx(i,j)*g110 g13p=(s13(i,j)*gmul(kp)-h13(i,j))*gmus(kp)*g110 g21p=strxy(i,j)*g220 g22p=stryy(i,j)*g220 g23p=(s23(i,j)*gmul(kp)-h23(i,j))*gmus(kp)*g220 g33p=gi(i,j)*gmus(kp) gf31=.5*( ( g11p*g13p + g21p*g23p ) . +( g11*g13 + g21*g23 ) ) gf32=.5*( ( g12p*g13p + g22p*g23p ) . +( g12*g13 + g22*g23 ) ) gf33=.5*( ( g13p**2 + g23p**2 + g33p**2 ) . +( g13**2 + g23**2 + g33**2 ) ) f3(i,j,k)=gf31*( px(i,j,kp)+px(i-1, j,kp) + +px(i,j,k )+px(i-1, j,k ) )*.25 + +gf32*( py(i,j,kp)+py(i,j-j3,kp) + +py(i,j,k )+py(i,j-j3,k ) )*.25 + +gf33*pz(i,j,k) diss=(eta(i,j,kp)+eta(i,j,k))*.5 ! kinematic viscosity c diss=(eta(i,j,kp)*gmm(i,j,kp)**2+eta(i,j,k)*gmm(i,j,k)**2)*.5 ! ki vis diss=diss*(rho(i,j,kp)+rho(i,j,k))*.5 ! dynamic viscosity f3(i,j,k)=diss*f3(i,j,k) ENDDO ENDDO 6 CONTINUE call updatelr(f1,np,mp,l,np,mp,iupx) call updatebt(f2,np,mp,l,np,mp,iupy) do k=1,L do j=1,mp #if (POLES == 0) do i=0+leftedge,np-rightedge #else do i=0,np #endif fx(i,j,k)=f1(i,j,k) enddo enddo enddo #if (POLES == 0) c----------> BC for xbar component of Fickian flux if(ibcx.eq.1) then if(leftedge.eq.1) then do k=1,l do j=1,mp fx(0,j,k)=f1(-1,j,k) enddo enddo endif if(rightedge.eq.1) then do k=1,l do j=1,mp fx(np,j,k)=f1(np+2,j,k) enddo enddo endif else do i=1,np,np-1 if((i.eq.leftedge).or.(i.eq.(rightedge*np))) then ii=1+i/np is=(i-1)/(np-1)*np ik=((np-2)*i+1)/(np-1) do k=1,l do j=1,mp cfx= 1./tnxx(j,k,ii) cfy=tnxy(j,k,ii)/tnxx(j,k,ii) cfz=tnxz(j,k,ii)/tnxx(j,k,ii) px0=-cfx*sfflx(j,k,ii)*etai(i,j,k) + -cfy*(py(i,j,k)+py(i,j-j3,k))*0.5 + -cfz*(pz(i,j,k)+pz(i, j,k-1))*0.5 g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) gf11= g11**2 + g21**2 gf12= g11*g12 + g21*g22 gf13= g11*g13 + g21*g23 fx0= gf11*px0 + +gf12*( py(i,j,k)+py(i,j-j3,k) )*0.5 + +gf13*( pz(i,j,k)+pz(i, j,k-1) )*0.5 diss=eta(i,j,k) ! kinematic viscosity diss=diss*rho(i,j,k) ! dynamic viscosity fx0=diss*fx0 fx(is,j,k)=2.*fx0-fx(ik,j,k) enddo enddo endif enddo endif #endif do k=1,L #if (POLES == 0) do j=0+botedge,mp-j3*topedge #else do j=0,mp #endif do i=1,np fy(i,j,k)=f2(i,j,k) enddo enddo enddo #if (POLES == 0) c----------> BC for ybar component of Fickian flux if(ibcy.eq.1) then if(botedge.eq.1) then do k=1,l do i=1,np fy(i,0,k)=f2(i,1-2*j3,k) enddo enddo endif if(topedge.eq.1) then do k=1,l do i=1,np fy(i,mp,k)=f2(i,mp+2*j3,k) enddo enddo endif else do j=1,mp,mp-j3 if((j.eq.botedge).or.(j.eq.(topedge*mp))) then jj=j3+j/mp js=(j-j3)/(mp-j3)*mp jk=((mp-1-j3)*j+1)/(mp-j3) do k=1,l do i=1,np cfx=tnyx(i,k,jj)/tnyy(i,k,jj) cfy=1./tnyy(i,k,jj) cfz=tnyz(i,k,jj)/tnyy(i,k,jj) py0=-cfy*sffly(i,k,jj)*etai(i,j,k) + -cfx*(px(i,j,k)+px(i-1,j,k))*0.5 + -cfz*(pz(i,j,k)+pz(i,j,k-1))*0.5 g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) gf21= g11*g12 + g21*g22 gf22= g12**2 + g22**2 gf23= g12*g13 + g22*g23 fy0=gf21*( px(i,j,k)+px(i-1,j,k) )*0.5 + +gf22*py0 + +gf23*( pz(i,j,k)+pz(i,j,k-1) )*0.5 diss=eta(i,j,k) ! kinematic viscosity diss=diss*rho(i,j,k) ! dynamic viscosity fy0=diss*fy0 fy(i,js,k)=2.*fy0-fy(i,jk,k) enddo enddo endif enddo endif #endif do k=1,L-1 do j=1,mp do i=1,np fz(i,j,k)=f3(i,j,k) enddo enddo enddo c----------> BC for zbar component of Fickian flux if(ibcz.eq.1) then do j=1,mp do i=1,np fz(i,j,0)=fz(i,j,l-1) fz(i,j,l)=fz(i,j, 1 ) enddo enddo else do k=1,l,l-1 ! =1 or =l kk=1+k/l ! =1 =2 ks=(k-1)/(l-1)*l ! =0 =l ki=((l-2)*k+1)/(l-1) ! =1 =l-1 do j=1,mp do i=1,np cfz= 1./tnzz(i,j,kk) cfx=tnzx(i,j,kk)/tnzz(i,j,kk) cfy=tnzy(i,j,kk)/tnzz(i,j,kk) pz0=-cfz*sfflz(i,j,kk)*etai(i,j,k) + -cfx*(px(i,j,k)+px(i-1, j,k))*0.5 + -cfy*(py(i,j,k)+py(i,j-j3,k))*0.5 g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) gf31= g11*g13 + g21*g23 gf32= g12*g13 + g22*g23 gf33= g13**2 + g23**2 + g33**2 fz0= gf31*( px(i,j,k)+px(i-1, j,k) )*0.5 + +gf32*( py(i,j,k)+py(i,j-j3,k) )*0.5 + +gf33*pz0 diss=eta(i,j,k) ! kinematic viscosity diss=diss*rho(i,j,k) ! dynamic viscosity fz0=diss*fz0 fz(i,j,ks)= 2.*fz0-fz(i,j,ki) c if(k.eq.l) fz(i,j,ks)=fz(i,j,ki) enddo enddo enddo endif c----------> divergence of Fickian fluxes do k=1,L do j=1,mp do i=1,np dvf(i,j,k)=( dxi*(fx(i,j,k)-fx(i-1,j,k)) . +dyi*(fy(i,j,k)-fy(i,j-1,k)) . +dzi*(fz(i,j,k)-fz(i,j,k-1)) ) enddo enddo enddo c enforce cyclicity if (istab.eq.1.and.isphere.eq.0) then iencyc=1 else iencyc=0 endif if (iencyc.eq.1) then if(ibcx.eq.1) then call updatelr(dvf,np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,L do j=1,mp dvf(np,j,k)=dvf(np+1,j,k) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(dvf,np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,L do i=1,np dvf(i,mp,k)=dvf(i,mp+j3,k) enddo enddo endif endif if(ibcz.eq.1) then do j=1,mp do i=1,np dvf(i,j,l)=dvf(i,j,1) enddo enddo endif endif do k=1,L do j=1,mp do i=1,np fp(i,j,k) = dvf(i,j,k)*rhoi(i,j,k) c fp(i,j,k)= fp(i,j,k)+2.*dvf(i,j,k)*rhoi(i,j,k) enddo enddo enddo #if (TIMEPLT == 1) call ttend(45) #endif return end subroutine indexdef include 'param.nml' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/indexpar/ imm(np),ipp(np), * jmm(mp),jpp(mp), * kmm(l ),kpp(l ), * ibox,iboy,iboz ibox=1-ibcx iboy=1-ibcy iboz=1-ibcz c DO k=1,L kmm(k)=ibcz*(k-1+(l+1-k)/l*(l-1))+iboz*max0(k-1,1) kpp(k)=ibcz*(k+1 -k /l*(l-1))+iboz*min0(k+1,l) ENDDO #if (POLES == 0) DO j=1,MP C jm=ibcy*(j-j3+(m+j3-j)/m*(m-1))+(1-ibcy)*max0(j-j3,1) C jp=ibcy*(j+j3 -j /m*(m-1))+(1-ibcy)*min0(j+j3,m) if (botedge.eq.1 .and. j.eq.1) then jmm(j)=ibcy*(1-2*j3)+iboy else jmm(j)=j-1 end if if (topedge.eq.1 .and. j.eq.mp) then jpp(j)=ibcy*(mp+2*j3)+iboy*mp else jpp(j)=j+1 end if ENDDO DO i=1,NP C im=ibcx*(i-1+(n+1-i)/n*(n-1))+(1-ibcx)*max0(i-1,1) C ip=ibcx*(i+1 -i /n*(n-1))+(1-ibcx)*min0(i+1,n) if (leftedge.eq.1 .and. i.eq.1) then imm(i)=ibcx*(-1)+ibox else imm(i)=i-1 end if if (rightedge.eq.1 .and. i.eq.np) then ipp(i)=ibcx*(np+2)+ibox*np else ipp(i)=i+1 end if ENDDO #else DO j=1,MP jmm(j)=j-1 jpp(j)=j+1 ENDDO DO i=1,NP imm(i)=i-1 ipp(i)=i+1 ENDDO #endif return end #endif /* endif SGS == 2 */ #endif /* endif ANALIZE == 0 */ subroutine lapdf(p,r,c,Prinv,hx,hy,hz,pz,itf) include 'param.nml' include 'msg.inc' dimension p(1-ih:np+ih, 1-ih:mp+ih, l), . r(1-ih:np+ih, 1-ih:mp+ih, l), . c(1-ih:np+ih, 1-ih:mp+ih, l), . hx(1-ih:np+ih, 1-ih:mp+ih, l), . hy(1-ih:np+ih, 1-ih:mp+ih, l), 2 hz(1-ih:np+ih, 1-ih:mp+ih, l), 1 Prinv(1-ih:np+ih, 1-ih:mp+ih, l), . pz(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1), . srff(1-ih:np+ih, 1-ih:mp+ih) ! ! Subroutine calculates diffusion terms, ! input fields: p-scalar field, c-eddy diffusivity, ! the output diffusion term is in matrix: r. ! Note that this subroutine is called only when ivisc=1. ! hy,hz are work arrays !--------------------------------------------------------------------- common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/stresd/ diagstr(8),ivis,irid,itstr common/sgscnst/ ceps,cL,cm,cs,prndt common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (TIMEPLT == 1) call ttbeg(48) #endif hdxi=0.5*dxi hdyi=0.5*dyi hdzi=0.5*dzi pri=1./prndt if(itf.eq.0) pri=1. compute z-derivatives at (i,j,k+-1/2) call update(p,np,mp,l,np,mp,iup) do k=2,L do j=1,mp do i=1,np pz(i,j,k)=dzi*(p(i,j,k)-p(i,j,k-1)) end do end do end do IF(IBCZ.EQ.0) THEN do j=1,mp do i=1,np pz(i,j,L+1)=-pz(i,j,L) end do end do corporate surface fluxes for theta, qv, and everything else(=0 flux) if (itf.eq.1) then ! temperature, do j=1,mp do i=1,np srff(i,j)=hfx(i,j) enddo enddo else if (itf.eq.-1) then ! moisture, do j=1,mmsp do i=1,nmsp srff(i,j)=qfx(i,j) enddo enddo else do j=1,mp do i=1,np srff(i,j)=0. enddo enddo endif do j=1,mp do i=1,np G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2 srff(i,j) = sqrt(g33)*srff(i,j)/amax1(pri*c(i,j,1),1.e-10) enddo enddo #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge jllim = 1 + (j3-ibcy)*botedge julim = mp + (ibcy-j3)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 21 j=jllim,julim #if (POLES == 0) if (j3.eq.1) then if (topedge.eq.1 .and. j.eq.mp) then jp1 = mp + 2 else jp1 = j + 1 end if if (botedge.eq.1 .and. j.eq.1) then jm1 = -1 else jm1 = j - 1 end if else jp1=1 jm1=1 end if cvec jp1=j+j3-j/m*(m-1) cvec jm1=j-j3+(m-j)/(m-j3)*(m-j3) #else jp1 = j + 1 jm1 = j - 1 #endif do 21 i=illim,iulim #if (POLES == 0) if (rightedge.eq.1 .and. i.eq.np) then ip1 = np + 2 else ip1 = i + 1 end if if (leftedge.eq.1 .and. i.eq.1) then im1 = -1 else im1 = i - 1 end if cvec ip1=i+1-i/n*(n-1) cvec im1=i-1+(n-i)/(n-1)*(n-1) #else ip1 = i + 1 im1 = i - 1 #endif G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2*Prinv(i,j,1) px=hdxi*(p(ip1,j,1)-p(im1,j,1)) py=hdyi*(p(i,jp1,1)-p(i,jm1,1))*j3 21 pz(i,j,1)=-2.*(srff(i,j)+g13*px+g23*py)/g33-pz(i,j,2) #if (POLES == 0) if(ibcx.eq.0) then illim = leftedge + np*(1-leftedge) iulim = np*rightedge + 1*(1-rightedge) jllim = 1 + (j3-ibcy)*botedge julim = mp + (ibcy-j3)*topedge do 211 i=illim,iulim,np-1 do 2111 j=jllim,julim if (j3.eq.1) then if (topedge.eq.1 .and. j.eq.mp) then jp1 = mp + 2 else jp1 = j + 1 end if if (botedge.eq.1 .and. j.eq.1) then jm1 = -1 else jm1 = j - 1 end if else jp1=1 jm1=1 end if cvec jp1=j+j3-j/m*(m-1) cvec jm1=j-j3+(m-j)/(m-j3)*(m-j3) G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2*Prinv(i,j,1) py=hdyi*(p(i,jp1,1)-p(i,jm1,1))*j3 2111 pz(i,j,1)=-2.*(srff(i,j)+g23*py)/(g33-g13*g13)-pz(i,j,2) if(ibcy.eq.0.and.j3.eq.1) then jllim = 1*botedge + mp*(1-botedge) julim = mp*topedge + 1*(1-topedge) do 2112 j=jllim,julim,mp-j3 2112 pz(i,j,1)=-2.*srff(i,j)/(gi(i,j)**2*Prinv(i,j,1))-pz(i,j,2) endif 211 continue endif if(ibcy.eq.0.and.j3.eq.1) then jllim = 1*botedge + mp*(1-botedge) julim = mp*topedge + 1*(1-topedge) illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge do 212 j=jllim,julim,mp-j3 do 2121 i=illim,iulim if (rightedge.eq.1 .and. i.eq.np) then ip1 = np + 2 else ip1 = i + 1 end if if (leftedge.eq.1 .and. i.eq.1) then im1 = -1 else im1 = i - 1 end if cvec ip1=i+1-i/n*(n-1) cvec im1=i-1+(n-i)/(n-1)*(n-1) G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2*Prinv(i,j,1) px=hdxi*(p(ip1,j,1)-p(im1,j,1)) 2121 pz(i,j,1)=-2.*(srff(i,j)+g13*px)/(g33-g23*g23)-pz(i,j,2) 212 continue endif #endif ELSE do j=1,mp do i=1,np pz(i,j,L+1)=pz(i,j,2) pz(i,j, 1 )=pz(i,j,L) end do end do ENDIF call update(c,np,mp,l,np,mp,1) if (rightedge.eq.0 .and. topedge.eq.0) then call update(pz,np,mp,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(pz,np+1,mp,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(pz,np,mp+1,l+1,np+1,mp+1,1) else call update(pz,np+1,mp+1,l+1,np+1,mp+1,1) end if compute x-flux at (i+-1/2,j,k) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,l do j=1,mp do i=illim,iulim G110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) G11m=1./((1-icylind)*gmm(i-1,j,k)*cosa(i,j)+icylind*1.) G11a=0.5*(G110+G11m) g13=0.5*gmul(k)*(G11m*s13(i-1,j)+G110*s13(i,j)) pza=0.25*(pz(i-1,j,k)+pz(i,j,k)+pz(i-1,j,k+1)+pz(i,j,k+1)) coef=0.25*pri*(c(i-1,j,k)+c(i,j,k)) . *(rho(i-1,j,k)+rho(i,j,k)) Pxa=dxi*(p(i,j,k)-p(i-1,j,k)) hx(i,j,k)=( G11a*pxa + g13*pza )*coef end do end do end do #if (POLES == 0) create boundary conditions at i=1 if(ibcx.eq.1) call updatelr(hx,np,mp,l,np,mp,1) if (leftedge.eq.1) then do j=1,mp do k=1,l cdel hx(1,j,k) = (ibcx-1)*hx(2,j,k) + ibcx*hx(0,j,k) hx(1,j,k) = hx(2,j,k) end do end do end if #endif c compute y-flux at (i,j+-1/2,k) if (j3.eq.1) then #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp #endif do k=1,l do j=jllim,julim do i=1,np G220=1./gmm(i,j,k) G22m=1./gmm(i,j-1,k) G22a=0.5*(G220+G22m) g23=0.5*gmul(k)*(G22m*s23(i,j-j3)+G220*s23(i,j)) pza=0.25*( pz(i,j-j3,k ) + pz(i,j,k ) . + pz(i,j-j3,k+1) + pz(i,j,k+1) ) coef=0.25*pri*(c(i,j-j3,k)+c(i,j,k))* 1 (rho(i,j-j3,k)+rho(i,j,k)) pya=dyi*(p(i,j,k)-p(i,j-j3,k)) hy(i,j,k)=( G22a*pya + g23*pza )*coef end do end do end do #if (POLES == 0) create boundary conditions at j=1 if(ibcy.eq.1) call updatebt(hy,np,mp,l,np,mp,1) if (botedge.eq.1) then do k=1,l do i=1,np hy(i,1,k)= (ibcy-1)*hy(i,2,k) + ibcy*hy(i,0,k) end do end do end if #endif endif compute z-flux at (i,j,k+-1/2) ! i) include the dh/dx and dh/dz terms call updatelr(hx,np,mp,l,np,mp,iupx) #if (POLES == 0) illim = 1 iulim = np - 1*rightedge #else illim = 1 iulim = np #endif do k=2,l do j=1,mp do i=illim,iulim G110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g13=0.5*(gmul(k)+gmul(k-1))*s13(i,j)*G110 gii=gi(i,j) hxa=0.25*(hx(i,j,k-1)+hx(i+1,j,k-1)+hx(i,j,k)+hx(i+1,j,k)) coef=0.25*pri*(c(i,j,k)+c(i,j,k-1)) . *(rho(i,j,k)+rho(i,j,k-1)) hza=gii*pz(i,j,k)*coef*0.5*(Prinv(i,j,k)+Prinv(i,j,k-1)) hz(i,j,k)= gii*hza + g13*hxa end do end do end do #if (POLES == 0) if (rightedge.eq.1) then corporate b.c. for hx on i=n+1 do k=2,l do j=1,mp G110=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g13=0.5*(gmul(k)+gmul(k-1))*s13(np,j)*G110 gii=gi(np,j) hx1 = (ibcx-1)*hx(np,j,k-1) + ibcx*hx(np+2,j,k-1) hx2 = (ibcx-1)*hx(np,j,k) + ibcx*hx(np+2,j,k) hxa=0.25*(hx(np,j,k-1)+hx1+hx(np,j,k)+hx2) coef=0.25*pri*(c(np,j,k)+c(np,j,k-1)) . *(rho(np,j,k)+rho(np,j,k-1)) hza=gii*pz(np,j,k)*coef*0.5*(Prinv(np,j,k)+Prinv(np,j,k-1)) hz(np,j,k)= gii*hza + g13*hxa end do end do end if #endif ! ii) include the dh/dy term if 3D if(j3.eq.1) then call updatebt(hy,np,mp,l,np,mp,iupy) #if (POLES == 0) jllim = 1 julim = mp - 1*topedge #else jllim = 1 julim = mp #endif do k=2,l do j=jllim,julim do i=1,np G220=1./gmm(i,j,k) g23=0.5*(gmul(k)+gmul(k-1))*s23(i,j)*G220 hya=0.25*(hy(i,j,k-1)+hy(i,j+j3,k-1)+ 1 hy(i,j,k)+hy(i,j+j3,k)) hz(i,j,k)=hz(i,j,k) + g23*hya end do end do end do #if (POLES == 0) if (topedge.eq.1) then do k=2,l do i=1,np corporate b.c. for hy on j=m+1 G220=1./gmm(i,mp,k) g23=0.5*(gmul(k)+gmul(k-1))*s23(i,mp)*G220 hy1= (ibcy-1)*hy(i,mp,k-1) + ibcy*hy(i,mp+2,k-1) hy2= (ibcy-1)*hy(i,mp,k) + ibcy*hy(i,mp+2,k) hya=0.25*(hy(i,mp,k-1)+hy1+hy(i,mp,k)+hy2) hz(i,mp,k)=hz(i,mp,k) + g23*hya end do end do endif #endif endif create boundary conditions at k=1; for k=L see divergence below IF(IBCZ.EQ.0) THEN c surface fluxes: if (itf.eq.1) then ! temperature, do j=1,mp do i=1,np G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2 hz(i,j,1)=-2.*sqrt(g33)*rho(i,j,1)*hfx(i,j)-hz(i,j,2) enddo enddo else if (itf.eq.-1) then ! moisture, do j=1,mp do i=1,np G110=1./((1-icylind)*gmm(i,j,1)*cosa(i,j)+icylind*1.) G220=1./gmm(i,j,1) g13=s13(i,j)*gmul(1)*G110 g23=s23(i,j)*gmul(1)*G220 g33=g13**2+g23**2+gi(i,j)**2 hz(i,j,1)=-2.*sqrt(g33)*rho(i,j,1)*qfx(i,j)-hz(i,j,2) enddo enddo else do j=1,mp do i=1,np c hz(i,j,1)=-hz(i,j,2) hz(i,j,1)= hz(i,j,2) end do end do end if ELSE do j=1,mp do i=1,np hz(i,j,1)= hz(i,j,L) end do end do ENDIF compute Laplacian term by term do k=1,l do j=1,mp do i=1,np r(i,j,k)=0. end do end do end do compute d/dx(dh/dx) #if (POLES == 0) illim = 1 iulim = np - 1*rightedge #else illim = 1 iulim = np #endif do k=1,l do j=1,mp do i=illim,iulim G110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) G11p=1./((1-icylind)*gmm(i+1,j,k)*cosa(i+1,j)+icylind*1.) r(i,j,k) = dxi*(hx(i+1,j,k)*G11p-hx(i,j,k)*G110) end do end do end do #if (POLES == 0) create boundary conditions on hx at i=n+1 if (rightedge.eq.1) then do j=1,mp do k=1,l hxn=hx(np,j,k) hxnp1 = (ibcx-1)*hxn + ibcx*hx(np+2,j,k) r(np,j,k) = dxi*(hxnp1-hxn) end do end do end if #endif c for 3D problem compute d/dy(dh/dy) and add to r if(j3.eq.1) then #if (POLES == 0) jllim = 1 julim = mp - 1*topedge #else jllim = 1 julim = mp #endif do k=1,l do j=jllim,julim do i=1,np G220=1./gmm(i, j ,k) G22p=1./gmm(i,j+1,k) r(i,j,k) = r(i,j,k) + dyi*(hy(i,j+1,k)*G22p-hy(i,j,k)*G220) end do end do end do #if (POLES == 0) create boundary conditions at j=m+1 if (topedge.eq.1) then do k=1,l do i=1,np hymp1= (ibcy-1)*hy(i,mp,k) + ibcy*hy(i,mp+2,k) r(i,mp,k) = r(i,mp,k) + dyi*(hymp1-hy(i,mp,k)) end do end do end if #endif endif compute d/dz(dh/dz) and add to r IF(IBCZ.EQ.0) THEN do j=1,mp do i=1,np do k=1,l-1 r(i,j,k) = r(i,j,k) + dzi*(hz(i,j,k+1)-hz(i,j,k)) end do corporate b.c. hz(i,j,L+1)=-hz(i,j,L) at k=L c hzLp1 =-hz(i,j,l) hzLp1 = hz(i,j,l) r(i,j,l) = r(i,j,l) + dzi*(hzLp1-hz(i,j,l)) end do end do ELSE do j=1,mp do i=1,np do k=1,l-1 r(i,j,k) = r(i,j,k) + dzi*(hz(i,j,k+1)-hz(i,j,k)) end do corporate b.c. hz(i,j,L+1)=-hz(i,j,L) at k=L r(i,j,l) = r(i,j,1) end do end do ENDIF do k=1,l do j=1,mp do i=1,np r(i,j,k)=r(i,j,k)/rho(i,j,k) end do end do end do call update(r,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(48) #endif return end subroutine pertth(th,ishft) include 'param.nml' include 'msg.inc' dimension th(1-ih:np+ih,1-ih:mp+ih,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) #if (TIMEPLT == 1) call ttbeg(50) #endif do 1 k=1,l do 1 j=1,mp do 1 i=1,np 1 th(i,j,k)=th(i,j,k)+ishft*the(i,j,k) #if (TIMEPLT == 1) call ttend(50) #endif return end subroutine tinit(z,x,y,tau,lipps,initi) include 'param.nml' include 'msg.inc' dimension z(l),x(n),y(m) dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) #if (TIMEPLT == 1) call ttbeg(9) #endif c if(initi.eq.1) call tinit_i(z,x,y,tau,lipps) if(initi.eq.0) call tinit_r(z,tau,lipps) c #if (TIMEPLT == 1) call ttend(9) #endif return end subroutine tinit_r(z,tau,lipps) calculate initial profiles when starting from real sounding include 'param.nml' include 'msg.inc' dimension z(l) dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profrhoi/rhoi(np,mp,l) common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw c original davies coefficients for nr(x or y)=6 c data relb/1.,0.98,0.9,0.5,0.1,0.02/ common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs dimension tme1(l),the1(l),qve1(l),ue1(l),ve1(l) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccc environmental sounding: ccc you may enter either pressure or height for a given level ccc (the other one should be set to zero and this subroutine ccc will automatically calculate it); if you do not use potential ccc temperature on input, activate the appropriate code below. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc parameter(npin=31) dimension press(npin),temp(npin),zin(npin), 1 vap(npin),uu(npin),vv(npin) cc pressure in hPa: DATA PRESS/1017.,1000.,980.,960.,950.,930.,910.,900.,875., . 850.,840.,830.,820.,810.,800.,775.,750.,700.,650.,600.,550., . 500.,450.,400.,350.,300.,250.,200.,150.,100.,50./ cc height in m: DATA ZIN /NPIN*0./ cc potential temperature in K: DATA TEMP/25.0,23.5,21.8,20.2,19.7,18.8,18.0,17.7,16.5,15.4, . 15.0,15.5,15.8,15.6,15.2,14.3,13.0,10.0, 6.7, 3.0,-1.3,-6.0, . -11.2,-17.0,-24.0,-32.9,-43.5,-55.0,-67.0,-77.0,-77.0/ ccwater vapor mixing ratio in g/kg: DATA VAP/15.6,14.7,13.7,12.7,12.0,11.0,10.0,9.6,8.6,7.6,7.2, . 6.9,6.5,6.2,5.9,5.3,4.6,3.5,1.9,0.9,0.5,0.46,0.31,0.20,0.11, . 0.05,0.015,0.004,0.0009,0.0002,0.0001/ cc x and y velocity components in m/s: DATA UU/19*-10.3,-8.5,-6.0,-3.5,-1.25,0.5,2.25,3.6,4.25, . 3.75,1.0,-9.8,-17.3/ DATA VV/22*0.,7.8,7.8,7.6,6.9,4.0,1.0,0.3,0.1,0./ cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c fs(zz)=(1.-exp(-zz/SD)) c fsi(zt)=-SD*alog(1.-zt/zb*fs(zb)) c fs(zz)=zz fsi(zt)=zt convert from temperature (deg C or K) into potential temperature do k=1,npin c temp(k)=temp(k)*(1.e3/press(k))**(rg/cp) temp(k)=(temp(k)+273.16)*(1.e3/press(k))**(rg/cp) enddo cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc utr=0. do ip=1,npin uu(ip)=uu(ip)-utr enddo cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc compute approximated height of pressure levels: if (zin(2).lt.1.e-4) then zin(1)=0. do k=2,npin km=k-1 tempk =temp(k )*(1.e3/press(k ))**(-rg/cp) . * (1.+.6e-3*vap(k )) tempkm=temp(km)*(1.e3/press(km))**(-rg/cp) . * (1.+.6e-3*vap(km)) delt=tempk-tempkm if (delt.gt.1.e-4) then tavi=alog(tempk/tempkm)/delt else tavi=1./tempk endif deltz=-rg/(tavi*g) * alog(press(k)/press(km)) zin(k)=zin(km)+deltz end do end if compute approximate pressure of height levels: if (press(1).lt.1.e-4) then press(1)=pr00/100. do k=2,npin km=k-1 tempk =temp(k ) tempkm=temp(km) delt=tempk-tempkm if (delt.gt.1.e-4) then tavi=alog(tempk/tempkm)/delt else tavi=1./tempk endif rc=rg/cp rci=1./rc press(k)=( press(km)**rc - . g*(1.e3)**rc*tavi*(zin(k)-zin(km))/cp )**rci enddo endif c print*,'INPUT SOUNDING' c do k=1,npin c print 921,k,zin(k),press(k),temp(k),vap(k) c921 format(1x,'k,z,p,theta,qv: ',i4,4e17.5) c enddo compute environmental profiles from sounding assuming no topography: cc surface data: iisn=1 the1(1)=temp(iisn) tme1(1)=the1(1) * (1000./press(iisn))**(-rg/cp) qve1(1)=vap(iisn)*1.e-3 ue1(1)=uu(1) ve1(1)=vv(1) c print*,'DETERMINED SURFACE DATA' cc higher levels - interpolate: c print*,'INTERPOLATION TO HIGHER LEVELS' do k=2,l c print*,'k=',k do kk=2,npin iisn=kk-1 if(zin(kk).ge.z(k)) go to 665 enddo c print*,'INPUT SOUNDING DOES NOT GO HIGH ENOUGH. STOP.' stop 'SOUNDING' 665 continue c print*,'iisn=',iisn coe2=(z(k)-zin(iisn))/(zin(iisn+1)-zin(iisn)) the1(k)=coe2*temp(iisn+1) + (1.-coe2)*temp(iisn) qve1(k)=(coe2*vap(iisn+1) + (1.-coe2)*vap(iisn))*1.e-3 presnl=coe2*press(iisn+1) + (1.-coe2)*press(iisn) tme1(k)=the1(k) * (1000./presnl)**(-rg/cp) ue1(k)=coe2*uu(iisn+1) + (1.-coe2)*uu(iisn) ve1(k)=coe2*vv(iisn+1) + (1.-coe2)*vv(iisn) end do c print*,'ENVIRONMENTAL PROFILES' do k=1,l c print 200,z(k)/1.e3,the1(k),tme1(k),qve1(k)*1.e3,ue1(k),ve1(k) 200 format(1x,'z,the,tme,qve,ue,ve:',3f10.3,e12.3,2f10.3) enddo compute th00,tt00,pr00,rh00 and average stability for base state profiles th00=the1(1) tt00=tme1(1) tvirt=tme1(1)*(1.+.6*qve1(1)) rh00=press(1)*100./(rg*tvirt) pr00=press(1)*100. sum=0. do k=2,l-1 sum = sum + (the1(k+1)-the1(k-1))/the1(k) enddo st=sum/(float(l-2)*2.*dz) c print*,'th00,tt00,pr00,rh00,st: ',th00,tt00,pr00,rh00,st c smooth environmental profiles c filter 2 and 4 dz waves call filtprf(the1,l,1,1) call filtprf(ue1 ,l,1,1) call filtprf(ve1 ,l,1,1) call filtprf(tme1,l,1,1) call filtprf(qve1,l,1,1) create environmental profiles; topography is now considered: do i=1,np do j=1,mp do k=1,l zstr=fsi(z(k)) zcr(k)=zstr/gi(i,j)+zs(i,j) end do if (moist.eq.1) then do k=1,l kk=zcr(k)/dz+1 kk=min(l,max(1,kk)) kkp=min(l,kk+1) coe=(zcr(k)-z(kk))/dz tme(i,j,k)=coe*tme1(kkp)+(1.-coe)*tme1(kk) qve(i,j,k)=coe*qve1(kkp)+(1.-coe)*qve1(kk) the(i,j,k)=coe*the1(kkp)+(1.-coe)*the1(kk) ue(i,j,k)=coe*ue1(kkp)+(1.-coe)*ue1(kk) ve(i,j,k)=coe*ve1(kkp)+(1.-coe)*ve1(kk) end do else do k=1,l kk=zcr(k)/dz+1 kk=min(l,max(1,kk)) kkp=min(l,kk+1) coe=(zcr(k)-z(kk))/dz the(i,j,k)=coe*the1(kkp)+(1.-coe)*the1(kk) ue(i,j,k)=coe*ue1(kkp)+(1.-coe)*ue1(kk) ve(i,j,k)=coe*ve1(kkp)+(1.-coe)*ve1(kk) end do endif compute reference state vertical profiles for every x,y point call thprof(tau(1,i,j,1),zcr,l,lipps) do k=1,l th0(i,j,k)=tau(k,i,j,1) end do call rhprof(tau(1,i,j,1),zcr,l,lipps) do k=1,l dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) rho(i,j,k)=tau(k,i,j,1)/(gi(i,j)*gmus(k)) + *((1-icylind)*gmm(i,j,k)**2*cosa(i,j) + +icylind*gmm(i,j,k))*dnmi rhoi(i,j,k)=1./rho(i,j,k) end do end do end do call update(th0,np,mp,l,np,mp,1) call update(rho,np,mp,l,np,mp,iup) call update(the,np,mp,l,np,mp,iup) call update(ve, np,mp,l,np,mp,1) call update(ue, np,mp,l,np,mp,1) if (nmsp.eq.np) then call update(qve,np,mp,l,np,mp,1) call update(tme,np,mp,l,np,mp,1) end if call absorber(z,x,y,tau) call theimpl(tau) ! theta_e derivatives for implict model return end subroutine tinit_i(z,x,y,tau,lipps) c --- z,x,y are computational (transformed) coordinate arrays c --- tau is Rayleigh sponge damping field c --- lipps is flag for type of basic state (see below) calculate initial profiles when starting from idealized sounding include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) dimension x(n),y(m),z(l),aa(l),bb(l),ue0(l),ve0(l), 1 the0(l),te0(l),pe0(l),pe(l) c mihai mods for politropic model and/or stable layer dimension theq0(l) dimension tkapp(l) real n1,n2,n2e,n10,nad !polytropic indices for the ambient theta real k0, k0i, k0e, gte(l+1), gth(l+1) parameter (gkst=530.,th0kst=2.13e6,tt0kst=2.13e6,rh0kst=176.) common/diffus/ sk(l),skr(l),sls c --------------------- end of mihai mods common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/htflx/ hflx(l+1) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/profrhoi/rhoi(np,mp,l) common/refstprof/ trs(l),thrs(l),prs(l),rhors(l) common/enstprof/ tes(l),thes(l),rhoes(l) common/cmoist/ rv,t00,ee0,hlat common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/temp_p/ tup,tdn common/latent/ hlatv,hlats common /hstst/ theq(1-ih:np+ih,1-ih:mp+ih,l), . dfhs(1-ih:np+ih,1-ih:mp+ih,l), . hskf,hska,hsks, . qveq(1-ih:nmsp+ih,1-ih:mmsp+ih,lms) c --- th0,rho are basic state potential temperature and density fields c --- the,ue,ve are environmental theta, zonal, and meridional wind c --- wind fields c --- zcr is physical vertical coordinate (i.e., in reference system) c --- theq,tme,qve are moist theta, temperature, and water vapor c --- mixing ratio fields common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/mihaistr/ acns,beta,dzb,hpsl,kst c alim01(fi)=amax1(0.,amin1(1.,fi)) c comb(tm,td,tu,ad,au)= c 1 alim01((tm-td)/(tu-td))*au + alim01((tu-tm)/(tu-td))*ad c --- vertical stretching c ! GGstr: stretiching Chan&Sofia c fs(zz)=(1.-exp(-zz/SD)) c fsi(zt)=-SD*alog(1.-zt/zb*fs(zb)) c fs(zz)=zz fsi(zt)=zt !GGstr: stretiching Chan&Sofia ! H in the notes is zb ! R in the notes is rds ! I'm going to use SD as our coefficient Zg ! and will use fs as our function f ! parameter(SD = 10.) ! fs(zt) = (exp((zb - zt)*log(1. + SD)/zb) - 1.)/SD pi=acos(-1.) capi=1./cap cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc compute basic and environmental state profiles for every x,y point c --- CAUTION: in general these will be time variable! c --- physical altitude do j=1,mp do i=1,np do k=1,l zstr=fsi(z(k)) zcr(k)=zstr/gi(i,j)+zs(i,j) !GGstr: the variable zcr is z in the notes ! zcr(k) = zb*(1.-fs(z(k)))/(1.+ zb*fs(z(k))/rds) enddo enddo enddo npoly=1 if (npoly.eq.1) then c build ambient theta profile (from temperature and density) assuming c polytropic stratification n1=3.0 !polytropic index at the base of the SL below SCZ c n2=1.49999 !polytropic index for the SCZ n2=1.4999945 !polytropic index for the SCZ c n2=1.499996 !polytropic index for the SCZ c n2=1.499992 !polytropic index for the SCZ nad=1.5 dn120=n1-nad dn220=nad-n2 c intrfc=1 intrfc=0 itanh=1 if(intrfc.eq.1) then kst = 1 + hpsl/dz tes(kst) = tt0kst rhoes(kst) = rh0kst trs(kst) = tt0kst rhors(kst) = rh0kst thes(kst) = tt0kst gup = gkst do k=kst-1,1,-1 c n10 = n1 n10 = n1 - dn120*zcr(k)/hpsl rul = (rds+zcr(k+1))/(rds+zcr(k)) dtemp = gup*dz*rul/(rg*(n10+1)) dtempa = gup*dz*rul/(rg*(nad+1)) tes(k) = tes(k+1) + dtemp trs(k) = trs(k+1) + dtempa rhoes(k) = rhoes(k+1)/(1.-dtemp/tes(k))**n10 rhors(k) = rhors(k+1)/(1.-dtempa/trs(k))**nad thes(k) = tes(k)*(rh0kst*tt0kst/(rhoes(k)*tes(k)))**cap gup = gkst*((rds+zcr(kst))/(rds+zcr(k)))**2 enddo gb = gkst do k=kst+1,l if (itanh.eq.1) then select case(l) !modif for different l case(24) n10 = nad + dn220*0.5*(tanh(1.4*(kst+2.5-k))+ & tanh(1.4*(k-l+2.5))) case(47) n10 = nad + dn220*0.5*(tanh(0.6*(kst+6-k))+ & tanh(0.6*(k-l+6))) case(93) n10 = nad + dn220*0.5*(tanh(0.3*(kst+12-k))+ & tanh(0.3*(k-l+12))) case(185) n10 = nad + dn220*0.5*(tanh(0.15*(kst+24-k))+ & tanh(0.15*(k-l+24))) end select else n10 = n2 endif rlu = (rds+zcr(k-1))/(rds+zcr(k)) dtemp = gb*dz*rlu/(rg*(n10+1)) dtempa = gb*dz*rlu/(rg*(nad+1)) tes(k) = tes(k-1) - dtemp trs(k) = trs(k-1) - dtempa rhoes(k) = rhoes(k-1)*(1.-dtemp/tes(k-1))**n10 rhors(k) = rhors(k-1)*(1.-dtempa/trs(k-1))**nad thes(k) = tes(k)*(rh0kst*tt0kst/(rhoes(k)*tes(k)))**cap gb = gkst*((rds+zcr(kst))/(rds+zcr(k)))**2 enddo tt00 = trs(1) th00 = thes(kst) rh00 = rhors(1) pr00=rg*rh00*tt00 else !intrfc=0 tes(1)=tt00 thes(1)=tt00 rhoes(1)=rh00 do k=2,l if (zcr(k).le.hpsl) then c n10 = n1 n10 = n1 - dn120*zcr(k)/hpsl else if (itanh.eq.1) then select case(l) !modif for different l case(24) n10 = nad + dn220*0.5*(tanh(1.4*(kst+2.5-k))+ & tanh(1.4*(k-l+2.5))) case(47) n10 = nad + dn220*0.5*(tanh(0.6*(kst+6-k))+ & tanh(0.6*(k-l+6))) case(93) n10 = nad + dn220*0.5*(tanh(0.3*(kst+12-k))+ & tanh(0.3*(k-l+12))) case(185) n10 = nad + dn220*0.5*(tanh(0.15*(kst+24-k))+ & tanh(0.15*(k-l+24))) end select else n10 = n2 endif endif hb=rg*tes(k-1)*((rds+zcr(k-1))/rds)**2/g tes(k)=tes(k-1)*(1.-(rds+zcr(k-1))*(zcr(k)-zcr(k-1))/ & ((n10+1.)*hb*(rds+zcr(k)))) rhoes(k)=rhoes(k-1)*(1.-(rds+zcr(k-1))*(zcr(k)-zcr(k-1))/ & ((n10+1.)*hb*(rds+zcr(k))))**(n10) thes(k)=tes(k)*(rh00*tt00/(rhoes(k)*tes(k)))**cap enddo c --- basic state temperature call tprof(trs,zcr,l,lipps) c --- basic state density call rhprof(rhors,zcr,l,lipps) c --- basic state pressure c call pprof(prs,zcr,l,lipps) endif !intrfc=1 endif !npoly=1 ! iudm=0 if (iudm.eq.1) then open (unit=2,file='/RQexec/ghizarum/krt_udm_sl47.txt', & status='old') c read (2,100) (skr(k), k=1,l) close(unit=2) 100 format (6e15.6) endif c --- basic state potential temperature call thprof(thrs,zcr,l,lipps) if(mype.eq.0) then do k=1,l write(17,906) trs(k),thrs(k),tes(k),thes(k),rhors(k) enddo endif 906 format(5x,6f15.6) c 906 format(4x,6e15.6) call ambient(thes,tkapp) do 12 k=1,l do 12 j=1,mp do 12 i=1,np th0(i,j,k)=thrs(k) if (npoly.eq.1) then the(i,j,k)=thes(k) else the(i,j,k)=thrs(k) endif 12 continue c------------------------------------------------------------------c C IDEALIZED BASIC STATE PROFILES c c c c NOTE: pressure and temperature profiles c c are NOT computed unless MOISTMOD > 0 c c c c lipps = 0: This is classical BOUSSINESQ approximation. c c Constant density, linearly decreasing c c (p,T) -> there exists max. altitude c c beyond which profiles are nonphysical c c Th = T. c c c c lipps = 1: Ogura and Phillips ANELASTIC: see JAS V. c c 19, pp. 173-179, 1962. Characterized c c by single scale height - hr. c c Th = constant (isentropic atm.) c c T = linearly decreasing profile. c c -> there exists a height restriction c c beyond which profiles are nonphysical c c c c lipps = 2: Clark and Farley ANELASTIC: see JAS V.41, c c pp. 329-350, 1984. Assumes exp. profile c c for th with scale height - ht. Value of c c cp (or equivalently, cap) is chosen c c as second indepenent parameter. c c (rho,p,T) are all nonlinearly decreasing c c and go to zero value at finite altitude c c -> there exists a height restriction c c beyond which profiles are nonphysical c c c c lipps = 3: Bacmeister and Schoeberl ANELASTIC: see c c JAS V. 46, pp. 2109-2134, 1989. Assumes c c exp. profiles for rho and th with scale c c heights hr and ht, respectively. c c -> T = constant (isothermal atm.) c c No height restriction. c c c c------------------------------------------------------------------c do 10 j=1,mp do 10 i=1,np if(mhd.eq.0) then do 13 k=1,l dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) rho(i,j,k)=rhors(k)/(gi(i,j)*gmus(k)) + *((1-icylind)*gmm(i,j,k)**2*cosa(i,j) + +icylind*gmm(i,j,k))*dnmi if(dnmi.lt.0.and.k.eq.1) print*,'DNMI:',i,j,k, . rho(i,j,k),dnmi,stryy(i,j),strxx(i,j),stryx(i,j),strxy(i,j) rhoi(i,j,k)=1./rho(i,j,k) 13 continue else do k=1,l dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) rh0(i,j,k)=1./(gi(i,j)*gmus(k))* + ((1-icylind)*gmm(i,j,k)**2*cosa(i,j)+icylind*gmm(i,j,k))*dnmi rho(i,j,k)=rhors(k)*rh0(i,j,k) rhoi(i,j,k)=1./rho(i,j,k) enddo endif c------- construct environmental wind if(u0z.ge.1.e-15) then do k=1,l ue0(k)=u00+u0z*zcr(k) ! specified shear enddo else do k=1,l ue0(k)=u00*gmm(i,j,k) ! ~constant in altitude enddo u0s=u00*rdsi endif c------- construct geostrophic environmental state do 14 k=1,l ue(i,j,k)=ue0(k)*cosa(i,j) ve(i,j,k)=v00 14 continue if(mhd.eq.1) then imhd = 0 !mod init Bxe if(imhd.eq.1) then ampB=0.0001 hwln=y(m)-y(1) y0c=(y(m)+y(1))*.5 ja=(mpos-1)*mp + j argm=pi*(y(ja)-y0c)/hwln cosbt=cos(argm) endif do k=1,l C coslc=isphere*cosa(i,j)+(1-isphere)*cosbt c coslc=1 C bxe(i,j,k)=ampB*(coslc**2) C . *sin( pi*(zcr(k)/(zh(i,j)-zs(i,j))) ) bxe(i,j,k)=0. bye(i,j,k)=0. bze(i,j,k)=0. enddo endif if( icylind.eq.1) then do k=1,l ve(i,j,k)=ve0(k) ue(i,j,k)=ue0(k) the0(k)=th0(i,j,k) if(lipps.eq.0) the0(k)=th00*(1.- st*zcr(k)) the(i,j,k)=the0(k) enddo endif ihs=0 ! Held-Suarez flow if(ihs.eq.1) then c------------------------------------------------------------------c c c c See Held and Suarez, Bulletin of the AMS, V. 75, c c pp. 1825-1830, 1994 c c c c NOTE: th00 = 315K for HS paper c c c c------------------------------------------------------------------c c c --- construct dry part held-suarez environmental state hskf=1./( 24.*3600.) hska=1./(40.*24.*3600.) hsks=1./(4. *24.*3600.) sigb=0.7 sigi=1./(1.-sigb) dthy=60. dthz=10. hd=7000. ! density scale height xs=th00-dthy*sina(i,j)**2 xc=dthz*cosa(i,j)**2 do 5 k=1,l sgm=exp(-zcr(k)/hd) ! Basic state (p/p_ref) approx. sg0=sgm**cap ! conversion factor for temp->theta thstr=200./sg0 dfhs(i,j,k)=amax1(0., sigi*(sgm-sigb) ) theq(i,j,k)=amax1(thstr,xs-xc*alog(sgm)) ! full HS profile theqtmp = theq(i,1,k) ! sub HS profile #if (PARALLEL == 2) if(mpos.eq.1) then do idest=npos+nprocx-1,mysize-1,nprocx call MPI_Send(theqtmp,1,DC_TYPE, . idest,21,MPI_COMM_EULAG,ierr) enddo else isource=npos-1 call MPI_RECV(theqtmp,1,DC_TYPE, . isource,21,MPI_COMM_EULAG,status,ierr) endif call mybarrier() #endif the(i,j,k)=theqtmp 5 continue endif ! set HD environment = basic state cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (MOISTMOD > 0) #if (MOISTMOD == 1) c------- profiles for pressure, temperature, and relative humidity if(ihs.eq.1) then pr00=g*hd*rh00 do k=1,l pe(k)=pr00*exp(-zcr(k)/hd) tme(i,j,k)=the(i,j,k)*(pe(k)/pr00)**cap qve(i,j,k)=.92 ! set relative humidity end do else call teprof(pe0,te0,zcr,l,lipps) do k=1,l pe(k)=pe0(k) tme(i,j,k)=te0(k) qve(i,j,k)=.92 ! set relative humidity end do end if c -------------------------------------------------------------- c --- initialize env. moisture fields using Grawboski thermodynamics if(ice.eq.1) then ! COLD RAIN a=rg/rv b=hlats/rv d=hlatv/rv e=-cp/rg do k=1,l coe_l=comb(tme(i,j,k),tdn,tup,0.,1.) ! liquid contribution thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**e ! modify? tti=tme(i,j,k) delt=(tti-t00)/(tti*t00) esw=ee0*exp(d * delt) esi=ee0*exp(b * delt) qvsw=a * esw /(pre-esw) ! modify? qvsi=a * esi /(pre-esi) ! modify? qvs=coe_l*qvsw + (1.-coe_l)*qvsi qve(i,j,k)=qve(i,j,k)*qvs c --- held-suarez test if(ihs.eq.1) then tti=theq(i,j,k)/thetme coe_l=comb(tti,tdn,tup,0.,1.) ! liquid contribution delt=(tti-t00)/(tti*t00) esw=ee0*exp(d * delt) esi=ee0*exp(b * delt) qvsw=a * esw /(pre-esw) ! modify? qvsi=a * esi /(pre-esi) ! modify? qvs=coe_l*qvsw + (1.-coe_l)*qvsi qveq(i,j,k)=0.9*qvs ! set relative humidity end if c --- end HS test end do else ! WARM RAIN a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg do k=1,l thetme=the(i,j,k)/tme(i,j,k) thi=1./the(i,j,k) c thetme=the0(k)/te0(k) !uniform qv on the planet c thi=1./the0(k) !uniform qv on the planet pre=1.e5*thetme**e ! modify? ylc=b*thetme*t00*thi ees=ee0*exp(b-ylc) qvs=a*ees/(pre-ees) ! modify? qve(i,j,k)=qve(i,j,k)*qvs c --- held-suarez test if(ihs.eq.1) then thi=1./theq(i,j,k) ylc=b*thetme*t00*thi ees=ee0*exp(b-ylc) qvs=a*ees/(pre-ees) ! modify? qveq(i,j,k)=0.9*qvs ! set relative humidity end if c --- end HS test end do endif #endif #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 10 continue c compute thermal and radiative diffusivities for SUN iskrsm = 0 ! 1 for computing like in GONG report 14 sig=5.67e-8 ! W/(m^2*K^4) Stefan-Boltzmann if (iskrsm.eq.1) then c00i = 7.1548412e12 !Christensen-Dalsgaard GONG report 14 betai = 1.97541 etai = 0.138316 c00e = 1.6236784e-34 !also in Espinosa, Rieutord 2007 betae = -9.28289 etae = 0.407895 do k=1,l k0i = c00i*tes(k)**(-betai)*rhoes(k)**etai k0e = c00e*tes(k)**(-betae)*rhoes(k)**etae k0 = 1./(1./k0i + 1./k0e) skr(k) = 16.*sig*tes(k)**3/(3.*cp*k0*rhoes(k)**2) if(mype.eq.0) print *,'skr,k:',skr(k),k enddo else !iudm=1 skr-from UDM model !c open (unit=2,file='/RQexec/ghizarum/cottos/mhd2/skr.txt', ! open (unit=2,file='skr.txt', ! & status='old') ! read (2,111) (skr(k), k=1,l) ! close(unit=2) !111 format (5e15.6) do k=1,l skr(k)=tkapp(k) !GG ! if(mype.eq.0) print*, skr(k) ! k0=0.034*(1.+6.*1.e21*rhoes(k)*tes(k)**(-3.5))!Kramers'(Ruediger) ! skr(k) = 16.*sig*tes(k)**3/(3.*cp*k0*rhoes(k)**2) enddo endif c compute radiative diffusivity based on solar luminosity c do k=1,l c skr(l)=sls/( -4.*pi*(rds+zcr(k))**2*rhors(k)*cp* c & 0.5*(gte(k)+gte(k+1)) ) c enddo sls=3.86e26 ! solar luminosity do k=1,l if (zcr(k).le.hpsl) then c sk(k) = 1.e-1 c sk(k) = 1.e7*sqrt(rhobr(1)/rhobr(k)) c sk(k) = 1.e7*(rhobr(1)/rhobr(k)) c sk(k) = 1.e7*(rhobr(1)/rhobr(k))**2 c sk(k) = 1.e7*sqrt((rhobr(1)/rhobr(k))**3) c sk(k) = 1.e2 sk(k) = 1.e6 c sk(k) = 1.e7 c sk(k) = 1.e8 c sk(k) = 0. else c sk(k) = 1.e5*sqrt(rhobr(1)/rhobr(k)) c sk(k) = 1.e7*sqrt(rhobr(1)/rhobr(k)) c sk(k) = 1.e7*(rhobr(1)/rhobr(k)) c sk(k) = 1.e4*(rhobr(1)/rhobr(k))**2 c sk(k) = 3.245e8 c sk(k) = 1.0e8 c sk(k) = sk(k)*1.e-1 c sk(k) = 1.e9 sk(k) = 1.e6 c sk(k) = 1.e7 c sk(k) = 1.e8 c sk(k) = 1.e2 c sk(k) = 0. endif enddo call update(th0,np,mp,l,np,mp,1) call update(rho,np,mp,l,np,mp,iup) call update(the,np,mp,l,np,mp,iup) call update(ve, np,mp,l,np,mp,1) call update(ue, np,mp,l,np,mp,1) if(mhd.eq.1) then call update(rh0,np,mp,l,np,mp,iup) call update(bxe,np,mp,l,np,mp,1) call update(bye,np,mp,l,np,mp,1) call update(bze,np,mp,l,np,mp,1) endif if (nmsp.eq.np) then call update(qve,np,mp,l,np,mp,1) call update(tme,np,mp,l,np,mp,1) end if call absorber(z,x,y,tau) call theimpl(tau) ! theta_e derivatives for implict model create flux and roughness fields Z.S. do 30 j=1,mp do 30 i=1,np hfx(i,j)=hf00 ! heat flux in K*m/s 30 zo(i,j)=0.1 ! roughness parameter, m if (moist.eq.1) then do 31 j=1,mp do 31 i=1,np 31 qfx(i,j)=qf00 ! spec.hum.flux in kg/kg*m/s endif c special heat flux c zeta1=5. c zeta2=5. c do k=2,l c zcrn=(k*1.-1.5)/(l*1.-1.) c hflx(k)=((1.-exp(-zeta1-zeta2))/(zeta1*(1.-exp(-zeta2)))- c . exp(-zeta1*zcrn)/zeta1-(1.-exp(-zeta1))* c . exp(-zeta2*(1.-zcrn))/(zeta1*(1.-exp(-zeta2))))*(l*1.-1.) c hflx(k)=hflx(k)*(1.+((k-1.5)*dz)/rds)**2 c enddo c hflx(1)=-hflx(2) c hflx(l+1)=-hflx(l) c endof special return end ! subroutine ambient(th_amb,tkapp) ! include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp) common/polyindex/ m0,m1,m2,width_ic,z1,z2 . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) ! dimension pm0(l),tm0(l),z(l),rad(l),th_amb(l) dimension tkapp(l),rho_ad(l),t_ad(l),p_ad(l),th_ad(l) dimension rlnrhom(l),tempm(l),zz(l),dTdr(l),dTedr(l),rhom(l) dimension dlnTdr(l), dlnrdr(l),cs2(l),gravz(l) integer l1 real Gc, star_radii,temp0,rho0,dz,cap real u0(2),u1(2) external star_amb ! Gc=6.674e-11 rmin=rds star_radii = 6.9599e8 Rg=13732. cp=2.5*Rg temp0 = 2.3222e6 rho0 = 207.918 l1 = 19 u0(1) = temp0 u0(2) = rho0 tempm(l1) = u0(1) rhom(l1) = u0(2) th_amb(l1)=tempm(l1)*(((temp0*rho0)/(tempm(l1)*rhom(l1)))**cap) DO k = 1,l rad(k) = rds + zcr(k) END DO DO k = l1 - 1, 1, -1 dz = rad(k+1) - rad(k) CALL rk5vec(rad(k+1), 2, u0, -dz, star_amb, u1) u0(1) = u1(1) u0(2) = u1(2) tempm(k) = u1(1) rhom(k) = u1(2) th_amb(k)=tempm(k)*(((temp0*rho0)/(tempm(k)*rhom(k)))**cap) r0 = r1 END DO u0(1) = temp0 u0(2) = rho0 DO k = l1 + 1, l dz = rad(k) - rad(k-1) CALL rk5vec(rad(k-1), 2, u0, dz, star_amb, u1) u0(1) = u1(1) u0(2) = u1(2) tempm(k) = u1(1) rhom(k) = u1(2) th_amb(k)=tempm(k)*(((temp0*rho0)/(tempm(k)*rhom(k)))**cap) END DO ! ! --- isentropic state density call rhprof(rho_ad,zcr,l,1) call pprof(p_ad,zcr,l,1) call tprof(t_ad,zcr,l,1) if(mype.eq.0) then open(1,file="strat.dat") do k=1, l th_ad(k)=t_ad(k)*(((temp0*rho0)/(t_ad(k)*rho_ad(k)))**cap) write(1,'(F11.6,2x,F15.7,2x,F15.7,2x, & F15.7,2x,F15.7,2x,F15.7,2x,F15.7)') & rad(k)/star_radii, & tempm(k),rhom(k),th_amb(k),t_ad(k),rho_ad(k),th_ad(k) enddo close(1) endif return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! real function grav_rafa(x) real x real ag, bg, cg, dg ag = -7.67624479849e-24 bg = 1.65029739402e-14 cg = -1.26840190398e-05 dg = 3694.34945199 grav_rafa = ag*x**3 + bg*x**2 + cg*x + dg endfunction !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine star_isen (x,n,u,uprime) ! common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z integer n real x,mr, u(n),uprime(n) real g0, ag, bg, cg, dg g0 = grav_rafa(x) mr=1.5 uprime(1)=-g0/((mr+1.)*rg) uprime(2)=(u(2)/u(1))*(-g0/rg-uprime(1)) ! return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine star_amb (x,n,u,uprime) ! common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/sphere/ rds integer n real x,u(n),uprime(n),mr,m1,m0,m2,width,x1,x2 real g0,star_radius,xb real ag,bg,cg,dg ! g0 = g/(x/(rds))**2 ag = -7.67624479849e-24 bg = 1.65029739402e-14 cg = -1.26840190398e-05 dg = 3694.34945199 star_radius = 6.9599e8 x1 = 0.7*star_radius m0 = 2.5 m1 = 1.5001 width = 0.01*star_radius mr = m0 - (m0-m1)*0.5*(1. + erf((x-x1)/(width))) g0 = ag*x**3 + bg*x**2 + cg*x + dg uprime(1)=-g0/((mr+1.)*rg) uprime(2)=(u(2)/u(1))*(-g0/rg-uprime(1)) ! return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine rk4vec(t0,m,u0,dt,f,u) ! integer m, k external f real dt real f0(m),f1(m),f2(m),f3(m) real t0,t1,t2,t3 real u(m),u0(m),u1(m),u2(m),u3(m) ! call f(t0,m,u0,f0) ! t1=t0+dt/2.0D+00 do k=1,m u1(k)=u0(k)+dt*f0(k)/2.0D+00 enddo call f(t1,m,u1,f1) ! t2=t0+dt/2.0D+00 do k=1,m u2(k)=u0(k)+dt*f1(k)/2.0D+00 enddo call f(t2,m,u2,f2) ! t3=t0+dt do k=1,m u3(k)=u0(k)+dt*f2(k) enddo call f(t3,m,u3,f3) ! do k=1,m u(k)=u0(k)+dt*(f0(k)+2.0D+00*f1(k)+ & 2.0D+00*f2(k)+f3(k))/6.0D+00 enddo ! return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine rk5vec(x, m, f, dx, func, fnew) external func integer m real f(m), fnew(m), f1(m), f2(m), f3(m), f4(m), f5(m), f6(m) real k1(m), k2(m), k3(m), k4(m), k5(m), k6(m) real dx, x real x1, x2, x3, x4, x5, x6 f1(1:m) = f(1:m) x1 = x call func(x1, m, f1, k1) x2 = x + dx / 4. f2(1:m) = f(1:m) + (dx / 4.) * k1(1:m) call func(x2, m, f2, k2) x3 = x + dx / 4. f3(1:m) = f(1:m) + (dx / 8.) * (k1(1:m) + k2(1:m)) call func(x3, m, f3, k3) x4 = x + dx / 2. f4(1:m) = f(1:m) + (dx / 2.) * (2. * k3(1:m) - k2(1:m)) call func(x4, m, f4, k4) x5 = x + (3. * dx / 4.) f5(1:m) = f(1:m) + (dx / 16.) * (3. * k1(1:m) + 9. * k4(1:m)) call func(x5, m, f5, k5) x6 = x + dx f6(1:m) = f(1:m) + (dx / 7.) * (2. * k2(1:m) - 3. * k1(1:m) & + 12. * (k3(1:m) - k4(1:m)) + 8. * k5(1:m)) call func(x6, m, f6, k6) fnew(1:m) = f(1:m) + (dx / 90.) * (7. * k1(1:m) + 32. * k3(1:m) & + 12. * k4(1:m) + 32. * k5(1:m) + 7. * k6(1:m)) return end !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! function deriv4(xi, yi, ni,l) integer ni, l real deriv4 real xi(ni), yi(ni) if(ni.eq.1) then deriv4=(-yi(ni+2)+4.*yi(ni+1)-3.*yi(ni))/(2.*(xi(ni+1)-xi(ni))) elseif(ni.eq.l) then deriv4=(3.*yi(l)-4.*yi(l-1)+yi(l-2))/(2.*(xi(ni)-xi(ni-1))) else deriv4=(yi(ni+1)-yi(ni-1))/(2.*(xi(ni)-xi(ni-1))) endif return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! subroutine bridge_init() include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" !HAD TO DEFINE THIS: character(LEN=5) :: frn_name real :: frn_dt, dummy(1) integer :: proc_eu, isize, irank real :: pi=3.1415926, dx, rcoors(l),gb_m,t_norm_frn logical :: lok integer, dimension(MPI_STATUS_SIZE) :: stat character(LEN=5) :: unit_system real :: unit_length, unit_time, unit_BB, unit_T integer :: MPI_COMM_XBEAM, ipx, ipy, ipz, ip, tag common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) !---------------------------------- if (tag_frn <= 0) return if (mype.eq.0) then !print *, 'Initializing Briging process - Eulag' ! ! Send length of name of foreign code. ! call MPI_SEND(5,1,MPI_INTEGER,0,tag_frn,MPI_COMM_WORLD,ierr) ! ! Send name of foreign code. ! call MPI_SEND('EULAG',5,MPI_CHARACTER,0,tag_frn,MPI_COMM_WORLD, +ierr) ! ! Send processor numbers of foreign code. ! call MPI_SEND((/1,nprocy,nprocx/),3,MPI_INTEGER,0,tag_frn, +MPI_COMM_WORLD, ierr) ! ! Send gridpoint numbers of foreign code. ! call MPI_SEND((/l,m,n/),3,MPI_INTEGER,0,tag_frn, +MPI_COMM_WORLD, ierr) ! ! Send unit system name and units. ! !HOW THIS CONVERTION HSOULD BE DONE? call MPI_SEND('SI ',5,MPI_CHARACTER,0,tag_frn, + MPI_COMM_WORLD,ierr) !SYSTEM OF UNITS call MPI_SEND(1. ,1,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! LENGTH call MPI_SEND(1.,1,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! TIME call MPI_SEND(1.,1,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! Magnetic Field call MPI_SEND(1. ,1,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! Temperature !print *, 'Sent Units - Eulag' ! ! Send domain extents of foreign code. j loops over r, theta, phi. ! call MPI_SEND((/rds,rds+dz*(l-1),0.,pi,0.,2*pi/),6,DC_TYPE,0, +tag_frn,MPI_COMM_WORLD,ierr) !call MPI_SEND((/0.7,1.,0.,pi,0.,2*pi/),6,MPI_DOUBLE,0,tag_frn,MPI_COMM_WORLD,ierr) ! ! Send output timestep of foreign code (code units) ! call MPI_SEND(dt00*nbridge,1,DC_TYPE,0,tag_frn, +MPI_COMM_WORLD,ierr) ! ! Receive confirmation flag that setup is acceptable. ! call MPI_RECV(lok,1,MPI_LOGICAL,0,tag_frn, + MPI_COMM_WORLD,stat,ierr) if (.not.lok) then print*, 'not ok - EULAG' endif ! print *, 'EULAG - LOK' ! ! Send vector of global r-grid points. ! gb_m=0. do i=0,l-1 rcoors(i+1)=rds+i*dz gb_m=gb_m+grav_rafa(rcoors(i+1)) enddo gb_m = gb_m/l !print*, 'Eulag xcoords', dz call MPI_SEND(rcoors,l,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! ! Send normalized time for PENCIL, using average of Rafa's gravity ! t_norm_frn = sqrt(rds/gb_m) print*, 'EULAG - tnorm',dz,gb_m, t_norm_frn, l call MPI_SEND(t_norm_frn,1,DC_TYPE,0,tag_frn, + MPI_COMM_WORLD,ierr) ! ! Receive number of x-procs from Pencil. ! call MPI_RECV(nprocx_frn,1,MPI_INTEGER,0, +tag_frn,MPI_COMM_WORLD,stat,mpierr) call MPI_RECV(nprocy_frn,1,MPI_INTEGER,0, +tag_frn,MPI_COMM_WORLD,stat,mpierr) ! print *, 'EULAG - nproc_frn' ! ! Receive index range of buddy processors. ! do ip=0,nprocx_frn-1 tag=tag_frn+ip ! print *, 'EULAG - ip, tag : ', ip, tag call MPI_RECV(xind_rng(ip,:),2,MPI_INTEGER,ip,mype, + MPI_COMM_WORLD,stat,ierr) enddo !print *, 'EULAG - rank, xind', xind_rng(0:nprocx_frn-1,:) #endif endif c GM: Next block is to learn the position differences in terms of ranks from EULAG code and frn code call MPI_BCAST(nprocx_frn,1,MPI_INTEGER,0, +MPI_COMM_EULAG,ierr) call MPI_BCAST(nprocy_frn,1,MPI_INTEGER,0, +MPI_COMM_EULAG,ierr) call MPI_BCAST(xind_rng(0:nprocx_frn-1,:),2*nprocx_frn, + MPI_INTEGER,0, + MPI_COMM_EULAG,ierr) ! print *, 'EULAG - xind_rng', mype, xind_rng(0,1),xind_rng(0,2), ! . xind_rng(1,1),xind_rng(1,2) call find_proc_coord(mype, ipx, ipy) !peer_frn = mype * nprocx_frn peer_frn = ipx*nprocx_frn*nprocy_frn+ipy*nprocx_frn !print *, 'EULAG mype peer_frn', mype, peer_frn return end function u0_char(i,j,k) include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #endif common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/corio/ fcr0 ! Guilherme's function for differential rotation profile ! Although the function and variables are named _char, they are Andrés. real omega_c, omega_E, omega_char, omega_p real u0_char real a, pi, pi2 real r_tcl, w_tcl real rsun !if(mype.eq.0) print*, "fcr0 = ", fcr0 fcr0 = 6.060171e-6 * icorio !Constants based on Andrés paper pol_rate = 0.764 ! This rates comes from the first setup eq_rate = 1.092 !we did. omega_c = fcr0/2. ! Omega Core - Given by half the fcr0 variable omega_E = omega_c*eq_rate ! Omega Equator omega_p = omega_c*pol_rate ! Omega Poles a = 2.0*0.483 ! Strength of the "cos" terms in omega_s !!!!!!!!!!!!!!!!!!!!! pi=acos(-1.) pi2=2.*pi rsun = 6.96e8 r_tcl = 0.7*rsun w_tcl = 0.02*rsun omega_s = a*(sina(i,j))**2. + (1- a)*(sina(i,j))**4. rad = (rds+zcr(k)) fe = 0.5*(1+erf((rad-r_tcl)/w_tcl)) !I took out the Omega_c front term. No need for 2pi, it is already incerted into omegas omega_char=(fe*(omega_e-omega_c+(omega_p-omega_e)*omega_s)) u0_char = rad*cosa(i,j)*omega_char return end ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine theimpl(tau) include 'param.nml' include 'msg.inc' dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/gwimpl/ dthe(1-ih:np+ih,1-ih:mp+ih,l,3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) if(implgw.eq.1) then dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp - topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do k=1,l do j=1,mp do i=illim,iulim dthe(i,j,k,1)=dxil*(the(i+1,j,k)-the(i-1,j,k)) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp dthe(1 ,j,k,1)=(1-ibcx)*dxi*(the(2,j,k)-the( 1,j,k)) . +ibcx*dxil*(the(2,j,k)-the(-1,j,k)) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp dthe(np,j,k,1)=(1-ibcx)*dxi*(the(np,j,k)-the(np-1,j,k)) . +ibcx*dxil*(the(np,j,k)-the(np+2,j,k)) enddo enddo endif #endif do k=1,l do i=1,np do j=jllim,julim dthe(i,j,k,2)=dyil*(the(i,j+j3,k)-the(i,j-j3,k)) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np dthe(i,1,k,2)=(1-ibcy)*dyi*(the(i,1+j3,k)-the(i, 1,k)) . +ibcy*dyil*(the(i,1+j3,k)-the(i,1-2*j3,k)) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np dthe(i,mp,k,2)=(1-ibcy)*dyi*(the(i,mp,k)-the(i,mp- j3,k)) . +ibcy*dyil*(the(i,mp,k)-the(i,mp+2*j3,k)) enddo enddo end if #endif do k=2,l-1 do j=1,mp do i=1,np dthe(i,j,k,3)=dzil*(the(i,j,k+1)-the(i,j,k-1)) enddo enddo enddo if(ibcz.eq.0) then do j=1,mp do i=1,np dthe(i,j,1,3)= dzi*(the(i,j,2)-the(i,j,1)) dthe(i,j,l,3)= dzi*(the(i,j,l)-the(i,j,l-1)) enddo enddo else do j=1,mp do i=1,np dthe(i,j,1,3)= dzil*(the(i,j,2)-the(i,j,l-1)) dthe(i,j,l,3)= dzil*(the(i,j,2)-the(i,j,l-1)) enddo enddo endif dth=0.5*dt do k=1,l do j=1,mp do i=1,np g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) dthx=dth*(g11*dthe(i,j,k,1) + g12*dthe(i,j,k,2) + + g13*dthe(i,j,k,3)) dthy=dth*(g21*dthe(i,j,k,1) + g22*dthe(i,j,k,2) + + g23*dthe(i,j,k,3)) dthz=dth* g33*dthe(i,j,k,3) c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) c astr =dth*(tau(k,i,j,1)*(1.-relt)+relt) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) astr =dth*(tau(k,i,j,1)**2+relt**2) & /(tau(k,i,j,1)+relt+1.e-13) astri=1./(1.+astr) dthe(i,j,k,1)=dthx*astri dthe(i,j,k,2)=dthy*astri dthe(i,j,k,3)=dthz*astri enddo enddo enddo #if (POLES == 0) if(ibcx.eq.1) then call updatelr(dthe(1-ih,1-ih,1,1),np,mp,l,np,mp,1) call updatelr(dthe(1-ih,1-ih,1,2),np,mp,l,np,mp,1) call updatelr(dthe(1-ih,1-ih,1,3),np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,l do j=1,mp dthe(np,j,k,1)=dthe(np+1,j,k,1) dthe(np,j,k,2)=dthe(np+1,j,k,2) dthe(np,j,k,3)=dthe(np+1,j,k,3) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(dthe(1-ih,1-ih,1,1),np,mp,l,np,mp,1) call updatebt(dthe(1-ih,1-ih,1,2),np,mp,l,np,mp,1) call updatebt(dthe(1-ih,1-ih,1,3),np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,l do i=1,np dthe(i,mp,k,1)=dthe(i,mp+j3,k,1) dthe(i,mp,k,2)=dthe(i,mp+j3,k,2) dthe(i,mp,k,3)=dthe(i,mp+j3,k,3) enddo enddo endif endif #else call update2(dthe(1-ih,1-ih,1,1),np,mp,l,np,mp,1) call update2(dthe(1-ih,1-ih,1,2),np,mp,l,np,mp,1) call update2(dthe(1-ih,1-ih,1,3),np,mp,l,np,mp,1) #endif if(ibcz.eq.1) then do j=1,mp do i=1,np dthe(i,j,l,1)=dthe(i,j,1,1) dthe(i,j,l,2)=dthe(i,j,1,2) dthe(i,j,l,3)=dthe(i,j,1,3) enddo enddo endif else do k=1,l do j=1,mp do i=1,np dthe(i,j,k,1)=0. dthe(i,j,k,2)=0. dthe(i,j,k,3)=0. enddo enddo enddo endif return end subroutine absorber(z,x,y,tau) include 'param.nml' include 'msg.inc' dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) dimension x(n),y(m),z(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/davpol/ relpol(np,mp,l),dyabp,towyp,ipolar common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/mihaistr/ acns,beta,dzb,hpsl,kst #if (ANALIZE == 0) common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . src(1-ih:np+ih, 1-ih:mp+ih, l-1), . tmp(1-ih:np+ih, 1-ih:mp+ih) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 8), . src(1-ih:np+ih, 1-ih:mp+ih, l-1), . tmp(1-ih:np+ih, 1-ih:mp+ih) #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c fs(zz)=(1.-exp(-zz/SD)) c fsi(zt)=-SD*alog(1.-zt/zb*fs(zb)) c fs(zz)=zz fsi(zt)=zt compute absorbers at x boundaries if ( irlx.eq.1 ) then toliL=1./towxL toliR=1./towxR do j=1,mp xab1=xr1(j)*xc1(j)+dxabL !VEC xab1=xcr(1,j)*cosa(1,j)+dxabL xab2=xr2(j)*xc2(j)-dxabR !VEC xab2=xcr(n,j)*cosa(n,j)-dxabR do i=1,np ia=(npos-1)*np + i r0=xcr(i,j)*cosa(i,j) r1=amax1(0., xab1-r0)/dxabL r2=amax1(0., r0-xab2)/dxabR relb=toliL*r1+toliR*r2-2.*toliL*toliR*r1*r2/(toliL+toliR) tmp(i,j)=irlx*relb relx(i,j)=tmp(i,j) enddo enddo #if (POLES == 0) icyclfrc=0 if(icyclfrc.eq.1) then if(ibcx.eq.1) then call updatelr(tmp,np,mp,1,np,mp,1) do j=1,mp relx(np,j)=tmp(np+1,j) enddo endif endif #endif else do j=1,mp do i=1,np relx(i,j)=0. enddo enddo endif compute absorbers at y boundaries if (j3.eq.1) then c --- special explicit polar damping tolip=1./towyp do k=1,l dyagm = dyabp*gmm(1,1,k) do j=1,mp do i=1,np c yab1=yr1(i)+dyabp !VEC yab1=ycr(i,1 )+dyabp c yab2=yr2(i)-dyabp !VEC yab2=ycr(i,mp)-dyabp yab1=yr1(i)+dyagm !VEC yab1=ycr(i,1 )+dyabp yab2=yr2(i)-dyagm !VEC yab2=ycr(i,mp)-dyabp r0=ycr(i,j) c r1=amax1(0.,-r0+yab1)/dyabp c r2=amax1(0., r0-yab2)/dyabp r1=amax1(0.,-r0+yab1)/dyagm r2=amax1(0., r0-yab2)/dyagm relb=r1+r2-r1*r2 ! linear absorber c --- increases more rapidly as pole is approached c relb=(r1+r2-r1*r2)**2 ! inverse quadratic c relb=(r1+r2-r1*r2)**3 ! inverse cubic c relb=(r1+r2-r1*r2)**4 ! inverse quartic c --- levels off as pole is approached c relb=r1*(2.-r1)+r2*(2.-r2)-(r1*r2)**2-2.*r1*r2 ! quadratic c tmp(i,j)=isphere*relb*tolip c relpol(i,j)=tmp(i,j) relpol(i,j,k)=isphere*relb*tolip enddo enddo enddo if (irly.eq.1) then toli=1./towy do j=1,mp do i=1,np yab1=yr1(i)+dyab !VEC yab1=ycr(i,1 )+dyab yab2=yr2(i)-dyab !VEC yab2=ycr(i,mp)-dyab r0=ycr(i,j) r1=amax1(0.,-r0+yab1)/dyab r2=amax1(0., r0-yab2)/dyab relb=toli*(r1+r2-r1*r2) tmp(i,j)=irly*relb rely(i,j)=tmp(i,j) enddo enddo #if (POLES == 0) icyclfrc=0 if(icyclfrc.eq.1) then if(ibcy.eq.1) then call updatebt(tmp,np,mp,1,np,mp,1) do i=1,np rely(i,mp)=tmp(i,mp+1) enddo endif endif #endif else do j=1,mp do i=1,np rely(i,j)=0. enddo enddo endif endif c --- compute absorbers at upper boundary towi=1./towz select case(l) case(24) abscl=7.*dz/7. ! for negative zab !modif for different l case(47) abscl=14.*dz/7. ! for negative zab c abscl=dz case(93) abscl=28.*dz/7. ! for negative zab case(185) abscl=56.*dz/7. ! for negative zab endselect c abscl=14.*dz/3. ! for negative zab cc abscl=5.7e3 ! for negative zab do k=1,l zstr=fsi(z(k)) do j=1,mp do i=1,np zl=zstr/gi(i,j)+zs(i,j) if(zab.ge.0.) then c t1=iab*amax1(0.,zl-zab) c tau(k,i,j,1)=towi*t1/(zb-zab) c add absorber for stable layer under the SCZ c t11=iab*0.5*(tanh((k-20.)/6.)-1.) !l=185 c t11=iab*0.5*(tanh((k-10.)/3.)-1.) !l=93 t11=iab*0.5*(tanh((k-5.)/1.5)-1.) !l=47 tau(k,i,j,1)=-towi*t11 t2=iabth*amax1(0.,zl-zab) c data zab ,towz /-2.4053125e8,0.2592E+06/ !zab=(l-6)*dz00 c tau(k,i,j,2)=towi*t2/(zb-zab) tau(k,i,j,2)=tau(k,i,j,1) else c tau(k,i,j,1)=iab*towi*exp((zl-zb)/abscl) c tau(k,i,j,2)=iabth*towi*exp((zl-zb)/abscl) tau(k,i,j,2)=iabb*towi*exp((zl-zb)/abscl) tau(k,i,j,1)= iab*towi*exp(-zl/abscl) c tau(k,i,j,2)=iabth*towi*exp(-zl/abscl) endif end do end do end do return end subroutine galin(a,del) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) #if (TIMEPLT == 1) call ttbeg(51) #endif do k=1,l do j=1,mp do i=1,np a(i,j,k)=a(i,j,k)+del end do end do end do call update(a,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(51) #endif return end subroutine thprof(th0,z,l,lipps) c --- anelastic potential temperature profile dimension th0(l),z(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 if(lipps.eq.0) then ! Boussinesq profile do k=1,l c th0(k)=th00-g*z(k)/rg ! CAUTION: max. alt. exists th0(k)=th00 end do endif if(lipps.eq.1) then ! Ogura-Phillips profile do k=1,l th0(k)=th00 end do endif if(lipps.eq.2) then ! Clark-Farley profile do k=1,l th0(k)=th00*exp(st*z(k)) end do endif if(lipps.eq.3) then ! Bacmeister-Schoeberl profile do k=1,l th0(k)=th00*exp(st*z(k)) end do endif return end subroutine tprof(t0,z,l,lipps) c --- anelastic temperature profile dimension rh0(l),t0(l),z(l),rad(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/sphere/ rds, rdsi real u0(2),u1(2) real temp0,rho0,dz integer l1 external star_isen if(lipps.eq.0) then ! Boussinesq profile do k=1,l rh0(k)=rh00 end do endif if(lipps.eq.1) then ! Ogura-Phillips profile do k=1,l rad(k)=rds+z(k) end do ! CAUTION: max. alt. exists temp0 = 2.3222e6 rho0 = 207.918 l1 = 19 u0(1) = temp0 u0(2) = rho0 t0(l1) = u0(1) rh0(l1) = u0(2) DO k = l1 - 1, 1, -1 dz = rad(k+1) - rad(k) CALL rk5vec(rad(k+1), 2, u0, -dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) END DO u0(1) = temp0 u0(2) = rho0 DO k = l1 + 1, l dz = rad(k) - rad(k-1) CALL rk5vec(rad(k-1), 2, u0, dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) END DO endif return end subroutine pprof(p0,z,l,lipps) c --- anelastic reference pressure profile dimension rh0(l),t0(l),p0(l),z(l),rad(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/sphere/ rds, rdsi real u0(2),u1(2) real temp0,rho0,dz integer l1 external star_isen if(lipps.eq.0) then ! Boussinesq profile do k=1,l rh0(k)=rh00 end do endif if(lipps.eq.1) then ! Ogura-Phillips profile do k=1,l rad(k)=rds+z(k) end do ! CAUTION: max. alt. exists temp0 = 2.3222e6 rho0 = 207.918 l1 = 19 u0(1) = temp0 u0(2) = rho0 t0(l1) = u0(1) rh0(l1) = u0(2) p0(l1) = rg*t0(l1)*rh0(l1) DO k = l1 - 1, 1, -1 dz = rad(k+1) - rad(k) CALL rk5vec(rad(k+1), 2, u0, -dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) p0(k) = rg*t0(k)*rh0(k) END DO u0(1) = temp0 u0(2) = rho0 DO k = l1 + 1, l dz = rad(k) - rad(k-1) CALL rk5vec(rad(k-1), 2, u0, dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) p0(k) = rg*t0(k)*rh0(k) END DO endif return end subroutine rhprof(rh0,z,l,lipps) c --- anelastic density profile dimension rh0(l),t0(l),z(l),rad(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/sphere/ rds, rdsi real u0(2),u1(2) real temp0,rho0,dz integer l1 external star_isen if(lipps.eq.0) then ! Boussinesq profile do k=1,l rh0(k)=rh00 end do endif if(lipps.eq.1) then ! Ogura-Phillips profile do k=1,l rad(k)=rds+z(k) end do ! CAUTION: max. alt. exists temp0 = 2.3222e6 rho0 = 207.918 l1 = 19 u0(1) = temp0 u0(2) = rho0 t0(l1) = u0(1) rh0(l1) = u0(2) DO k = l1 - 1, 1, -1 dz = rad(k+1) - rad(k) CALL rk5vec(rad(k+1), 2, u0, -dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) END DO u0(1) = temp0 u0(2) = rho0 DO k = l1 + 1, l dz = rad(k) - rad(k-1) CALL rk5vec(rad(k-1), 2, u0, dz, star_isen, u1) u0(1) = u1(1) u0(2) = u1(2) t0(k) = u1(1) rh0(k) = u1(2) END DO endif if(lipps.eq.2) then ! Clark-Farley profile capi=1./cap cs=g/(cp*tt00*st) do k=1,l exs=exp(-st*z(k)) ! CAUTION: max. alt. exists rh0(k)=rh00*exs*(1.-cs*(1.-exs))**(capi-1.) end do endif if(lipps.eq.3) then ! Bacmeister-Schoeberl profile sdi=1./6622.51 ! density scale height (m^-1) do k=1,l rh0(k)=rh00*exp(-sdi*z(k)) end do endif return end subroutine lstsq(th,z,nz,a,b) include 'param.nml' include 'msg.inc' dimension th(nz),z(nz) common/lsty/ y(l) sy=0 sz=0 syz=0 szz=0 do k=1,nz y(k)=alog(th(k)) end do do k=1,nz sz = sz + z(k) szz = szz + z(k)*z(k) syz = syz + y(k)*z(k) sy = sy + y(k) end do a=(sy*szz-sz*syz)/(float(nz)*szz-sz*sz) b=(float(nz)*syz-sy*sz)/(float(nz)*szz-sz*sz) a=exp(a) return end subroutine rhngck(rho) include 'param.nml' include 'msg.inc' dimension rho(1-ih:np+ih, 1-ih:mp+ih, l) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) real globmax,globmin #if (TIMEPLT == 1) call ttbeg(22) #endif checks for negative density in the profile rhmn= 1.e15 rhmx=-1.e15 rhsmn= 1.e15 rhsmx=-1.e15 do 26 k=1,l do 26 j=1,mp do 26 i=1,np dnm=stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j) rhophy=rho(i,j,k)*(gi(i,j)*gmus(k)) + /((1-icylind)*gmm(i,j,k)**2*cosa(i,j) + +icylind*gmm(i,j,k))*dnm rhmx=amax1(rhmx,rhophy) rhmn=amin1(rhmn,rhophy) rhsmx=amax1(rhsmx,rho(i,j,k)) rhsmn=amin1(rhsmn,rho(i,j,k)) if(rho(i,j,k).lt.0.) print *,'rho<0',mype,i,j,k,rho(i,j,k), . stryy(i,j),strxx(i,j),stryx(i,j),strxy(i,j),rho(i,j,k),gi(i,j), . gmm(i,j,k),cosa(i,j) 26 continue rhmx=globmax(rhmx,1,1,1,1,1,1,1,1,1,1,1,1) rhmn=globmin(rhmn,1,1,1,1,1,1,1,1,1,1,1,1) rhsmx=globmax(rhsmx,1,1,1,1,1,1,1,1,1,1,1,1) rhsmn=globmin(rhsmn,1,1,1,1,1,1,1,1,1,1,1,1) if (mype.eq.0) then print 266, rhmn,rhmx ! physical density extrema print 267, rhsmn,rhsmx ! density*Jacobian extrema if(rhmn.le.0.) stop 'rho(z).le.0, consider exp. density profile' end if 266 format(2x,' rhmin, rhmx:',2e11.4) 267 format(2x,'rhsmin, rhsmx:',2e11.4) #if (TIMEPLT == 1) call ttend(22) #endif return end subroutine teprof(pm0,tm0,z,l,lipps) c --- anelastic pressure and temperature profiles c (only called if MOISTMOD > 0) dimension pm0(l),tm0(l),z(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z if(lipps.eq.0) then ! Boussinesq profile do k=1,l pm0(k)=pr00-rh00*g*z(k) ! CAUTION: max. alt. exists tm0(k)=tt00-g*z(k)/rg ! CAUTION: max. alt. exists end do end if if(lipps.eq.1) then ! Ogura-Phillips profile capi=1./cap sdi=1./7000. ! density scale height (m^-1) do k=1,l pm0(k)=pr00*(1.-cap*z(k)*sdi)**capi ! CAUTION: max. alt. exists tm0(k)=tt00*(1.-cap*z(k)*sdi) ! CAUTION: max. alt. exists end do end if if(lipps.eq.2) then ! Clark-Farley profile capi=1./cap cs=g/(cp*tt00*st) do k=1,l exs=exp(-st*z(k)) pm0(k)=pr00*(1.-cs*(1.-exs))**capi ! CAUTION: max. alt. exists tm0(k)=tt00/exs*(1.-cs*(1.-exs)) ! CAUTION: max. alt. exists end do end if if(lipps.eq.3) then ! Bacmeister-Schoeberl profile sdi=1./7000. ! density scale height (m^-1) do k=1,l pm0(k)=pr00*exp(-sdi*z(k)) tm0(k)=pr00/(rg*rh00) end do end if return end subroutine rhotad(f,d,iflg) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . d(1-ih:np+ih, 1-ih:mp+ih, l) #if (TIMEPLT == 1) call ttbeg(23) #endif if(iflg.eq.1) then do k=1,l do j=1,mp do i=1,np f(i,j,k)=f(i,j,k)*d(i,j,k) enddo enddo enddo endif if(iflg.eq.-1) then do k=1,l do j=1,mp do i=1,np f(i,j,k)=f(i,j,k)/d(i,j,k) enddo enddo enddo endif #if (TIMEPLT == 1) call ttend(23) #endif return end #if (ANALIZE == 0) subroutine bbc include 'param.nml' include 'msg.inc' common/rigidB/ bbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,2), . bbx(1-ih:mmhdp+ih, lmhd , 2), . bby(1-ih:nmhdp+ih, lmhd , 2) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) C---------------------------------------------------------------------------- C This routine sets the boundary conditions for normal induction B C at the model boundaries (cf. routine velbc for velocities) C There is no universal way to do this. Consider that C B_solenoidal= [Metric-Coefficient Matrix]*B_physical. C In the code below vertical-boundary solenoidal velocity is set assuming C that at the curvilinear boundary B_physical = B_environment, C but anything desired can be passed by the subroutine call. C---------------------------------------------------------------------------- do 3200 k=1,l,l-1 kk=1+k/l do 320 j=1,mp do 320 i=1,np g33=gi(i,j)*gmus(k) g110=1./(gmm(i,j,k)*cosa(i,j)) g220=1./gmm(i,j,k) g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 bbz(i,j,kk)=g13*bxe(i,j,k)+g23*bye(i,j,k)+g33*bze(i,j,k) 320 continue 3200 continue do k=1,l do j=1,mp bbx(j,k,1)=0. bbx(j,k,2)=0. enddo do i=1,np bby(i,k,1)=0. bby(i,k,2)=0. enddo enddo if (leftedge.eq.1) then do 321 k=1,l do 321 j=1,mp ja=(mpos-1)*mp + j g110w=1./(gmm(1,j,k)*cosa(1,j)) g220w=1./gmm(1,j,k) g11w=strxx(1,j)*g110w g21w=strxy(1,j)*g220w bbx(j,k,1)=g11w*bxe(1,j,k)+g21w*bye(1,j,k) #if (PARALLEL > 0) g110w=1./(gmm(0,j,k)*cosa(0,j)) g220w=1./gmm(0,j,k) g11w=strxx(0,j)*g110w g21w=strxy(0,j)*g220w bbx(j,k,2)=g11w*bxe(0,j,k)+g21w*bye(0,j,k) #endif 321 continue end if if (rightedge.eq.1) then do 322 k=1,l do 322 j=1,mp ja=(mpos-1)*mp + j #if (PARALLEL > 0) g110e=1./(gmm(np+1,j,k)*cosa(np+1,j)) g220e=1./gmm(np+1,j,k) g11e=strxx(np+1,j)*g110e g21e=strxy(np+1,j)*g220e bbx(j,k,1)=g11e*bxe(np+1,j,k)+g21e*bye(np+1,j,k) #endif g110e=1./(gmm(np,j,k)*cosa(np,j)) g220e=1./gmm(np,j,k) g11e=strxx(np,j)*g110e g21e=strxy(np,j)*g220e bbx(j,k,2)=g11e*bxe(np,j,k)+g21e*bye(np,j,k) 322 continue end if if (botedge.eq.1) then do 323 k=1,l do 323 i=1,np g110s=1./(gmm(i,1,k)*cosa(i,1)) g220s=1./gmm(i,1,k) g12s=stryx(i,1)*g110s g22s=stryy(i,1)*g220s bby(i,k,1)=g12s*bxe(i,1,k)+g22s*bye(i,1,k) #if (PARALLEL > 0) g110s=1./(gmm(i,0,k)*cosa(i,0)) g220s=1./gmm(i,0,k) g12s=stryx(i,0)*g110s g22s=stryy(i,0)*g220s bby(i,k,2)=g12s*bxe(i,0,k)+g22s*bye(i,0,k) #endif 323 continue end if if (topedge.eq.1) then do 324 k=1,l do 324 i=1,np #if (PARALLEL > 0) g110n=1./(gmm(i,mp+1,k)*cosa(i,mp+1)) g220n=1./gmm(i,mp+1,k) g12n=stryx(i,mp+1)*g110n g22n=stryy(i,mp+1)*g220n bby(i,k,1)=g12n*bxe(i,mp+1,k)+g22n*bye(i,mp+1,k) #endif g110n=1./(gmm(i,mp,k)*cosa(i,mp)) g220n=1./gmm(i,mp,k) g12n=stryx(i,mp)*g110n g22n=stryy(i,mp)*g220n bby(i,k,2)=g12n*bxe(i,mp,k)+g22n*bye(i,mp,k) 324 continue end if call bbcad(bbx,bby,bbz,rh0) return end subroutine bbcad(bbx,bby,bbz,d) include 'param.nml' include 'msg.inc' dimension wgx(np),wgy(mp),wgz(l) dimension d(1-ih:np+ih, 1-ih:mp+ih, l) dimension bbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,2), . bbx(1-ih:mmhdp+ih, lmhd , 2), . bby(1-ih:nmhdp+ih, lmhd , 2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/vbcdg/ uinf,vinf,oinf,uout,vout,oout,tflx,epsim,epsia common/blank/ scr13(1-ih:np+ih, 1-ih:mp+ih, l, 13), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l) real globsum c#if (POLES == 0) pp(xx)=amax1(xx,0.) pn(xx)=amin1(xx,0.) c#endif c if((ibcx.eq.1).and.(ibcy.eq.1.or.j3.eq.0)) return #if (TIMEPLT == 1) call ttbeg(25) #endif c#if (POLES == 0) call update(d,np,mp,l,np,mp,1) character of the adjustement of velocities at the boundaries: c iflg=0 multiplicative adjustment of outflow velocities only; c iflg.ne.0 additive adjustement of both inflow and outflow velocities c z boundary has been coded in for special purpose exepriments but commented out as omega=0 is required at z=0 and h iflg=0 customarily there are no fluxes through z boundaries (except for that caused by time dependend orography); typically there is no need for a code computing adjustemnt at z boundaries; however, in special cases such code may be helpful. izflg=0 baypasses the special code, izlg=1 activates it. izflg=1 compute weights for integrals do i=1,np wgx(i)=1. enddo if( leftedge.eq.1) wgx(1)=0.5 if(rightedge.eq.1) wgx(np)=0.5 do j=1,mp wgy(j)=1. enddo if(botedge.eq.1) wgy(1)=0.5 if(topedge.eq.1) wgy(mp)=0.5 do k=1,l wgz(k)=1. enddo wgz(1)=0.5 wgz(l)=0.5 compute adjustement of outflow velocities at the boundaries: cofluxes through x boundaries uout=0. uinf=0. udb=0. if(ibcx.eq.1) goto 10 do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp tmp1(1,j,k)=wgz(k)*wgy(j)* . (d(np,j,k)*pp(bbx(j,k,2))-d(np+1,j,k)*pn(bbx(j,k,1))) tmp2(2,j,k)=wgz(k)*wgy(j)* . (d(np,j,k)*pn(bbx(j,k,2))-d(np+1,j,k)*pp(bbx(j,k,1))) tmp3(3,j,k)=wgz(k)*wgy(j)*(d(np,j,k)+d(np+1,j,k)) end do end do end if uout=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) uinf=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) udb=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) udb = udb*dy*dz uout=uout*dy*dz uinf=uinf*dy*dz 10 continue cofluxes through y boundaries vout=0. vinf=0. vdb=0. if(ibcy.eq.1) goto 20 do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np tmp1(i,1,k)=wgz(k)*wgx(i)* . (d(i,mp,k)*pp(bby(i,k,2))-d(i,mp+1,k)*pn(bby(i,k,1))) tmp2(i,2,k)=wgz(k)*wgx(i)* . (d(i,mp,k)*pn(bby(i,k,2))-d(i,mp+1,k)*pp(bby(i,k,1))) tmp3(i,3,k)=wgz(k)*wgx(i)*(d(i,mp,k) + d(i,mp+1,k)) end do end do end if vout=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vinf=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vdb=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vdb = vdb*dx*dz vout=vout*dx*dz vinf=vinf*dx*dz 20 continue cofluxes through z boundaries oout=0. oinf=0. tflx=0. odb=0. if(izflg.eq.1) then do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do do j=1,mp do i=1,np if ((ibbl .eq. 1) .and. (ibbu .eq. 1)) then tmp1(i,j,1)=wgx(i)*wgy(j)* c . d(i,j,l)*pp(bbz(i,j,2)) . (d(i,j,l)*pp(bbz(i,j,2))-d(i,j,1)*pn(bbz(i,j,1))) tmp2(i,j,2)=wgx(i)*wgy(j)* c . d(i,j,l)*pn(bbz(i,j,2)) . (d(i,j,l)*pn(bbz(i,j,2))-d(i,j,1)*pp(bbz(i,j,1))) c tmp3(i,j,3) = wgx(i)*wgy(j)*d(i,j,l) tmp3(i,j,3) = wgx(i)*wgy(j)*(d(i,j,l)+d(i,j,1)) elseif (ibbl .eq. 1) then tmp1(i,j,1)=wgx(i)*wgy(j)* c . d(i,j,l)*pp(bbz(i,j,2)) . (-d(i,j,1)*pn(bbz(i,j,1))) tmp2(i,j,2)=wgx(i)*wgy(j)* c . d(i,j,l)*pn(bbz(i,j,2)) . (-d(i,j,1)*pp(bbz(i,j,1))) c tmp3(i,j,3) = wgx(i)*wgy(j)*d(i,j,l) tmp3(i,j,3) = wgx(i)*wgy(j)*(d(i,j,1)) else tmp1(i,j,1)=wgx(i)*wgy(j)* c . d(i,j,l)*pp(bbz(i,j,2)) . (d(i,j,l)*pp(bbz(i,j,2))) tmp2(i,j,2)=wgx(i)*wgy(j)* c . d(i,j,l)*pn(bbz(i,j,2)) . (d(i,j,l)*pn(bbz(i,j,2))) c tmp3(i,j,3) = wgx(i)*wgy(j)*d(i,j,l) tmp3(i,j,3) = wgx(i)*wgy(j)*(d(i,j,l)) endif end do end do oout = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) oinf = globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) odb = globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) else ! Bench do k=1,l do j=1,mp do i=1,np tmp3(i,j,k)=0. end do end do end do do j=1,mp do i=1,np tmp3(i,j,3) = wgx(i)*wgy(j)*(d(i,j,l)+d(i,j,1)) end do end do odb = globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) endif do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. end do end do end do do j=1,mp do i=1,np zbrdt= gmul(1)/zb*gi(i,j)*gmus(1)*zsd(i,j) . -(gmul(1)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(1) zhrdt=-(gmul(l)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(l) . +gmul(l)/zb*gi(i,j)*gmus(l)*zsd(i,j) tmp1(i,j,1) = wgx(i)*wgy(j)*(d(i,j,l)*zhrdt-d(i,j,1)*zbrdt) end do end do tflx=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) odb = odb*dx*dy oout=oout*dx*dy oinf=oinf*dx*dy tflx=tflx*dx*dy constant of mass adjustement c if(uout+vout+oout.eq.0.) iflg=1 c epsia=0. c if(iflg.eq.0) then c epsim=-(uinf+vinf+oinf+tflx)/(uout+vout+oout) c else epsim=1. epsiat=-(uinf+vinf+oinf+tflx+uout+vout+oout)/(udb+vdb+odb) epsiab=-epsiat if (ibbl .eq. 0.) then epsiab = 0. endif if (ibbu .eq. 0.) then epsiat = 0. endif c endif corrected outflow velocities if(ibcx.eq.1) goto 111 if (leftedge.eq.1) then do 11 k=1,l do 11 j=1,mp 11 bbx(j,k,1)=pp(bbx(j,k,1))+epsim*pn(bbx(j,k,1))+epsiab endif if(rightedge.eq.1) then do 12 k=1,l do 12 j=1,mp 12 bbx(j,k,2)=pn(bbx(j,k,2))+epsim*pp(bbx(j,k,2))+epsiat endif 111 continue if(ibcy.eq.1) goto 222 if (botedge.eq.1) then do 22 k=1,l do 22 i=1,np 22 bby(i,k,1)=pp(bby(i,k,1))+epsim*pn(bby(i,k,1))+epsiab endif if (topedge.eq.1) then do 23 k=1,l do 23 i=1,np 23 bby(i,k,2)=pn(bby(i,k,2))+epsim*pp(bby(i,k,2))+epsiat endif 222 continue do j=1,mp do i=1,np bbz(i,j,2)=pn(bbz(i,j,2))+epsim*pp(bbz(i,j,2))+epsiat bbz(i,j,1)=pp(bbz(i,j,1))+epsim*pn(bbz(i,j,1))+epsiab enddo enddo c#endif ! Check it out oout=0. oinf=0. if(izflg.eq.1) then do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. end do end do end do do j=1,mp do i=1,np tmp1(i,j,1)=wgx(i)*wgy(j)* . (d(i,j,l)*pp(bbz(i,j,2))-d(i,j,1)*pn(bbz(i,j,1))) tmp2(i,j,2)=wgx(i)*wgy(j)* . (d(i,j,l)*pn(bbz(i,j,2))-d(i,j,1)*pp(bbz(i,j,1))) end do end do oout = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) oinf = globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) endif #if (TIMEPLT == 1) call ttend(25) #endif return end subroutine velbc(ue,ve,rho) cc transform physical velocity bc (here ue,ve) to solenoidal velocities include 'param.nml' include 'msg.inc' dimension ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/rigid/ ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (TIMEPLT == 1) call ttbeg(24) #endif C---------------------------------------------------------------------------- C This routine sets the boundary conditions for normal solenoidal C velocities at the model boundaries. There is no universal way to C do this. There are two important formulae to consider: C a) V_solenoidal=V_contravariant- partial X_bar/partial t C b) V_solenoidal= [Metric-Coefficient Matrix]*V_physical. C Both are equivalent but their relative utility depends on the C problem at hand. C C In the code below vertical-boundary solenoidal velocity is set assuming C that the curvilinear boundary is impermeable, whereupon contravariant C velocity vanishes there (fluid adheres to the boundary), so relation (a) C is employed. Horizontal components exploit (b) formulae while assuming C known physical velocities at the boundary (here profiles ue and ve, C but anything desired can be passed by the subroutine call). Alternate C formulations are included (but commented out) for the use with special C applications (e.g., flow past chanels with vibrating lateral walls) C---------------------------------------------------------------------------- we =0. do 3200 k=1,l,l-1 kk=1+k/l do 320 j=1,mp do 320 i=1,np g33=gi(i,j)*gmus(k) ob(i,j,kk)=gmul(k)*zsd(i,j)/zb*g33-(gmul(k)/zb-1.)*zhd(i,j)*g33 !(a) C g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) C g220=1./gmm(i,j,k) C g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 C g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 C ob(i,j,kk)=g13*ue(i,j,k)+g23*ve(i,j,k)+g33*we !alternative (b) 320 continue 3200 continue do k=1,l do j=1,mp ub(j,k,1)=0. ub(j,k,2)=0. enddo do i=1,np vb(i,k,1)=0. vb(i,k,2)=0. enddo enddo if (leftedge.eq.1) then do 321 k=1,l do 321 j=1,mp ja=(mpos-1)*mp + j g110w=1./((1-icylind)*gmm(1,j,k)*cosa(1,j)+icylind*1.) g220w=1./gmm(1,j,k) g11w=strxx(1,j)*g110w g21w=strxy(1,j)*g220w ub(j,k,1)=g11w*ue(1,j,k)+g21w*ve(1,j,k) C ub(j,k,1)=-strxd(1,j) !alternative (a) #if (PARALLEL > 0) g110w=1./((1-icylind)*gmm(0,j,k)*cosa(0,j)+icylind*1.) g220w=1./gmm(0,j,k) g11w=strxx(0,j)*g110w g21w=strxy(0,j)*g220w ub(j,k,2)=g11w*ue(0,j,k)+g21w*ve(0,j,k) C ub(j,k,2)=-strxd(0,j) !alternative (a) #endif 321 continue end if if (rightedge.eq.1) then do 322 k=1,l do 322 j=1,mp ja=(mpos-1)*mp + j #if (PARALLEL > 0) g110e=1./((1-icylind)*gmm(np+1,j,k)*cosa(np+1,j) . +icylind*1.) g220e=1./gmm(np+1,j,k) g11e=strxx(np+1,j)*g110e g21e=strxy(np+1,j)*g220e ub(j,k,1)=g11e*ue(np+1,j,k)+g21e*ve(np+1,j,k) C ub(j,k,1)=-strxd(np+1,j) !alternative (a) #endif g110e=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g220e=1./gmm(np,j,k) g11e=strxx(np,j)*g110e g21e=strxy(np,j)*g220e ub(j,k,2)=g11e*ue(np,j,k)+g21e*ve(np,j,k) C ub(j,k,2)=-strxd(np,j) !alternative (a) 322 continue end if if (botedge.eq.1) then do 323 k=1,l do 323 i=1,np g110s=1./((1-icylind)*gmm(i,1,k)*cosa(i,1)+icylind*1.) g220s=1./gmm(i,1,k) g12s=stryx(i,1)*g110s g22s=stryy(i,1)*g220s vb(i,k,1)=g12s*ue(i,1,k)+g22s*ve(i,1,k) C vb(i,k,1)=-stryd(i,1) !alternative (a) #if (PARALLEL > 0) g110s=1./((1-icylind)*gmm(i,0,k)*cosa(i,0)+icylind*1.) g220s=1./gmm(i,0,k) g12s=stryx(i,0)*g110s g22s=stryy(i,0)*g220s vb(i,k,2)=g12s*ue(i,0,k)+g22s*ve(i,0,k) C vb(i,k,2)=-stryd(i,0) !alternative (a) #endif 323 continue end if if (topedge.eq.1) then do 324 k=1,l do 324 i=1,np #if (PARALLEL > 0) g110n=1./((1-icylind)*gmm(i,mp+1,k)*cosa(i,mp+1)+icylind*1.) g220n=1./gmm(i,mp+1,k) g12n=stryx(i,mp+1)*g110n g22n=stryy(i,mp+1)*g220n vb(i,k,1)=g12n*ue(i,mp+1,k)+g22n*ve(i,mp+1,k) C vb(i,k,1)=-stryd(i,mp+1) !alternative (a) #endif g110n=1./((1-icylind)*gmm(i,mp,k)*cosa(i,mp)+icylind*1.) g220n=1./gmm(i,mp,k) g12n=stryx(i,mp)*g110n g22n=stryy(i,mp)*g220n vb(i,k,2)=g12n*ue(i,mp,k)+g22n*ve(i,mp,k) C vb(i,k,2)=-stryd(i,mp) !alternative (a) 324 continue end if #if (TIMEPLT == 1) call ttend(24) #endif call vbcad(rho) return end subroutine vbcad(d) include 'param.nml' include 'msg.inc' dimension wgx(np),wgy(mp),wgz(l) dimension d(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/rigid/ ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) common/vbcdg/ uinf,vinf,oinf,uout,vout,oout,tflx,epsim,epsia common/blank/ scr13(1-ih:np+ih, 1-ih:mp+ih, l, 13), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l) real globsum #if (POLES == 0) pp(xx)=amax1(xx,0.) pn(xx)=amin1(xx,0.) #endif if((ibcx.eq.1).and.(ibcy.eq.1.or.j3.eq.0)) return #if (TIMEPLT == 1) call ttbeg(25) #endif #if (POLES == 0) call update(d,np,mp,l,np,mp,1) character of the adjustement of velocities at the boundaries: c iflg=0 multiplicative adjustment of outflow velocities only; c iflg.ne.0 additive adjustement of both inflow and outflow velocities c z boundary has been coded in for special purpose exepriments but commented out as omega=0 is required at z=0 and h iflg=0 customarily there are no fluxes through z boundaries (except for that caused by time dependend orography); typically there is no need for a code computing adjustemnt at z boundaries; however, in special cases such code may be helpful. izflg=0 baypasses the special code, izlg=1 activates it. izflg=0 compute weights for integrals do i=1,np wgx(i)=1. enddo if( leftedge.eq.1) wgx(1)=0.5 if(rightedge.eq.1) wgx(np)=0.5 do j=1,mp wgy(j)=1. enddo if(botedge.eq.1) wgy(1)=0.5 if(topedge.eq.1) wgy(mp)=0.5 do k=1,l wgz(k)=1. enddo wgz(1)=0.5 wgz(l)=0.5 compute adjustement of outflow velocities at the boundaries: cofluxes through x boundaries uout=0. uinf=0. udb=0. if(ibcx.eq.1) goto 10 do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp tmp1(1,j,k)=wgz(k)*wgy(j)* . (d(np,j,k)*pp(ub(j,k,2))-d(np+1,j,k)*pn(ub(j,k,1))) tmp2(2,j,k)=wgz(k)*wgy(j)* . (d(np,j,k)*pn(ub(j,k,2))-d(np+1,j,k)*pp(ub(j,k,1))) tmp3(3,j,k)=wgz(k)*wgy(j)*(d(np,j,k)+d(np+1,j,k)) end do end do end if uout=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) uinf=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) udb=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) udb = udb*dy*dz uout=uout*dy*dz uinf=uinf*dy*dz 10 continue cofluxes through y boundaries vout=0. vinf=0. vdb=0. if(ibcy.eq.1) goto 20 do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np tmp1(i,1,k)=wgz(k)*wgx(i)* . (d(i,mp,k)*pp(vb(i,k,2))-d(i,mp+1,k)*pn(vb(i,k,1))) tmp2(i,2,k)=wgz(k)*wgx(i)* . (d(i,mp,k)*pn(vb(i,k,2))-d(i,mp+1,k)*pp(vb(i,k,1))) tmp3(i,3,k)=wgz(k)*wgx(i)*(d(i,mp,k) + d(i,mp+1,k)) end do end do end if vout=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vinf=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vdb=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vdb = vdb*dx*dz vout=vout*dx*dz vinf=vinf*dx*dz 20 continue cofluxes through z boundaries oout=0. oinf=0. tflx=0. odb=0. if(izflg.eq.1) then do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. tmp2(i,j,k)=0. tmp3(i,j,k)=0. end do end do end do do j=1,mp do i=1,np tmp1(i,j,1)=wgx(i)*wgy(j)* . (d(i,j,l)*pp(ob(i,j,2))-d(i,j,1)*pn(ob(i,j,1))) tmp2(i,j,2)=wgx(i)*wgy(j)* . (d(i,j,l)*pn(ob(i,j,2))-d(i,j,1)*pp(ob(i,j,1))) tmp3(i,j,3) = wgx(i)*wgy(j)*(d(i,j,l)+d(i,j,1)) end do end do oout = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) oinf = globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) odb = globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) endif do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=0. end do end do end do do j=1,mp do i=1,np zbrdt= gmul(1)/zb*gi(i,j)*gmus(1)*zsd(i,j) . -(gmul(1)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(1) zhrdt=-(gmul(l)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(l) . +gmul(l)/zb*gi(i,j)*gmus(l)*zsd(i,j) tmp1(i,j,1) = wgx(i)*wgy(j)*(d(i,j,l)*zhrdt-d(i,j,1)*zbrdt) end do end do tflx=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) odb = odb*dx*dy oout=oout*dx*dy oinf=oinf*dx*dy tflx=tflx*dx*dy constant of mass adjustement if(uout+vout+oout.eq.0.) iflg=1 epsia=0. if(iflg.eq.0) then epsim=-(uinf+vinf+oinf+tflx)/(uout+vout+oout) else epsim=1. epsia=-(uinf+vinf+oinf+tflx+uout+vout+oout)/(udb+vdb+odb) endif corrected outflow velocities if(ibcx.eq.1) goto 111 if (leftedge.eq.1) then do 11 k=1,l do 11 j=1,mp 11 ub(j,k,1)=pp(ub(j,k,1))+epsim*pn(ub(j,k,1))-epsia endif if(rightedge.eq.1) then do 12 k=1,l do 12 j=1,mp 12 ub(j,k,2)=pn(ub(j,k,2))+epsim*pp(ub(j,k,2))+epsia endif 111 continue if(ibcy.eq.1) goto 222 if (botedge.eq.1) then do 22 k=1,l do 22 i=1,np 22 vb(i,k,1)=pp(vb(i,k,1))+epsim*pn(vb(i,k,1))-epsia endif if (topedge.eq.1) then do 23 k=1,l do 23 i=1,np 23 vb(i,k,2)=pn(vb(i,k,2))+epsim*pp(vb(i,k,2))+epsia endif 222 continue c do 33 j=1,mp c do 33 i=1,np c ob(i,j,2)=pn(ob(i,j,2))+epsim*pp(ob(i,j,2))+epsia c 33 ob(i,j,1)=pp(ob(i,j,1))+epsim*pn(ob(i,j,1))-epsia #endif #if (TIMEPLT == 1) call ttend(25) #endif return end subroutine vbcadn(d) c --- computes fluxes through non-periodic boundaries and corrects c --- boundary conditions to maintain global mass balance. include 'param.nml' include 'msg.inc' dimension wgx(np),wgy(mp),wgz(l) dimension d(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/rigid/ ob(1-ih:np+ih,1-ih:mp+ih,2), . ub(1-ih:mp+ih, l , 2), . vb(1-ih:np+ih, l , 2) common/vbcdg/ uinf,vinf,oinf,uout,vout,oout,tflx,epsim,epsia common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . scr16(1-ih:np+ih, 1-ih:mp+ih, l-1), . temp(1-ih:np+ih, 1-ih:mp+ih) real globsum #if (POLES == 0) pp(xx)=amax1(xx,0.) pn(xx)=amin1(xx,0.) #endif if(ibcx.eq.1.and.ibcy.eq.1) return #if (TIMEPLT == 1) call ttbeg(25) #endif #if (POLES == 0) call update(d,np,mp,l,np,mp,1) character of the adjustement of velocities at the boundaries: c iflg=0 multiplicative adjustment of outflow velocities only; c iflg.ne.0 additive adjustement of both inflow and outflow velocities c z boundary has been coded in for special purpose exepriments but commented out as omega=0 is required at z=0 and h iflg=0 customarily there are no fluxes through z boundaries (except for that caused by time dependend orography); typically there is no need for a code computing adjustemnt at z boundaries; however, in special cases such code may be helpful. izflg=0 baypasses the special code, izlg=1 activates it. izflg=0 compute weights for integrals do i=1,np wgx(i)=1. enddo if( leftedge.eq.1) wgx(1)=0.5 if(rightedge.eq.1) wgx(np)=0.5 do j=1,mp wgy(j)=1. enddo if(botedge.eq.1) wgy(1)=0.5 if(topedge.eq.1) wgy(mp)=0.5 do k=1,l wgz(k)=1. enddo wgz(1)=0.5 wgz(l)=0.5 compute adjustement of outflow velocities at the boundaries: cofluxes through x boundaries uout=0. uinf=0. udb=0. if(ibcx.eq.1) goto 10 if (rightedge.eq.1) then do k=1,l do j=1,mp uout=uout+wgz(k)*wgy(j)* . (d(np,j,k)*pp(ub(j,k,2))-d(1,j,k)*pn(ub(j,k,1))) uinf=uinf+wgz(k)*wgy(j)* . (d(np,j,k)*pn(ub(j,k,2))-d(1,j,k)*pp(ub(j,k,1))) udb = udb+wgz(k)*wgy(j)*(d(np,j,k)+d(1,j,k)) end do end do end if #if (PARALLEL > 0) uout=globsum(uout,1,1,1,1,1,1,1,1,1,1,1,1) uinf=globsum(uinf,1,1,1,1,1,1,1,1,1,1,1,1) udb=globsum( udb,1,1,1,1,1,1,1,1,1,1,1,1) #endif udb = udb*dy*dz uout=uout*dy*dz uinf=uinf*dy*dz 10 continue cofluxes through y boundaries vout=0. vinf=0. vdb=0. if(ibcy.eq.1) goto 20 if (topedge.eq.1) then do k=1,l do i=1,np vout=vout+wgz(k)*wgx(i)* . (d(i,mp,k)*pp(vb(i,k,2))-d(i,1,k)*pn(vb(i,k,1))) vinf=vinf+wgz(k)*wgx(i)* . (d(i,mp,k)*pn(vb(i,k,2))-d(i,1,k)*pp(vb(i,k,1))) vdb = vdb+wgz(k)*wgx(i)*(d(i,mp,k)+d(i,1,k)) end do end do end if #if (PARALLEL > 0) vout=globsum(vout,1,1,1,1,1,1,1,1,1,1,1,1) vinf=globsum(vinf,1,1,1,1,1,1,1,1,1,1,1,1) vdb=globsum( vdb,1,1,1,1,1,1,1,1,1,1,1,1) #endif vdb = vdb*dx*dz vout=vout*dx*dz vinf=vinf*dx*dz 20 continue cofluxes through z boundaries oout=0. oinf=0. tflx=0. odb=0. if(izflg.eq.1) then do j=1,mp do i=1,np oout=oout+wgx(i)*wgy(j)* . (d(i,j,l)*pp(ob(i,j,2))-d(i,j,1)*pn(ob(i,j,1))) oinf=oinf+wgx(i)*wgy(j)* . (d(i,j,l)*pn(ob(i,j,2))-d(i,j,1)*pp(ob(i,j,1))) odb = odb+wgx(i)*wgy(j)*(d(i,j,l)+d(i,j,1)) end do end do #if (PARALLEL > 0) oout=globsum(oout,1,1,1,1,1,1,1,1,1,1,1,1) oinf=globsum(oinf,1,1,1,1,1,1,1,1,1,1,1,1) odb=globsum( odb,1,1,1,1,1,1,1,1,1,1,1,1) #endif odb = odb*dx*dy oout=oout*dx*dy oinf=oinf*dx*dy endif do j=1,mp do i=1,np zbrdt= gmul(1)/zb*gi(i,j)*gmus(1)*zsd(i,j) . -(gmul(1)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(1) zhrdt=-(gmul(l)/zb-1.)*zhd(i,j)*gi(i,j)*gmus(l) . +gmul(l)/zb*gi(i,j)*gmus(l)*zsd(i,j) temp(i,j)=wgx(i)*wgy(j)*(d(i,j,l)*zhrdt-d(i,j,1)*zbrdt) end do end do tflx=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1) tflx=tflx*dx*dy constant of mass adjustement if(uout+vout+oout.eq.0.) iflg=1 if(iflg.eq.0) then epsim=-(uinf+vinf+oinf+tflx)/(uout+vout+oout) epsia=0. else epsim=1. epsia=-(uinf+vinf+oinf+tflx+uout+vout+oout)/(udb+vdb+odb) endif corrected outflow velocities if(ibcx.eq.1) goto 111 do 11 k=1,l do 11 j=1,mp ub(j,k,2)=pn(ub(j,k,2))+epsim*pp(ub(j,k,2))+epsia 11 ub(j,k,1)=pp(ub(j,k,1))+epsim*pn(ub(j,k,1))-epsia 111 continue if(ibcy.eq.1) goto 222 do 22 k=1,l do 22 i=1,np vb(i,k,2)=pn(vb(i,k,2))+epsim*pp(vb(i,k,2))+epsia 22 vb(i,k,1)=pp(vb(i,k,1))+epsim*pn(vb(i,k,1))-epsia 222 continue c do 33 j=1,mp c do 33 i=1,np c ob(i,j,2)=pn(ob(i,j,2))+epsim*pp(ob(i,j,2))+epsia c 33 ob(i,j,1)=pp(ob(i,j,1))+epsim*pn(ob(i,j,1))-epsia #endif #if (TIMEPLT == 1) call ttend(25) #endif return end subroutine velprd(u,v,w,ox,oy,oz,fox,foy,foz,p, . gc1,gc2,gc3,itraj1,eppr,itpr) c --- computes extrapolated fields at n+1 c --- computes staggered velocities and fluxes for advective solver include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l, 0:1), . v(1-ih:np+ih, 1-ih:mp+ih, l, 0:1), . w(1-ih:np+ih, 1-ih:mp+ih, l, 0:1), . ox(1-ih:np+ih, 1-ih:mp+ih, l, 0:2), . oy(1-ih:np+ih, 1-ih:mp+ih, l, 0:2), . oz(1-ih:np+ih, 1-ih:mp+ih, l, 0:2), . fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . p(1-ih:np+ih, 1-ih:mp+ih, l) c lc=0 or 1 ---> advecting velocities or velocites +0.5dtF in SL-like manner c io=0 or 1 ---> advecting physical or advective velocities c icont0=0 or 1; 0 shutts off auxiliary pressure solver for itraj=1 parameter(lc=1,io=0,iw=1-io,icont0=1) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/slt/ x0(1-ih:np+ih,1-ih:mp+ih,l), 1 y0(1-ih:np+ih,1-ih:mp+ih,l), 1 z0(1-ih:np+ih,1-ih:mp+ih,l), 1 pfx(1-ih:np+ih,1-ih:mp+ih,l), 1 pfy(1-ih:np+ih,1-ih:mp+ih,l), 1 pfz(1-ih:np+ih,1-ih:mp+ih,l), 1 fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) common/blank/ ux(1-ih:np+ih,1-ih:mp+ih,l), . uy(1-ih:np+ih,1-ih:mp+ih,l), . uz(1-ih:np+ih,1-ih:mp+ih,l), . vx(1-ih:np+ih,1-ih:mp+ih,l), . vy(1-ih:np+ih,1-ih:mp+ih,l), . vz(1-ih:np+ih,1-ih:mp+ih,l), . wx(1-ih:np+ih,1-ih:mp+ih,l), . wy(1-ih:np+ih,1-ih:mp+ih,l), . wz(1-ih:np+ih,1-ih:mp+ih,l), . temp(1-ih:np+ih,1-ih:mp+ih,l, 7) dimension wk0(0-ih:np+ih+1,0-ih:mp+ih+1,0:l+1) ! local array dimension wk1(1-ih:np+ih+1,1-ih:mp+ih+1,1:l+1) ! local array parameter(ialff=0) c return #if (TIMEPLT == 1) call ttbeg(39) #endif IF(ITRAJ1.EQ.0) THEN c --- do linear extrapolation to time level n+1 do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=2.*ox(i,j,k,0)*(lagr+ieul*d(i,j,k))-ox(i,j,k,2) oy(i,j,k,1)=2.*oy(i,j,k,0)*(lagr+ieul*d(i,j,k))-oy(i,j,k,2) oz(i,j,k,1)=2.*oz(i,j,k,0)*(lagr+ieul*d(i,j,k))-oz(i,j,k,2) u(i,j,k,1)=u(i,j,k,0) v(i,j,k,1)=v(i,j,k,0) w(i,j,k,1)=w(i,j,k,0) enddo enddo enddo if(ialff.eq.1) call trnsav(ox(1-ih,1-ih,1,1), * oy(1-ih,1-ih,1,1), * oz(1-ih,1-ih,1,1), * wx,wy,wz,j3,ibcx,ibcy,ibcz) ELSE do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=ox(i,j,k,0)+0.5*dt*(fox(i,j,k)-ox(i,j,k,1)) oy(i,j,k,1)=oy(i,j,k,0)+0.5*dt*(foy(i,j,k)-oy(i,j,k,1)) oz(i,j,k,1)=oz(i,j,k,0)+0.5*dt*(foz(i,j,k)-oz(i,j,k,1)) enddo enddo enddo if(ieul.eq.0) go to 777 do k=1,l do j=1,mp do i=1,np u(i,j,k,1)=u(i,j,k,0)+0.5*dt*(fx(i,j,k)-u(i,j,k,1)) v(i,j,k,1)=v(i,j,k,0)+0.5*dt*(fy(i,j,k)-v(i,j,k,1)) w(i,j,k,1)=w(i,j,k,0)+0.5*dt*(fz(i,j,k)-w(i,j,k,1)) ox(i,j,k,1)=io*ox(i,j,k, 1)+iw*u(i,j,k, 1) oy(i,j,k,1)=io*oy(i,j,k, 1)+iw*v(i,j,k, 1) oz(i,j,k,1)=io*oz(i,j,k, 1)+iw*w(i,j,k, 1) ox(i,j,k,2)=io*ox(i,j,k,lc)+iw*u(i,j,k,lc) oy(i,j,k,2)=io*oy(i,j,k,lc)+iw*v(i,j,k,lc) oz(i,j,k,2)=io*oz(i,j,k,lc)+iw*w(i,j,k,lc) enddo enddo enddo compute velocity derivatives call update2(ox(1-ih,1-ih,1,2),np,mp,l,np,mp,iup) call update2(oy(1-ih,1-ih,1,2),np,mp,l,np,mp,iup) call update2(oz(1-ih,1-ih,1,2),np,mp,l,np,mp,iup) #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge #else illim = 1 iulim = np #endif do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim cp=.5*gc1*amax1(0.,ox(i,j,k,0)) cn=.5*gc1*amin1(0.,ox(i,j,k,0)) ux(i,j,k)= cp*(ox( i ,j,k,2)-ox(i-1,j,k,2)) . +cn*(ox(i+1,j,k,2)-ox( i ,j,k,2)) vx(i,j,k)= cp*(oy( i ,j,k,2)-oy(i-1,j,k,2)) . +cn*(oy(i+1,j,k,2)-oy( i ,j,k,2)) wx(i,j,k)= cp*(oz( i ,j,k,2)-oz(i-1,j,k,2)) . +cn*(oz(i+1,j,k,2)-oz( i ,j,k,2)) 1 continue #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp c1p=.5*gc1*amax1(0.,ox(1,j,k,0)) c1n=.5*gc1*amin1(0.,ox(1,j,k,0)) ux(1,j,k)= c1n*(ox(2,j,k,2)-ox( 1,j,k,2)) 1 +ibcx*c1p*(ox(1,j,k,2)-ox(-1,j,k,2)) vx(1,j,k)= c1n*(oy(2,j,k,2)-oy( 1,j,k,2)) 1 +ibcx*c1p*(oy(1,j,k,2)-oy(-1,j,k,2)) wx(1,j,k)= c1n*(oz(2,j,k,2)-oz( 1,j,k,2)) 1 +ibcx*c1p*(oz(1,j,k,2)-oz(-1,j,k,2)) enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp cnp=.5*gc1*amax1(0.,ox(np,j,k,0)) cnn=.5*gc1*amin1(0.,ox(np,j,k,0)) ux(np,j,k)= cnp*(ox(np ,j,k,2)-ox(np-1,j,k,2)) 1 +ibcx*cnn*(ox(np+2,j,k,2)-ox(np ,j,k,2)) vx(np,j,k)= cnp*(oy(np ,j,k,2)-oy(np-1,j,k,2)) 1 +ibcx*cnn*(oy(np+2,j,k,2)-oy(np ,j,k,2)) wx(np,j,k)= cnp*(oz(np ,j,k,2)-oz(np-1,j,k,2)) 1 +ibcx*cnn*(oz(np+2,j,k,2)-oz(np ,j,k,2)) enddo enddo end if #endif if(j3.eq.1) then jllim = 1 + j3*botedge julim = mp - j3*topedge do 2 k=1,l do 2 j=jllim,julim do 2 i=1,np cp=0.5*gc2*amax1(0., oy(i,j,k,0)) cn=0.5*gc2*amin1(0., oy(i,j,k,0)) uy(i,j,k)= cp*(ox(i,j ,k,2)-ox(i,j-j3,k,2)) . +cn*(ox(i,j+j3,k,2)-ox(i,j ,k,2)) vy(i,j,k)= cp*(oy(i,j ,k,2)-oy(i,j-j3,k,2)) . +cn*(oy(i,j+j3,k,2)-oy(i,j ,k,2)) wy(i,j,k)= cp*(oz(i,j ,k,2)-oz(i,j-j3,k,2)) . +cn*(oz(i,j+j3,k,2)-oz(i,j ,k,2)) 2 continue #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np c1p=0.5*gc2*amax1(0., oy(i,1,k,0)) c1n=0.5*gc2*amin1(0., oy(i,1,k,0)) uy(i,1,k)= c1n*(ox(i,1+j3,k,2)-ox(i, 1,k,2)) 1 +ibcy*c1p*(ox(i,1 ,k,2)-ox(i,-j3,k,2)) vy(i,1,k)= c1n*(oy(i,1+j3,k,2)-oy(i, 1,k,2)) 1 +ibcy*c1p*(oy(i,1 ,k,2)-oy(i,-j3,k,2)) wy(i,1,k)= c1n*(oz(i,1+j3,k,2)-oz(i, 1,k,2)) 1 +ibcy*c1p*(oz(i,1 ,k,2)-oz(i,-j3,k,2)) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np cmp=0.5*gc2*amax1(0., oy(i,mp,k,0)) cmn=0.5*gc2*amin1(0., oy(i,mp,k,0)) uy(i,mp,k)=cmp*(ox(i,mp ,k,2)-ox(i,mp-j3,k,2)) 1 +ibcy*cmn*(ox(i,mp+1+j3,k,2)-ox(i,mp ,k,2)) vy(i,mp,k)=cmp*(oy(i,mp ,k,2)-oy(i,mp-j3,k,2)) 1 +ibcy*cmn*(oy(i,mp+1+j3,k,2)-oy(i,mp ,k,2)) wy(i,mp,k)=cmp*(oz(i,mp ,k,2)-oz(i,mp-j3,k,2)) 1 +ibcy*cmn*(oz(i,mp+1+j3,k,2)-oz(i,mp ,k,2)) enddo enddo end if #else if (botedge.eq.1) then do k=1,l do i=1,np c1p=0.5*gc2*amax1(0., oy(i,1,k,0)) c1n=0.5*gc2*amin1(0., oy(i,1,k,0)) uy(i,1,k)= c1p*(ox(i,1 ,k,2)-pflip*ox(i,1-j3,k,2)) . +c1n*(ox(i,1+j3,k,2)- ox(i,1 ,k,2)) vy(i,1,k)= c1p*(oy(i,1 ,k,2)-pflip*oy(i,1-j3,k,2)) . +c1n*(oy(i,1+j3,k,2)- oy(i,1 ,k,2)) wy(i,1,k)= c1p*(oz(i,1 ,k,2)-oz(i,1-j3,k,2)) c wy(i,1,k)= c1p*(oz(i,1 ,k,2)-pflip*oz(i,1-j3,k,2)) . +c1n*(oz(i,1+j3,k,2)- oz(i,1 ,k,2)) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np cmp=0.5*gc2*amax1(0., oy(i,mp,k,0)) cmn=0.5*gc2*amin1(0., oy(i,mp,k,0)) uy(i,mp,k)= cmp*( ox(i,mp ,k,2)-ox(i,mp-j3,k,2)) . +cmn*(pflip*ox(i,mp+j3,k,2)-ox(i,mp ,k,2)) vy(i,mp,k)= cmp*( oy(i,mp ,k,2)-oy(i,mp-j3,k,2)) . +cmn*(pflip*oy(i,mp+j3,k,2)-oy(i,mp ,k,2)) wy(i,mp,k)= cmp*( oz(i,mp ,k,2)-oz(i,mp-j3,k,2)) . +cmn*(oz(i,mp+j3,k,2)-oz(i,mp ,k,2)) c . +cmn*(pflip*oz(i,mp+j3,k,2)-oz(i,mp ,k,2)) enddo enddo end if #endif else do k=1,l do j=1,mp do i=1,np uy(i,j,k)=0. vy(i,j,k)=0. wy(i,j,k)=0. enddo end do end do endif do 3 k=2,l-1 do 3 j=1,mp do 3 i=1,np cp=.5*gc3*amax1(0.,oz(i,j,k,0)) cn=.5*gc3*amin1(0.,oz(i,j,k,0)) uz(i,j,k)= cp*(ox(i,j, k ,2)-ox(i,j,k-1,2)) . +cn*(ox(i,j,k+1,2)-ox(i,j, k ,2)) vz(i,j,k)= cp*(oy(i,j, k ,2)-oy(i,j,k-1,2)) . +cn*(oy(i,j,k+1,2)-oy(i,j, k ,2)) wz(i,j,k)= cp*(oz(i,j, k ,2)-oz(i,j,k-1,2)) . +cn*(oz(i,j,k+1,2)-oz(i,j, k ,2)) 3 continue do j=1,mp do i=1,np c1p=.5*gc3*amax1(0.,oz(i,j,1,0)) c1n=.5*gc3*amin1(0.,oz(i,j,1,0)) clp=.5*gc3*amax1(0.,oz(i,j,l,0)) cln=.5*gc3*amin1(0.,oz(i,j,l,0)) uz(i,j,1)= c1n*(ox(i,j,2,2)-ox(i,j, 1 ,2)) 1 +ibcz*c1p*(ox(i,j,1,2)-ox(i,j,l-1,2)) uz(i,j,l)= clp*(ox(i,j,l,2)-ox(i,j,l-1,2)) 1 +ibcz*c1n*(ox(i,j,2,2)-ox(i,j, l ,2)) vz(i,j,1)= c1n*(oy(i,j,2,2)-oy(i,j, 1 ,2)) 1 +ibcz*c1p*(oy(i,j,1,2)-oy(i,j,l-1,2)) vz(i,j,l)= clp*(oy(i,j,l,2)-oy(i,j,l-1,2)) 1 +ibcz*c1n*(oy(i,j,2,2)-oy(i,j, l ,2)) wz(i,j,1)= c1n*(oz(i,j,2,2)-oz(i,j, 1 ,2)) 1 +ibcz*c1p*(oz(i,j,1,2)-oz(i,j,l-1,2)) wz(i,j,l)= clp*(oz(i,j,l,2)-oz(i,j,l-1,2)) 1 +ibcz*c1n*(oz(i,j,2,2)-oz(i,j, l ,2)) enddo enddo do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=ox(i,j,k,1)-ux(i,j,k)-uy(i,j,k)-uz(i,j,k) oy(i,j,k,1)=oy(i,j,k,1)-vx(i,j,k)-vy(i,j,k)-vz(i,j,k) oz(i,j,k,1)=oz(i,j,k,1)-wx(i,j,k)-wy(i,j,k)-wz(i,j,k) enddo enddo enddo if(iw.eq.1) then do k=1,l do j=1,mp do i=1,np g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ox(i,j,k,2)=g11*ox(i,j,k,1)+g21*oy(i,j,k,1) oy(i,j,k,2)=g12*ox(i,j,k,1)+g22*oy(i,j,k,1) oz(i,j,k,2)=g13*ox(i,j,k,1)+g23*oy(i,j,k,1)+g33*oz(i,j,k,1) ox(i,j,k,1)=ox(i,j,k,2)+strxd(i,j) oy(i,j,k,1)=oy(i,j,k,2)+stryd(i,j) oz(i,j,k,1)=oz(i,j,k,2)-gmul(k)*zsd(i,j)/zb*g33 . +(gmul(k)/zb-1.)*zhd(i,j)*g33 enddo enddo enddo endif if(ialff.eq.1) call trnsav(ox(1-ih,1-ih,1,1), * oy(1-ih,1-ih,1,1), * oz(1-ih,1-ih,1,1), * wx,wy,wz,j3,ibcx,ibcy,ibcz) 777 continue continuity constraint imposed icont=icont0*itraj1 if(icont.eq.1) then do k=1,l do j=1,mp do i=1,np w(i,j,k,1)=0. ox(i,j,k,2)=1. oy(i,j,k,2)=0. oz(i,j,k,2)=1. u(i,j,k,1)=1. enddo enddo enddo if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,1), * oy(1-ih,1-ih,1,1), * oz(1-ih,1-ih,1,1),1) store=initprs initprs=0 call gcrk(w(1-ih,1-ih,1,1),pfx,pfy,pfz, 1 ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), 1 ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), 1 u(1-ih,1-ih,1,1),ub,vb,ob,itpr,eppr,1,1) c 1 u(1-ih,1-ih,1,1),itpr,eppr,1) call prforc(w(1-ih,1-ih,1,1),pfx,pfy,pfz, 1 ox(1-ih,1-ih,1,1),oy(1-ih,1-ih,1,1),oz(1-ih,1-ih,1,1), 1 ox(1-ih,1-ih,1,2),oy(1-ih,1-ih,1,2),oz(1-ih,1-ih,1,2), 1 u(1-ih,1-ih,1,1),ub,vb,ob,1) c 1 u(1-ih,1-ih,1,1)) initprs=store do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=pfx(i,j,k) oy(i,j,k,1)=pfy(i,j,k) oz(i,j,k,1)=pfz(i,j,k) enddo enddo enddo if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,1), * oy(1-ih,1-ih,1,1), * oz(1-ih,1-ih,1,1),-1) endif !end of auxuliary pr.solver do k=1,l do j=1,mp do i=1,np u(i,j,k,1)=u(i,j,k,0) v(i,j,k,1)=v(i,j,k,0) w(i,j,k,1)=w(i,j,k,0) enddo enddo enddo ENDIF if(ieul.eq.1) then if(itraj1.eq.0) then do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=0.5*(ox(i,j,k,1)+ox(i,j,k,0)*d(i,j,k))*gc1 oy(i,j,k,1)=0.5*(oy(i,j,k,1)+oy(i,j,k,0)*d(i,j,k))*gc2 oz(i,j,k,1)=0.5*(oz(i,j,k,1)+oz(i,j,k,0)*d(i,j,k))*gc3 enddo enddo enddo else do k=1,l do j=1,mp do i=1,np ox(i,j,k,1)=ox(i,j,k,1)*d(i,j,k)*gc1 oy(i,j,k,1)=oy(i,j,k,1)*d(i,j,k)*gc2 oz(i,j,k,1)=oz(i,j,k,1)*d(i,j,k)*gc3 enddo enddo enddo endif create staggered advective velocities for A or B grid ibxo=1-ibcx ibyo=1-ibcy ibzo=1-ibcz if (igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call updatelr(ox(1-ih,1-ih,1,1),np,mp,l,np,mp,iupx) call updatebt(oy(1-ih,1-ih,1,1),np,mp,l,np,mp,iupy) do k=2,l do j=1,mp do i=1,np z0(i,j,k)=0.5*(oz(i,j,k,1)+oz(i,j,k-1,1)) enddo enddo enddo do j=1,mp do i=1,np wbc(i,j,1)=ibcz*z0(i,j,l)+ibzo*(2.*oz(i,j,1,1)-z0(i,j,2)) wbc(i,j,2)=ibcz*z0(i,j,2)+ibzo*(2.*oz(i,j,l,1)-z0(i,j,l)) enddo enddo #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp + j3*topedge #endif do k=1,l do j=jllim,julim do i=1,np y0(i,j,k)=0.5*(oy(i,j,k,1)+oy(i,j-j3,k,1)) enddo enddo enddo #if (POLES == 0) if(ibcy.eq.1) then call updatebt(y0,np,mp,l,np,mp,2) if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=y0(i,0,k) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np vbc(i,k,2)=y0(i,mp+2*j3,k) end do end do end if else ! ibcy=0 if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=2.*oy(i,1,k,1)-y0(i,1+j3,k) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np vbc(i,k,2)=2.*oy(i,mp,k,1)-y0(i,mp,k) end do end do end if endif #else if ((botedge.eq.1).or.(topedge.eq.1)) then do k=1,l do i=1,np vbc(i,k,1)=0. vbc(i,k,2)=0. enddo enddo end if #endif #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,l do j=1,mp do i=illim,iulim x0(i,j,k)=0.5*(ox(i,j,k,1)+ox(i-1,j,k,1)) enddo enddo enddo #if (POLES == 0) if(ibcx.eq.1) then call updatelr(x0,np,mp,l,np,mp,2) if (leftedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,1)=x0(0,j,k) enddo enddo end if if (rightedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,2)=x0(np+2,j,k) enddo enddo end if else ! ibcx=0 if (leftedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,1)=2.*ox(1,j,k,1)-x0(2,j,k) enddo enddo end if if (rightedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,2)=2.*ox(np,j,k,1)-x0(np,j,k) enddo enddo end if endif #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) illim = 1 + leftedge jllim = 1 + j3*botedge illim0= 1 - leftedge jllim0= 1 - j3*botedge iulim = np + rightedge julim = mp + j3*topedge iupwy = 1 + 2*ibcy n1=1 n2=np m1=1 m2=mp if ( leftedge.eq.1) n1=0 if (rightedge.eq.1) n2=np+1 if ( botedge.eq.1) m1=0 if ( topedge.eq.1) m2=mp+1 if(j3.eq.0) then ! <----------- 2D call updatelr(ox(1-ih,1-ih,1,1),np,mp,l,np,mp,iupx) call updatelr(oy(1-ih,1-ih,1,1),np,mp,l,np,mp,iupy) CCCCCCCCCCCCC c: U velocity CCCCCCCCCCCCC do 40 k=1,l do 40 i=1,np 40 wk0(i,1,k)=ox(i,1,k,1) if (leftedge.eq.1) then do k=1,l wk0(0,1,k)=ibcx*ox(-1,1,k,1)+ibxo*(2.*ox(1,1,k,1)-ox(2,1,k,1)) enddo endif if (rightedge.eq.1) then do k=1,l wk0(np+1,1,k)= . ibcx*ox(np+2,1,k,1)+ibxo*(2.*ox(np,1,k,1)-ox(np-1,1,k,1)) enddo endif do 42 i=illim0,iulim wk0(i,1, 0 )=ibcz*wk0(i,1,l-1)+ibzo*wk0(i,1, 2 ) 42 wk0(i,1,l+1)=ibcz*wk0(i,1, 2 )+ibzo*wk0(i,1,l-1) #if (PARALLEL > 0) call updatelrw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,1) #endif c: B-grid average do k=1,l+1 do i=1,iulim wk1(i,1,k)=.25*( wk0(i,1,k-1)+wk0(i-1,1,k-1) . +wk0(i,1, k )+wk0(i-1,1, k ) ) enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(wk1,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(wk1,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(wk1,np ,mp+1,l+1,np+1,mp+1,1) else call updatelr(wk1,np+1,mp+1,l+1,np+1,mp+1,1) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid x velocities do k=1,l do i=illim,np x0(i,1,k)=0.5*(wk1(i,1,k)+wk1(i,1,k+1)) enddo enddo if (leftedge.eq.1) then do k=1,l ubc(1,k,1)=0.5*(wk1(1,1,k)+wk1(1,1,k+1)) ubc(1,k,2)=0.5*(wk1(0,1,k)+wk1(0,1,k+1)) enddo endif if (rightedge.eq.1) then do k=1,l ubc(1,k,1)=0.5*(wk1(np+2,1,k)+wk1(np+2,1,k+1)) ubc(1,k,2)=0.5*(wk1(np+1,1,k)+wk1(np+1,1,k+1)) enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc CCCCCCCCCCCCC c: W velocity CCCCCCCCCCCCC do 50 k=1,l do 50 i=1,np 50 wk0(i,1,k)=oz(i,1,k,1) if (leftedge.eq.1) then do k=1,l wk0(0,1,k)=ibcx*oz(-1,1,k,1)+ibxo*oz(2,1,k,1) enddo endif if (rightedge.eq.1) then do k=1,l wk0(np+1,1,k)=ibcx*oz(np+2,1,k,1)+ibxo*oz(np-1,1,k,1) enddo endif do 52 i=illim0,iulim wk0(i,1, 0 )=ibcz*wk0(i,1,l-1)+ibzo*(2.*wk0(i,1,1)-wk0(i,1,2 )) 52 wk0(i,1,l+1)=ibcz*wk0(i,1,2 )+ibzo*(2.*wk0(i,1,l)-wk0(i,1,l-1)) #if (PARALLEL > 0) call updatelrw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,1) #endif c: B-grid average do k=1,l+1 do i=1,iulim wk1(i,1,k)=.25*( wk0(i,1,k-1)+wk0(i-1,1,k-1) . +wk0(i,1, k )+wk0(i-1,1, k ) ) enddo enddo #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(wk1,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(wk1,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(wk1,np ,mp+1,l+1,np+1,mp+1,1) else call updatelr(wk1,np+1,mp+1,l+1,np+1,mp+1,1) end if #endif ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid z velocities do k=2,l do i=1,np z0(i,1,k)=0.5*(wk1(i,1,k)+wk1(i+1,1,k)) enddo enddo do i=1,np wbc(i,1,1)=0.5*(wk1(i,1, 1 )+wk1(i+1,1, 1 )) wbc(i,1,2)=0.5*(wk1(i,1,l+1)+wk1(i+1,1,l+1)) enddo c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc else ! <----------- 3D call updatelr(ox(1-ih,1-ih,1,1),np,mp,l,np,mp,iupx) call updatelr(oy(1-ih,1-ih,1,1),np,mp,l,np,mp,iupx) call updatelr(oz(1-ih,1-ih,1,1),np,mp,l,np,mp,iupx) c: U velocity do 10 k=1,l do 10 j=1,mp do 10 i=1,np 10 wk0(i,j,k)=ox(i,j,k,1) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*ox(-1 ,j,k,1) * +ibxo*(2.*ox(1 ,j,k,1)-ox(2 ,j,k,1)) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*ox(np+2,j,k,1) * +ibxo*(2.*ox(np,j,k,1)-ox(np-1,j,k,1)) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)=ibcy*wk0(i,-2-j3,k)+ibyo*wk0(i,1+j3,k) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)=ibcy*wk0(i,mp+3+j3,k)+ibyo*wk0(i,mp-j3,k) enddo enddo endif do 13 j=jllim0,julim do 13 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*wk0(i,j, 2 ) 13 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*wk0(i,j,l-1) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,1) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,1) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,1) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid x velocities do k=1,l do j=1,mp do i=illim,np x0(i,j,k)=0.25*( wk1(i,j ,k)+wk1(i,j ,k+1) . +wk1(i,j+j3,k)+wk1(i,j+j3,k+1) ) enddo enddo enddo if (leftedge.eq.1) then do k=1,l do j=1,mp ubc(j,k,1)=0.25*( wk1(1,j ,k)+wk1(1,j ,k+1) . +wk1(1,j+j3,k)+wk1(1,j+j3,k+1) ) ubc(j,k,2)=0.25*( wk1(0,j ,k)+wk1(0,j ,k+1) . +wk1(0,j+j3,k)+wk1(0,j+j3,k+1) ) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp ubc(j,k,1)=0.25*( wk1(np+2,j ,k)+wk1(np+2,j ,k+1) . +wk1(np+2,j+j3,k)+wk1(np+2,j+j3,k+1) ) ubc(j,k,2)=0.25*( wk1(np+1,j ,k)+wk1(np+1,j ,k+1) . +wk1(np+1,j+j3,k)+wk1(np+1,j+j3,k+1) ) enddo enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc c: V velocity do 20 k=1,l do 20 j=1,mp do 20 i=1,np 20 wk0(i,j,k)=oy(i,j,k,1) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*oy(-1,j,k,1)+ibxo*oy(2,j,k,1) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*oy(np+2,j,k,1)+ibxo*oy(np-1,j,k,1) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)= ibcy*wk0(i,-2-j3,k) . +ibyo*(2.*wk0(i,1,k)-wk0(i,1+j3,k)) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)= ibcy*wk0(i,mp+3+j3,k) . +ibyo*(2.*wk0(i,mp,k)-wk0(i,mp-j3,k)) enddo enddo endif do 23 j=jllim0,julim do 23 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*wk0(i,j, 2 ) 23 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*wk0(i,j,l-1) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,1) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,1) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,1) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid y velocities do k=1,l do j=jllim,mp do i=1,np y0(i,j,k)=0.25*( wk1(i ,j,k)+wk1(i ,j,k+1) . +wk1(i+1,j,k)+wk1(i+1,j,k+1) ) enddo enddo enddo if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=0.25*( wk1(i ,1,k)+wk1(i ,1,k+1) . +wk1(i+1,1,k)+wk1(i+1,1,k+1) ) vbc(i,k,2)=0.25*( wk1(i ,0,k)+wk1(i ,0,k+1) . +wk1(i+1,0,k)+wk1(i+1,0,k+1) ) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=0.25*( wk1(i ,mp+j3+1,k)+wk1(i ,mp+j3+1,k+1) . +wk1(i+1,mp+j3+1,k)+wk1(i+1,mp+j3+1,k+1) ) vbc(i,k,2)=0.25*( wk1(i ,mp+j3 ,k)+wk1(i ,mp+j3 ,k+1) . +wk1(i+1,mp+j3 ,k)+wk1(i+1,mp+j3 ,k+1) ) enddo enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc c: W velocity do 30 k=1,l do 30 j=1,mp do 30 i=1,np 30 wk0(i,j,k)=oz(i,j,k,1) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*oz(-1,j,k,1)+ibxo*oz(2,j,k,1) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*oz(np+2,j,k,1)+ibxo*oz(np-1,j,k,1) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)=ibcy*wk0(i,-2-j3,k)+ibyo*wk0(i,1+j3,k) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)=ibcy*wk0(i,mp+3+j3,k)+ibyo*wk0(i,mp-j3,k) enddo enddo endif do 33 j=jllim0,julim do 33 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*(2.*wk0(i,j,1)-wk0(i,j, 2 )) 33 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*(2.*wk0(i,j,l)-wk0(i,j,l-1)) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,1) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,1) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,1) end if #endif ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid z velocities do k=2,l do j=1,mp do i=1,np z0(i,j,k)=0.25*( wk1(i, j ,k)+wk1(i+1, j ,k) . +wk1(i,j+j3,k)+wk1(i+1,j+j3,k) ) enddo enddo enddo do j=1,mp do i=1,np wbc(i,j,1)=0.25*( wk1(i, j ,1)+wk1(i+1, j ,1) . +wk1(i,j+j3,1)+wk1(i+1,j+j3,1) ) wbc(i,j,2)=0.25*( wk1(i, j ,l+1)+wk1(i+1, j ,l+1) . +wk1(i,j+j3,l+1)+wk1(i+1,j+j3,l+1) ) enddo enddo c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc endif ! <----------- 2D,3D #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif ! <--- igrid endif ! <--- ieul = 1 if(lagr.eq.1) then call update(ox(1-ih,1-ih,1,1),np,mp,l,np,mp,1) call update(oy(1-ih,1-ih,1,1),np,mp,l,np,mp,1) call update(oz(1-ih,1-ih,1,1),np,mp,l,np,mp,1) endif #if (TIMEPLT == 1) call ttend(39) #endif return end subroutine bvprd(u,v,w,ox,oy,oz) c --- computes extrapolated fields at n+1 c --- computes staggered velocities and fluxes for advective solver include 'param.nml' include 'msg.inc' dimension u(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . v(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . w(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . d(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/corio/ ang,fcr0,btpl,fcr2(np,mp),fcr3(np,mp),initprs common/rigidB/ ob(1-ih:nmhdp+ih,1-ih:mmhdp+ih,2), . ub(1-ih:mmhdp+ih, lmhd , 2), . vb(1-ih:nmhdp+ih, lmhd , 2) common/profB/ bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/sltB/ x0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 y0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 z0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) dimension wk0(0-ih:np+ih+1,0-ih:mp+ih+1,0:l+1) ! local array dimension wk1(1-ih:np+ih+1,1-ih:mp+ih+1,1:l+1) ! local array dimension p(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) ! local array common/mhdscr/ s1(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . s2(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . s3(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . s4(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) gc1=dt*dxi gc2=dt*dyi gc3=dt*dzi icont=1 !mod bbc do j=1,mp do i=1,np !Bench if (ibbl .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi gactp=1./(gi(i,j)*gmus(2)) + *((1-icylind)*gmm(i,j,2)**2*cosa(i,j) + +icylind*gmm(i,j,2))*dnmi * dt*dzi bze(i,j,2) = w(i,j,2) bze(i,j,1) = w(i,j,2)*(gactp/gacbt) endif if (ibbu .eq. 1) then dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(l-1)) + *((1-icylind)*gmm(i,j,l-1)**2*cosa(i,j) + +icylind*gmm(i,j,l-1))*dnmi gactp=1./(gi(i,j)*gmus(l)) + *((1-icylind)*gmm(i,j,l)**2*cosa(i,j) + +icylind*gmm(i,j,l))*dnmi bze(i,j,l-1) = w(i,j,l-1) bze(i,j,l) = w(i,j,l-1)*(gacbt/gactp) endif enddo enddo call update(bze,np,mp,l,np,mp,1) call bbc do k=1,l do j=1,mp do i=1,np g110=1./(gmm(i,j,k)*cosa(i,j)) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ox(i,j,k)=g11*u(i,j,k)+g21*v(i,j,k) oy(i,j,k)=g12*u(i,j,k)+g22*v(i,j,k) oz(i,j,k)=g13*u(i,j,k)+g23*v(i,j,k)+g33*w(i,j,k) if(icont.eq.0) then ox(i,j,k)=ox(i,j,k)*d(i,j,k)*gc1 oy(i,j,k)=oy(i,j,k)*d(i,j,k)*gc2 oz(i,j,k)=oz(i,j,k)*d(i,j,k)*gc3 endif enddo enddo enddo IF(ICONT.EQ.1) THEN call rhoswap( 1) do k=1,l do j=1,mp do i=1,np p(i,j,k)=0. s1(i,j,k)=1. s2(i,j,k)=0. s3(i,j,k)=1. s4(i,j,k)=1. enddo enddo enddo c if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,1), c * oy(1-ih,1-ih,1,1), c * oz(1-ih,1-ih,1,1),1) initprst=initprs initprs=0 call gcrk( p,x0,y0,z0,ox,oy,oz,s1,s2,s3,s4,ub,vb,ob * ,90,1.e-5,1,2) call prforc(p,x0,y0,z0,ox,oy,oz,s1,s2,s3,s4,ub,vb,ob,2) initprs=initprst call rhoswap(-1) do k=1,l do j=1,mp do i=1,np ox(i,j,k)=x0(i,j,k) oy(i,j,k)=y0(i,j,k) oz(i,j,k)=z0(i,j,k) enddo enddo enddo c if(tt.le.tend) call vstrhat(ox(1-ih,1-ih,1,1), c * oy(1-ih,1-ih,1,1), c * oz(1-ih,1-ih,1,1),-1) do k=1,l do j=1,mp do i=1,np ox(i,j,k)=ox(i,j,k)*d(i,j,k)*gc1 oy(i,j,k)=oy(i,j,k)*d(i,j,k)*gc2 oz(i,j,k)=oz(i,j,k)*d(i,j,k)*gc3 enddo enddo enddo ENDIF !end of auxuliary pr.solver Create staggered advective velocities for A or B grid ibxo=1-ibcx ibyo=1-ibcy ibzo=1-ibcz if (igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc call updatelr(ox(1-ih,1-ih,1),np,mp,l,np,mp,iupx) call updatebt(oy(1-ih,1-ih,1),np,mp,l,np,mp,iupy) do k=2,l do j=1,mp do i=1,np z0(i,j,k)=0.5*(oz(i,j,k)+oz(i,j,k-1)) enddo enddo enddo do j=1,mp do i=1,np wbc(i,j,1)=ibcz*z0(i,j,l)+ibzo*(2.*oz(i,j,1)-z0(i,j,2)) wbc(i,j,2)=ibcz*z0(i,j,2)+ibzo*(2.*oz(i,j,l)-z0(i,j,l)) enddo enddo #if (POLES == 0) jllim = 1 + j3*botedge julim = mp #else jllim = 1 julim = mp + j3*topedge #endif c jllim = 1 + j3*botedge !modpol do k=1,l c do j=jllim,mp do j=jllim,julim do i=1,np y0(i,j,k)=0.5*(oy(i,j,k)+oy(i,j-j3,k)) enddo enddo enddo #if (POLES == 0) call update(y0,np,mp,l,np,mp,iup) if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=ibcy*y0(i,0 ,k)+ibyo*(2.*oy(i,1,k)-y0(i,1+j3,k)) vbc(i,k,2)=ibcy*y0(i,1+j3,k)+ibyo*(2.*oy(i,0,k)-y0(i,0 ,k)) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=ibcy*y0(i,mp ,k)+ . ibyo*(2.*oy(i,mp+1,k)-y0(i,mp+1+j3,k)) vbc(i,k,2)=ibcy*y0(i,mp+1+j3,k)+ . ibyo*(2.*oy(i,mp ,k)-y0(i,mp ,k)) end do end do end if #else if ((botedge.eq.1).or.(topedge.eq.1)) then do k=1,l do i=1,np vbc(i,k,1)=0. vbc(i,k,2)=0. enddo enddo end if #endif #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif c illim = 1 + leftedge do k=1,l do j=1,mp do i=illim,iulim c do i=illim,np x0(i,j,k)=0.5*(ox(i,j,k)+ox(i-1,j,k)) enddo enddo enddo #if (POLES == 0) call update(x0,np,mp,l,np,mp,iup) if (leftedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,1)=ibcx*x0(0,j,k)+ibxo*(2.*ox(1,j,k)-x0(2,j,k)) ubc(j,k,2)=ibcx*x0(2,j,k)+ibxo*(2.*ox(0,j,k)-x0(0,j,k)) enddo enddo end if if (rightedge.eq.1) then do j=1,mp do k=1,l ubc(j,k,1)=ibcx*x0(np ,j,k)+ibxo*(2.*ox(np+1,j,k)-x0(np+2,j,k)) ubc(j,k,2)=ibcx*x0(np+2,j,k)+ibxo*(2.*ox(np ,j,k)-x0(np ,j,k)) enddo enddo end if #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) illim = 1 + leftedge jllim = 1 + j3*botedge illim0= 1 - leftedge jllim0= 1 - j3*botedge iulim = np + rightedge julim = mp + j3*topedge n1=1 n2=np m1=1 m2=mp if ( leftedge.eq.1) n1=0 if (rightedge.eq.1) n2=np+1 if ( botedge.eq.1) m1=0 if ( topedge.eq.1) m2=mp+1 if(j3.eq.0) then ! <----------- 2D call updatelr(ox(1-ih,1-ih,1),np,mp,l,np,mp,iupx) call updatelr(oy(1-ih,1-ih,1),np,mp,l,np,mp,iupx) CCCCCCCCCCCCC c: U velocity CCCCCCCCCCCCC do 40 k=1,l do 40 i=1,np 40 wk0(i,1,k)=ox(i,1,k) if (leftedge.eq.1) then do k=1,l wk0(0,1,k)=ibcx*ox(-1,1,k)+ibxo*(2.*ox(1,1,k)-ox(2,1,k)) enddo endif if (rightedge.eq.1) then do k=1,l wk0(np+1,1,k)= . ibcx*ox(np+2,1,k)+ibxo*(2.*ox(np,1,k)-ox(np-1,1,k)) enddo endif do 42 i=illim0,iulim wk0(i,1, 0 )=ibcz*wk0(i,1,l-1)+ibzo*wk0(i,1, 2 ) 42 wk0(i,1,l+1)=ibcz*wk0(i,1, 2 )+ibzo*wk0(i,1,l-1) #if (PARALLEL > 0) call updatelrw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupx) #endif c: B-grid average do k=1,l+1 do i=1,iulim wk1(i,1,k)=.25*( wk0(i,1,k-1)+wk0(i-1,1,k-1) . +wk0(i,1, k )+wk0(i-1,1, k ) ) enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(wk1,np ,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(wk1,np+1,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(wk1,np ,mp+1,l+1,np+1,mp+1,iupx) else call updatelr(wk1,np+1,mp+1,l+1,np+1,mp+1,iupx) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid x velocities do k=1,l do i=illim,np x0(i,1,k)=0.5*(wk1(i,1,k)+wk1(i,1,k+1)) enddo enddo if (leftedge.eq.1) then do k=1,l ubc(1,k,1)=0.5*(wk1(1,1,k)+wk1(1,1,k+1)) ubc(1,k,2)=0.5*(wk1(0,1,k)+wk1(0,1,k+1)) enddo endif if (rightedge.eq.1) then do k=1,l ubc(1,k,1)=0.5*(wk1(np+2,1,k)+wk1(np+2,1,k+1)) ubc(1,k,2)=0.5*(wk1(np+1,1,k)+wk1(np+1,1,k+1)) enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc CCCCCCCCCCCCC c: W velocity CCCCCCCCCCCCC do 50 k=1,l do 50 i=1,np 50 wk0(i,1,k)=oz(i,1,k) if (leftedge.eq.1) then do k=1,l wk0(0,1,k)=ibcx*oz(-1,1,k)+ibxo*oz(2,1,k) enddo endif if (rightedge.eq.1) then do k=1,l wk0(np+1,1,k)=ibcx*oz(np+2,1,k)+ibxo*oz(np-1,1,k) enddo endif do 52 i=illim0,iulim wk0(i,1, 0 )=ibcz*wk0(i,1,l-1)+ibzo*(2.*wk0(i,1,1)-wk0(i,1,2 )) 52 wk0(i,1,l+1)=ibcz*wk0(i,1,2 )+ibzo*(2.*wk0(i,1,l)-wk0(i,1,l-1)) #if (PARALLEL > 0) call updatelrw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupx) #endif c: B-grid average do k=1,l+1 do i=1,iulim wk1(i,1,k)=.25*( wk0(i,1,k-1)+wk0(i-1,1,k-1) . +wk0(i,1, k )+wk0(i-1,1, k ) ) enddo enddo #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(wk1,np ,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(wk1,np+1,mp ,l+1,np+1,mp+1,iupx) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(wk1,np ,mp+1,l+1,np+1,mp+1,iupx) else call updatelr(wk1,np+1,mp+1,l+1,np+1,mp+1,iupx) end if #endif ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid z velocities do k=2,l do i=1,np z0(i,1,k)=0.5*(wk1(i,1,k)+wk1(i+1,1,k)) enddo enddo do i=1,np wbc(i,1,1)=0.5*(wk1(i,1, 1 )+wk1(i+1,1, 1 )) wbc(i,1,2)=0.5*(wk1(i,1,l+1)+wk1(i+1,1,l+1)) enddo c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc else ! <----------- 3D call updatelr(ox(1-ih,1-ih,1),np,mp,l,np,mp,iupx) call updatelr(oy(1-ih,1-ih,1),np,mp,l,np,mp,iupx) call updatelr(oz(1-ih,1-ih,1),np,mp,l,np,mp,iupx) c: U velocity do 10 k=1,l do 10 j=1,mp do 10 i=1,np 10 wk0(i,j,k)=ox(i,j,k) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*ox(-1 ,j,k) * +ibxo*(2.*ox(1 ,j,k)-ox(2 ,j,k)) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*ox(np+2,j,k) * +ibxo*(2.*ox(np,j,k)-ox(np-1,j,k)) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)=ibcy*wk0(i,-2-j3,k)+ibyo*wk0(i,1+j3,k) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)=ibcy*wk0(i,mp+3+j3,k)+ibyo*wk0(i,mp-j3,k) enddo enddo endif do 13 j=jllim0,julim do 13 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*wk0(i,j, 2 ) 13 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*wk0(i,j,l-1) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iup) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,iup) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,iup) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid x velocities do k=1,l do j=1,mp do i=illim,np x0(i,j,k)=0.25*( wk1(i,j ,k)+wk1(i,j ,k+1) . +wk1(i,j+j3,k)+wk1(i,j+j3,k+1) ) enddo enddo enddo if (leftedge.eq.1) then do k=1,l do j=1,mp ubc(j,k,1)=0.25*( wk1(1,j ,k)+wk1(1,j ,k+1) . +wk1(1,j+j3,k)+wk1(1,j+j3,k+1) ) ubc(j,k,2)=0.25*( wk1(0,j ,k)+wk1(0,j ,k+1) . +wk1(0,j+j3,k)+wk1(0,j+j3,k+1) ) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp ubc(j,k,1)=0.25*( wk1(np+2,j ,k)+wk1(np+2,j ,k+1) . +wk1(np+2,j+j3,k)+wk1(np+2,j+j3,k+1) ) ubc(j,k,2)=0.25*( wk1(np+1,j ,k)+wk1(np+1,j ,k+1) . +wk1(np+1,j+j3,k)+wk1(np+1,j+j3,k+1) ) enddo enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc c: V velocity do 20 k=1,l do 20 j=1,mp do 20 i=1,np 20 wk0(i,j,k)=oy(i,j,k) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*oy(-1,j,k)+ibxo*oy(2,j,k) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*oy(np+2,j,k)+ibxo*oy(np-1,j,k) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)= ibcy*wk0(i,-2-j3,k) . +ibyo*(2.*wk0(i,1,k)-wk0(i,1+j3,k)) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)= ibcy*wk0(i,mp+3+j3,k) . +ibyo*(2.*wk0(i,mp,k)-wk0(i,mp-j3,k)) enddo enddo endif do 23 j=jllim0,julim do 23 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*wk0(i,j, 2 ) 23 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*wk0(i,j,l-1) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iup) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,iup) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,iup) end if ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid y velocities do k=1,l do j=jllim,mp do i=1,np y0(i,j,k)=0.25*( wk1(i ,j,k)+wk1(i ,j,k+1) . +wk1(i+1,j,k)+wk1(i+1,j,k+1) ) enddo enddo enddo if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=0.25*( wk1(i ,1,k)+wk1(i ,1,k+1) . +wk1(i+1,1,k)+wk1(i+1,1,k+1) ) vbc(i,k,2)=0.25*( wk1(i ,0,k)+wk1(i ,0,k+1) . +wk1(i+1,0,k)+wk1(i+1,0,k+1) ) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=0.25*( wk1(i ,mp+j3+1,k)+wk1(i ,mp+j3+1,k+1) . +wk1(i+1,mp+j3+1,k)+wk1(i+1,mp+j3+1,k+1) ) vbc(i,k,2)=0.25*( wk1(i ,mp+j3 ,k)+wk1(i ,mp+j3 ,k+1) . +wk1(i+1,mp+j3 ,k)+wk1(i+1,mp+j3 ,k+1) ) enddo enddo endif c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc c: W velocity do 30 k=1,l do 30 j=1,mp do 30 i=1,np 30 wk0(i,j,k)=oz(i,j,k) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*oz(-1,j,k)+ibxo*oz(2,j,k) enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*oz(np+2,j,k)+ibxo*oz(np-1,j,k) enddo enddo endif if (ibcy.eq.1) then call updatebtw(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iupwy) end if if (botedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,1-j3,k)=ibcy*wk0(i,-2-j3,k)+ibyo*wk0(i,1+j3,k) enddo enddo endif if (topedge.eq.1) then do k=1,l do i=illim0,iulim wk0(i,mp+j3,k)=ibcy*wk0(i,mp+3+j3,k)+ibyo*wk0(i,mp-j3,k) enddo enddo endif do 33 j=jllim0,julim do 33 i=illim0,iulim wk0(i,j, 0 )=ibcz*wk0(i,j,l-1)+ibzo*(2.*wk0(i,j,1)-wk0(i,j, 2 )) 33 wk0(i,j,l+1)=ibcz*wk0(i,j, 2 )+ibzo*(2.*wk0(i,j,l)-wk0(i,j,l-1)) #if (PARALLEL > 0) call updatew(wk0,n1,n2,m1,m2,l+2,0,np+1,0,mp+1,iup) #endif c: B-grid average do k=1,l+1 do j=1,julim do i=1,iulim wk1(i,j,k)=.125*( wk0(i ,j ,k-1)+wk0(i-1,j ,k-1) . +wk0(i-1,j-j3,k-1)+wk0(i ,j-j3,k-1) . +wk0(i ,j ,k )+wk0(i-1,j ,k ) . +wk0(i-1,j-j3,k )+wk0(i ,j-j3,k ) ) enddo enddo enddo #if (PARALLEL > 0) if (rightedge.eq.0 .and. topedge.eq.0) then call update(wk1,np ,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(wk1,np+1,mp ,l+1,np+1,mp+1,iup) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(wk1,np ,mp+1,l+1,np+1,mp+1,iup) else call update(wk1,np+1,mp+1,l+1,np+1,mp+1,iup) end if #endif ccccccccccccccccccccccccccccccccccccccccc c ----> grid C ---> grid C ---> grid C c c: C-grid z velocities do k=2,l do j=1,mp do i=1,np z0(i,j,k)=0.25*( wk1(i, j ,k)+wk1(i+1, j ,k) . +wk1(i,j+j3,k)+wk1(i+1,j+j3,k) ) enddo enddo enddo do j=1,mp do i=1,np wbc(i,j,1)=0.25*( wk1(i, j ,1)+wk1(i+1, j ,1) . +wk1(i,j+j3,1)+wk1(i+1,j+j3,1) ) wbc(i,j,2)=0.25*( wk1(i, j ,l+1)+wk1(i+1, j ,l+1) . +wk1(i,j+j3,l+1)+wk1(i+1,j+j3,l+1) ) enddo enddo c ----> grid C ---> grid C ---> grid C c ccccccccccccccccccccccccccccccccccccccccc endif ! <----------- 2D,3D #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif ! <--- igrid return end subroutine trnsav(ox,oy,oz,wx,wy,wz,j3,ibcx,ibcy,ibcz) include 'param.nml' include 'msg.inc' dimension ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l), . wx(1-ih:np+ih, 1-ih:mp+ih, l), . wy(1-ih:np+ih, 1-ih:mp+ih, l), . wz(1-ih:np+ih, 1-ih:mp+ih, l) #if (TIMEPLT == 1) call ttbeg(26) #endif ibxo=1-ibcx ibyo=1-ibcy ibzo=1-ibcz #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif call updatelr(oz,np,mp,l,np,mp,iupx) call updatelr(oy,np,mp,l,np,mp,iupx) call updatebt(ox,np,mp,l,np,mp,iupy) do k=1,l do j=1,mp do i=illim,iulim wz(i,j,k)=.25*(oz(i+1,j,k)+2.*oz(i,j,k)+oz(i-1,j,k)) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp wz(1,j,k)=.25*(oz(2,j,k)+2.*oz(1,j,k)+oz(-1,j,k))*ibcx * +oz(1,j,k)*ibxo enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp wz(np,j,k)=.25*(oz(np+2,j,k)+2.*oz(np,j,k)+oz(np-1,j,k))*ibcx * +oz(np,j,k)*ibxo enddo enddo end if #endif call updatebt(wz,np,mp,l,np,mp,iupy) do k=1,l do j=jllim,julim do i=1,np oz(i,j,k)=.25*(wz(i,j+j3,k)+2.*wz(i,j,k)+wz(i,j-j3,k)) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np oz(i,1,k)=.25*(wz(i,1+j3,k)+2.*wz(i,1,k)+wz(i,-j3,k))*ibcy * +wz(i,1,k)*ibyo enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np oz(i,mp,k)=.25*(wz(i,mp+1+j3,k)+2.*wz(i,mp,k)+wz(i,mp-j3,k))*ibcy * +wz(i,mp,k)*ibyo enddo enddo end if #endif do k=1,l do j=1,mp do i=illim,iulim wy(i,j,k)=.25*(oy(i+1,j,k)+2.*oy(i,j,k)+oy(i-1,j,k)) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,l do j=1,mp wy(1,j,k)=.25*(oy(2,j,k)+2.*oy(1,j,k)+oy(-1,j,k))*ibcx * +oy( 1,j,k) *ibxo enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp wy(np,j,k)=.25*(oy(np+2,j,k)+2.*oy(np,j,k)+oy(np-1,j,k))*ibcx * +oy( np ,j,k) *ibxo enddo enddo end if #endif do k=2,l-1 do j=1,mp do i=1,np oy(i,j,k)=.25*(wy(i,j,k+1)+2.*wy(i,j,k)+wy(i,j,k-1)) enddo enddo enddo do j=1,mp do i=1,np oy(i,j,1)=.25*(wy(i,j,2)+2.*wy(i,j,1)+wy(i,j,l-1))*ibcz * +wy(i,j, 1 ) *ibzo oy(i,j,l)=.25*(wy(i,j,2)+2.*wy(i,j,l)+wy(i,j,l-1))*ibcz * +wy(i,j, l ) *ibzo enddo enddo do k=1,l do j=jllim,julim do i=1,np wx(i,j,k)=.25*(ox(i,j+j3,k)+2.*ox(i,j,k)+ox(i,j-j3,k)) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then do k=1,l do i=1,np wx(i,1,k)=.25*(ox(i,1+j3,k)+2.*ox(i,1,k)+ox(i,-j3,k))*ibcy * +ox(i, 1,k) *ibyo enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np wx(i,mp,k)=.25*(ox(i,mp+1+j3,k)+2.*ox(i,mp,k)+ox(i,mp-j3,k))*ibcy * +ox(i,mp ,k) *ibyo enddo enddo end if #else if (botedge.eq.1) then do k=1,l do i=1,np wx(i,1,k)=.25*(ox(i,1+j3,k)+2.*ox(i,1,k)+pflip*ox(i,1-j3,k)) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np wx(i,mp,k)=.25*(pflip*ox(i,mp+j3,k)+2.*ox(i,mp,k)+ox(i,mp-j3,k)) enddo enddo end if #endif do k=2,l-1 do j=1,mp do i=1,np ox(i,j,k)=.25*(wx(i,j,k+1)+2.*wx(i,j,k)+wx(i,j,k-1)) enddo enddo enddo do j=1,mp do i=1,np ox(i,j,1)=.25*(wx(i,j,2)+2.*wx(i,j,1)+wx(i,j,l-1))*ibcz * +wx(i,j, 1 ) *ibzo ox(i,j,l)=.25*(wx(i,j,2)+2.*wx(i,j,l)+wx(i,j,l-1))*ibcz * +wx(i,j, l ) *ibzo enddo enddo #if (TIMEPLT == 1) call ttend(26) #endif return end #endif /* ANALIZE == 0 */ subroutine potprs(u,v,w,p) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . p(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 real globsum,psum #if (TIMEPLT == 1) call ttbeg(27) #endif compute pressure from the potential psum=0. if(igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do 1 k=1,l do 1 j=1,mp do 1 i=1,np 1 p(i,j,k)=-.5*(u(i,j,k)**2+j3*v(i,j,k)**2+w(i,j,k)**2) c return psum=globsum(p,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) psum=psum/float(n*m*l) do 2 k=1,l do 2 j=1,mp do 2 i=1,np 2 p(i,j,k)=p(i,j,k)-psum cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (POLES == 0) illim = 1 + leftedge jllim = 1 + j3*botedge call update(u,np,mp,l,np,mp,1) call update(v,np,mp,l,np,mp,1) call update(w,np,mp,l,np,mp,1) do 3 k=2,l do 3 j=jllim,mp do 3 i=illim,np uav=.125*( u(i ,j ,k )+u(i-1,j ,k ) 1 +u(i-1,j-j3,k )+u(i ,j-j3,k ) 1 +u(i ,j ,k-1)+u(i-1,j ,k-1) 1 +u(i-1,j-j3,k-1)+u(i ,j-j3,k-1) ) vav=.125*( v(i ,j ,k )+v(i-1,j ,k ) 1 +v(i-1,j-j3,k )+v(i ,j-j3,k ) 1 +v(i ,j ,k-1)+v(i-1,j ,k-1) 1 +v(i-1,j-j3,k-1)+v(i ,j-j3,k-1) )*j3 wav=.125*( w(i ,j ,k )+w(i-1,j ,k ) 1 +w(i-1,j-j3,k )+w(i ,j-j3,k ) 1 +w(i ,j ,k-1)+w(i-1,j ,k-1) 1 +w(i-1,j-j3,k-1)+w(i ,j-j3,k-1) ) 3 p(i,j,k)=-.5*(uav**2+vav**2+wav**2) psum=globsum(p,1-ih,np+ih,1-ih,mp+ih,1,l,illim,np,jllim,mp,2,l) psum=psum/float((l-1)*(m-j3)*(n-1)) do 4 k=2,l do 4 j=jllim,mp do 4 i=illim,np 4 p(i,j,k)=p(i,j,k)-psum #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif call update(p,np,mp,l,np,mp,1) if (mype.eq.0) print 100, psum 100 format(2x,'potential initialisation, psum=', e11.4) #if (TIMEPLT == 1) call ttend(27) #endif return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine reduce_sum(f,fav,tau,iflg) ! include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" dimension faver(m,l) #endif dimension f(1-ih:np+ih,1-ih:mp+ih,l), . tau(l,1-ih:np+ih,1-ih:mp+ih), . tmpyz(mp,l),fav(mp,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw mpl=m*l #if (POLES == 0) iulim=np-ibcx*rightedge #else iulim=np #endif #if(PARALLEL > 0) do k=1,l do j=1,mp ja=j+(mpos-1)*mp faver(ja,k)=0. do i=1,iulim relt =(relx(i,j)**2+rely(i,j)**2) & /(relx(i,j)+rely(i,j)+1.e-13) alph =(tau(k,i,j)**2+relt**2) & /(tau(k,i,j)+relt+1.e-13) alph=alph*iflg+float(1-iflg) faver(ja,k)=faver(ja,k)+alph*f(i,j,k) enddo faver(ja,k)=faver(ja,k)/iulim enddo enddo CALL MPI_Reduce(faver/nprocx,fav,mpl,DC_TYPE,MPI_SUM, $ 0,MPI_COMM_EULAG ,ierror) #else do k=1,l do j=1,mp fav(j,k)=0. do i=1,iulim relt =(relx(i,j)**2+rely(i,j)**2) & /(relx(i,j)+rely(i,j)+1.e-13) alph =(tau(k,i,j)**2+relt**2) & /(tau(k,i,j)+relt+1.e-13) alph=alph*iflg+float(1-iflg) fav(j,k)=fav(j,k)+alph*f(i,j,k) end do fav(j,k)=fav(j,k)/iulim end do end do #endif return end ! subroutine zonav(f,fav,tau,iflg) include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" dimension faver(mp,l),raver(mp,l) #endif dimension f(1-ih:np+ih,1-ih:mp+ih,l), . tau(l,1-ih:np+ih,1-ih:mp+ih), . fav(mp,l),rav(mp,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw #if (TIMEPLT == 1) call ttbeg(28) #endif #if(PARALLEL > 0) mpl=mp*l #if (POLES == 0) iulim=np-ibcx*rightedge #else iulim=np #endif do k=1,l do j=1,mp faver(j,k)=0. raver(j,k)=0. c ja=j+(mpos-1)*mp do i=1,iulim c ia=i+(npos-1)*np c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) alph=tau(k,i,j)*(1.-relt)+relt alph=alph*iflg+float(1-iflg) faver(j,k)=faver(j,k)+alph*rho(i,j,k)*f(i,j,k) raver(j,k)=raver(j,k)+alph*rho(i,j,k) enddo enddo enddo c goto 99 CALL MPI_ALLReduce(faver,fav,mpl,DC_TYPE,MPI_SUM, $ my_row,ierror) CALL MPI_ALLReduce(raver,rav,mpl,DC_TYPE,MPI_SUM, $ my_row,ierror) c 99 continue do j=1,mp do k=1,l fav(j,k)=fav(j,k)/amax1(rav(j,k), 1.e-15) enddo enddo #else do 1 k=1,l do 1 j=1,mp fav(j,k)=0. rav(j,k)=0. do 10 i=1,np-ibcx c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) alph=tau(k,i,j)*(1.-relt)+relt alph=alph*iflg+float(1-iflg) fav(j,k)=fav(j,k)+alph*rho(i,j,k)*f(i,j,k) 10 rav(j,k)=rav(j,k)+alph*rho(i,j,k) 1 fav(j,k)=fav(j,k)/amax1(rav(j,k),1.e-15) #endif #if (TIMEPLT == 1) call ttend(28) #endif return end subroutine spherav(f,fav,tau,iflg) include 'param.nml' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" dimension faver(l),raver(l) #endif dimension f(1-ih:np+ih,1-ih:mp+ih,l), . tau(l,1-ih:np+ih,1-ih:mp+ih), . fav(l),rav(l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw #if (TIMEPLT == 1) call ttbeg(28) #endif #if(PARALLEL > 0) mpl=mp*l #if (POLES == 0) iulim=np-ibcx*rightedge #else iulim=np #endif do k=1,l faver(k)=0. raver(k)=0. do j=1,mp c ja=j+(mpos-1)*mp do i=1,iulim c ia=i+(npos-1)*np c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) alph=tau(k,i,j)*(1.-relt)+relt alph=alph*iflg+float(1-iflg) faver(k)=faver(k)+alph*rho(i,j,k)*f(i,j,k) raver(k)=raver(k)+alph*rho(i,j,k) enddo enddo enddo c goto 99 CALL MPI_ALLReduce(faver,fav,mpl,DC_TYPE,MPI_SUM, $ my_row,ierror) CALL MPI_ALLReduce(raver,rav,mpl,DC_TYPE,MPI_SUM, $ my_row,ierror) c 99 continue do k=1,l fav(k)=fav(k)/amax1(rav(k), 1.e-15) enddo #else do 1 k=1,l fav(k)=0. rav(k)=0. do 1 j=1,mp do 10 i=1,np-ibcx c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) alph=tau(k,i,j)*(1.-relt)+relt alph=alph*iflg+float(1-iflg) fav(k)=fav(k)+alph*rho(i,j,k)*f(i,j,k) 10 rav(k)=rav(k)+alph*rho(i,j,k) 1 fav(k)=fav(k)/amax1(rav(k),1.e-15) #endif #if (TIMEPLT == 1) call ttend(28) #endif return end #if (ANALIZE == 0) subroutine advec(xf,xd1,xd2,xd3,iflg,ifirst) include 'param.nml' include 'msg.inc' dimension xd1(1-ih:np+ih, 1-ih:mp+ih, l), . xd2(1-ih:np+ih, 1-ih:mp+ih, l), . xd3(1-ih:np+ih, 1-ih:mp+ih, l), . xf(1-ih:np+ih, 1-ih:mp+ih, l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . d(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) c return #if (TIMEPLT == 1) call ttbeg(30) #endif #if (SEMILAG == 1) #if (J3DIM == 1) call inter3(xf,xd1,xd2,xd3,ifirst) #endif #if (J3DIM == 0) call inter2(xf,xd1,xd3,ifirst) #endif #endif #if (SEMILAG == 0) #if (J3DIM == 1) c if(iflg.eq.1) then c if(iflg.eq.1.or.(iflg.ge.31.and.iflg.le.33)) then if(iflg.ge.2.and.iflg.le.4) then call mpdata3(xd1,xd2,xd3,xf,d,iflg) c call mpdatm3(xd1,xd2,xd3,xf,d,iflg) else c call mpdatm3(xd1,xd2,xd3,xf,d,iflg) call mpdata3(xd1,xd2,xd3,xf,d,iflg) endif #endif #if (J3DIM == 0) if(iflg.ge.2.and.iflg.le.5) then call mpdatm2(xd1,xd3,xf,d,iflg) !default else call mpdata2(xd1,xd3,xf,d,iflg) !default endif #endif #endif #if (TIMEPLT == 1) call ttend(30) #endif return end #if (SEMILAG == 0) #if (J3DIM == 0) subroutine mpdata2(u1,u2,x,h,iflg) include 'param.nml' include 'msg.inc' dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(iord0=2,isor=1,nonos=1,idiv=0) parameter(n1=np+1,n2=l+1) parameter(n1m=n1-1,n2m=n2-1,n2mm=n2-2) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+l)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(l,2),scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc data ep/1.e-10/ c donor(y1,y2,a)=amax1(0.,a)*y1+amin1(0.,a)*y2 vdyf(x1,x2,a,r)=(abs(a)-a**2/r)*(abs(x2)-abs(x1)) 1 /(abs(x2)+abs(x1)+ep) vcorr(a,b,y1,y2,r)=-0.125*a*b*y1/(y2*r) vcor31(a,x0,x1,x2,x3,r)= -(a -3.*abs(a)*a/r+2.*a**3/r**2)/3. 1 *(abs(x0)+abs(x3)-abs(x1)-abs(x2)) 2 /(abs(x0)+abs(x3)+abs(x1)+abs(x2)+ep) vcor32(a,b,y1,y2,r)=0.25*b/r*(abs(a)-2.*a**2/r)*y1/y2 vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) #if (TIMEPLT == 1) call ttbeg(31) #endif call updatelr(x,np,mp,l,np,mp,iupx) iprec=0 c if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib iord=iord0 if(isor.eq.3) iord=max0(iord,3) if(liner.eq.1) iord=1 iboz=1-ibcz #if (POLES == 0) ibox=1-ibcx illim1 = 1 illim2 = 1 + leftedge illim3 = 1 + 2*leftedge iulim1 = np + rightedge iulim2 = np - rightedge illimx = 1 + (1-ibcx)*leftedge illimx2 = 1 + (2-ibcx)*leftedge iulimx = np + (ibcx-1)*rightedge #else ibox=0 illim1 = 1 illim2 = 1 illim3 = 1 iulim1 = np iulim2 = np illimx = 1 illimx2 = 1 iulimx = np #endif do j=1,n2m do i=illim2,np v1(i,1,j) = u1(i,1,j) end do end do #if (POLES == 0) if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j) = ubc(1,j,1) end do end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j) = ubc(1,j,2) end do end if #endif do i=1,np do j=2,n2m v2(i,1,j) = u2(i,1,j) end do #if (POLES == 0) v2(i,1, 1) = wbc(i,1,1) v2(i,1,n2) = wbc(i,1,2) #endif enddo if(nonos.eq.1) then do j=1,n2m #if (POLES == 0) jm=ibcz*(j-1+(n2-j)/n2m*(n2-2))+iboz*max0(j-1,1 ) jp=ibcz*(j+1 -j /n2m*(n2-2))+iboz*min0(j+1,n2m) #else jm=j-1 jp=j+1 #endif do i=1,np #if (POLES == 0) if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if cvec im=ibcx*(i-1+(n1-i)/n1m*(n1-2))+(1-ibcx)*max0(i-1,1 ) cvec ip=ibcx*(i+1 -i /n1m*(n1-2))+(1-ibcx)*min0(i+1,n1m) #else im = i - 1 ip = i + 1 #endif mx(i,1,j)=amax1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp)) mn(i,1,j)=amin1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp)) end do end do endif do 3 k=1,iord if ((k.eq.1).and.(ibcx.eq.0)) call mp2bc(x,iflg,bcx,n1m,n2m) do 331 j=1,n2m do 331 i=illim2,np 331 f1(i,1,j)=donor(x(i-1,1,j),x(i,1,j),v1(i,1,j)) #if (POLES == 0) if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m f1(1,1,j)=f1(-1,1,j) enddo end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=f1(np+3,1,j) enddo end if else if (leftedge.eq.1) then do j=1,n2m f1(1,1,j)=donor(bcx(j,1),x(1,1,j),v1(1,1,j)) enddo end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=donor(x(np,1,j),bcx(j,2),v1(np+1,1,j)) enddo end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif #endif do 332 j=2,n2m do 332 i=1,np 332 f2(i,1,j)=donor(x(i,1,j-1),x(i,1,j),v2(i,1,j)) if (iprec.eq.1) then do i=1,np f2(i,1, 1)=donor(x(i,1, 1),x(i,1, 1),v2(i,1, 1)) f2(i,1,n2)=donor(x(i,1,n2m),x(i,1,n2m),v2(i,1,n2)) end do else do i=1,np f2(i,1, 1)=-f2(i,1, 2 )*iboz+f2(i,1,n2m)*ibcz f2(i,1,n2)=-f2(i,1,n2m)*iboz+f2(i,1, 2 )*ibcz end do end if do 333 j=1,n2m do 333 i=1,np 333 x(i,1,j)=x(i,1,j)-(f1(i+1,1,j)-f1(i,1,j)+f2(i,1,j+1)- . f2(i,1,j))/h(i,1,j) if(k.eq.iord) go to 6 do 49 j=1,n2m do 49 i=1,iulim1 f1(i,1,j)=v1(i,1,j) 49 v1(i,1,j)=0. do 50 j=1,n2 do 50 i=1,np f2(i,1,j)=v2(i,1,j) 50 v2(i,1,j)=0. if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if call updatelr(f2,np,mp,l+1,np,mp,1) call updatelr(x,np,mp,l,np,mp,iupx) do 51 j=2,n2-2 do 51 i=illim2,np 51 v1(i,1,j)=vdyf(x(i-1,1,j),x(i,1,j),f1(i,1,j), . .5*(h(i-1,1,j)+h(i,1,j))) * +vcorr(f1(i,1,j), f2(i-1,1,j)+f2(i-1,1,j+1)+f2(i,1,j+1)+ . f2(i,1,j), * abs(x(i-1,1,j+1))+abs(x(i,1,j+1))- . abs(x(i-1,1,j-1))-abs(x(i,1,j-1)), . abs(x(i-1,1,j+1))+abs(x(i,1,j+1))+ . abs(x(i-1,1,j-1))+abs(x(i,1,j-1))+ep, * .5*(h(i-1,1,j)+h(i,1,j))) if(ibcz.eq.1) then do i=illim2,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), . .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), f2(i-1,1,1)+f2(i-1,1,2)+f2(i,1,2)+ . f2(i,1,1), * abs(x(i-1,1,2 ))+abs(x(i,1,2 ))- . abs(x(i-1,1,n2mm))-abs(x(i,1,n2mm)), . abs(x(i-1,1,2 ))+abs(x(i,1,2 ))+ . abs(x(i-1,1,n2mm))+abs(x(i,1,n2mm))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=v1(i,1,1) enddo else !ibcz test do i=illim2,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), . .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=vdyf(x(i-1,1,n2m),x(i,1,n2m),f1(i,1,n2m), . .5*(h(i-1,1,n2m)+h(i,1,n2m))) enddo endif if(idiv.eq.1) then do 511 j=2-ibcz,n2-2+ibcz do 511 i=illim2,np 511 v1(i,1,j)=v1(i,1,j) * -vdiv1(f1(i-1,1,j),f1(i,1,j),f1(i+1,1,j),.5*(h(i-1,1,j)+ . h(i,1,j))) * -vdiv2(f1(i,1,j),f2(i-1,1,j+1),f2(i,1,j+1),f2(i-1,1,j), . f2(i,1,j),.5*(h(i-1,1,j)+h(i,1,j))) endif do 52 j=2,n2m do 52 i=illim2,iulim2 52 v2(i,1,j)=vdyf(x(i,1,j-1),x(i,1,j),f2(i,1,j),.5*(h(i,1,j-1)+ . h(i,1,j))) * +vcorr(f2(i,1,j), f1(i,1,j-1)+f1(i,1,j)+f1(i+1,1,j)+ . f1(i+1,1,j-1), * abs(x(i+1,1,j-1))+abs(x(i+1,1,j))- . abs(x(i-1,1,j-1))-abs(x(i-1,1,j)), . abs(x(i+1,1,j-1))+abs(x(i+1,1,j))+ . abs(x(i-1,1,j-1))+abs(x(i-1,1,j))+ep, * .5*(h(i,1,j-1)+h(i,1,j))) #if (POLES == 0) if(ibcx.eq.1) then i0=-1 if (leftedge.eq.1) then do j=2,n2m v2(1,1,j)=vdyf(x(1,1,j-1),x(1,1,j),f2(1,1,j), . .5*(h(1,1,j-1)+h(1,1,j))) * +vcorr(f2(1,1,j), f1(1,1,j-1)+f1(1,1,j)+f1(2,1,j)+f1(2,1,j-1), * abs(x(2,1,j-1))+abs(x(2,1,j))-abs(x(i0,1,j-1))-abs(x(i0,1,j)), * abs(x(2,1,j-1))+abs(x(2,1,j))+abs(x(i0,1,j-1))+abs(x(i0,1,j))+ * ep,.5*(h(1,1,j-1)+h(1,1,j))) #if (PARALLEL == 0) v2(n1m,1,j)=v2(1,1,j) #endif enddo end if #if (PARALLEL > 0) call updatelr(v2,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do j=2,n2m v2(np,1,j)=v2(np+1,1,j) end do endif #endif end if #endif if(idiv.eq.1) then do 521 j=2,n2m do 521 i=illimx,iulimx 521 v2(i,1,j)=v2(i,1,j) * -vdiv1(f2(i,1,j-1),f2(i,1,j),f2(i,1,j+1),.5* . (h(i,1,j-1)+h(i,1,j))) * -vdiv2(f2(i,1,j),f1(i+1,1,j),f1(i+1,1,j-1),f1(i,1,j-1), * f1(i,1,j),.5*(h(i,1,j-1)+h(i,1,j))) endif if(isor.eq.3) then do 61 j=2-ibcz,n2-2+ibcz do 61 i=illim3,iulim2 61 v1(i,1,j)=v1(i,1,j) +vcor31(f1(i,1,j), 1 x(i-2,1,j),x(i-1,1,j),x(i,1,j),x(i+1,1,j), . .5*(h(i-1,1,j)+h(i,1,j))) #if (POLES == 0) if(ibcx.eq.1) then if (leftedge.eq.1) then do j=2-ibcz,n2-2+ibcz v1(2,1,j)=v1(2,1,j) +vcor31(f1(2,1,j), 1 x(-1,1,j),x(1,1,j),x(2,1,j),x(3,1,j), . .5*(h(1,1,j)+h(2,1,j))) enddo end if if (rightedge.eq.1) then do j=2-ibcz,n2-2+ibcz v1(np,1,j)=v1(np,1,j) +vcor31(f1(np,1,j), . x(np-2,1,j),x(np-1,1,j),x(np,1,j),x(np+2,1,j), . .5*(h(np-1,1,j)+h(np,1,j))) enddo end if endif #endif do 62 j=2,n2-2 do 62 i=illimx2,iulimx 62 v1(i,1,j)=v1(i,1,j) 1 +vcor32(f1(i,1,j),f2(i-1,1,j)+f2(i-1,1,j+1)+f2(i,1,j+1)+ . f2(i,1,j), * abs(x(i,1,j+1 ))-abs(x(i,1,j-1 ))- . abs(x(i-1,1,j+1))+abs(x(i-1,1,j-1)), * abs(x(i,1,j+1 ))+abs(x(i,1,j-1 ))+ . abs(x(i-1,1,j+1))+abs(x(i-1,1,j-1))+ep, * .5*(h(i-1,1,j)+h(i,1,j))) if(ibcz.eq.1) then do i=illimx2,iulimx v1(i,1,1)=v1(i,1,1) 1 +vcor32(f1(i,1,1),f2(i-1,1,1)+f2(i-1,1,2)+f2(i,1,2)+ . f2(i,1,1), * abs(x(i,1,2 ))-abs(x(i,1,n2mm ))- . abs(x(i-1,1,2))+abs(x(i-1,1,n2mm)), * abs(x(i,1,2 ))+abs(x(i,1,n2mm ))+ . abs(x(i-1,1,2))+abs(x(i-1,1,n2mm))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=v1(i,1,1) enddo endif do 63 j=3,n2-2 do 63 i=illimx,iulimx !!! 1+(1-ibcx)*leftedge, np+(ibcx-1)*rightedge 63 v2(i,1,j)=v2(i,1,j) +vcor31(f2(i,1,j), 1 x(i,1,j-2),x(i,1,j-1),x(i,1,j),x(i,1,j+1),.5* . (h(i,1,j-1)+h(i,1,j))) if(ibcz.eq.1) then do i=illimx,iulimx v2(i,1,2)=v2(i,1,2) +vcor31(f2(i,1,2), 1 x(i,1,n2mm),x(i,1,1),x(i,1,2),x(i,1,3),.5* . (h(i,1,1)+h(i,1,2))) v2(i,1,n2m)=v2(i,1,n2m) +vcor31(f2(i,1,n2m), 1 x(i,1,n2m-2),x(i,1,n2mm),x(i,1,n2m),x(i,1,2),.5* . (h(i,1,n2mm)+h(i,1,n2m))) enddo endif do 64 j=3-ibcz,n2-2+ibcz do 64 i=illim2,iulim2 !!! 1+1*leftedge, np-1*rightedge 64 v2(i,1,j)=v2(i,1,j) 1 +vcor32(f2(i,1,j),f1(i,1,j-1)+f1(i+1,1,j-1)+f1(i+1,1,j)+ . f1(i,1,j), * abs(x(i+1,1,j ))-abs(x(i-1,1,j ))- . abs(x(i+1,1,j-1))+abs(x(i-1,1,j-1)), * abs(x(i+1,1,j ))+abs(x(i-1,1,j ))+ . abs(x(i+1,1,j-1))+abs(x(i-1,1,j-1))+ep, * .5*(h(i ,1,j-1)+h(i,1,j))) #if (POLES == 0) if(ibcx.eq.1) then if (leftedge.eq.1) then do j=3-ibcz,n2-2+ibcz v2(1,1,j)=v2(1,1,j) 1 +vcor32(f2(1,1,j),f1(1,1,j-1)+f1(2,1,j-1)+ . f1(2,1,j)+f1(1,1,j), * abs(x(2,1,j ))-abs(x(-1,1,j ))- . abs(x(2,1,j-1))+abs(x(-1,1,j-1)), * abs(x(2,1,j ))+abs(x(-1,1,j ))+ . abs(x(2,1,j-1))+abs(x(-1,1,j-1))+ep, * .5*(h(1,1,j-1)+h(1,1,j))) #if (PARALLEL == 0) v2(n1m,1,j)=v2(1,1,j) #endif end do end if #if (PARALLEL > 0) call updatelr(v2,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do j=3-ibcz,n2-2+ibcz v2(np,1,j)=v2(np+1,1,j) end do end if #endif endif !ibcx=1 #endif endif !isor=3 #if (POLES == 0) if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j)=v1(-1,1,j) end do end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j)=v1(np+3,1,j) end do end if end if #endif if (iprec.eq.1) then do i=1,np v2(i,1, 1)=0. v2(i,1,n2)=0. end do else do i=1,np v2(i,1, 1)=-v2(i,1, 2)*iboz+v2(i,1,n2m)*ibcz v2(i,1,n2)=-v2(i,1,n2m)*iboz+v2(i,1, 2)*ibcz end do end if if(nonos.eq.1) then c non-oscillatory option do 401 j=1,n2m #if (POLES == 0) jm=ibcz*(j-1+(n2-j)/n2m*(n2-2))+iboz*max0(j-1,1 ) jp=ibcz*(j+1 -j /n2m*(n2-2))+iboz*min0(j+1,n2m) #else jm=j-1 jp=j+1 #endif do 401 i=1,np #if (POLES == 0) if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if cvec im=ibcx*(i-1+(n1-i)/n1m*(n1-2))+ibox*max0(i-1,1 ) cvec ip=ibcx*(i+1 -i /n1m*(n1-2))+ibox*min0(i+1,n1m) #else im = i - 1 ip = i + 1 #endif mx(i,1,j)=amax1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp), . mx(i,1,j)) 401 mn(i,1,j)=amin1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp), . mn(i,1,j)) do 402 j=1,n2m do 402 i=illim2,np 402 f1(i,1,j)=donor(x(i-1,1,j),x(i,1,j),v1(i,1,j)) #if (POLES == 0) if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m f1(1,1 ,j)=f1(-1,1,j) enddo end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=f1(np+3,1,j) enddo end if else if (leftedge.eq.1) then do j=1,n2m f1(1,1 ,j)=0. enddo end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=0. enddo end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif #endif if (iprec.eq.1) then do 4031 i=1,np do j=2,n2m f2(i,1, j)=donor(x(i,1,j-1),x(i,1,j),v2(i,1,j)) enddo f2(i,1, 1)=0. f2(i,1,n2)=0. 4031 continue else do 4032 i=1,np do j=2,n2m f2(i,1,j)=donor(x(i,1,j-1),x(i,1,j),v2(i,1,j)) enddo f2(i,1, 1)=-f2(i,1, 2)*iboz+f2(i,1,n2m)*ibcz f2(i,1,n2)=-f2(i,1,n2m)*iboz+f2(i,1, 2)*ibcz 4032 continue endif do 404 j=1,n2m do 404 i=1,np cp(i,1,j)=(mx(i,1,j)-x(i,1,j))*h(i,1,j)/ 1(pn(f1(i+1,1,j))+pp(f1(i,1,j))+pn(f2(i,1,j+1))+pp(f2(i,1,j))+ep) cn(i,1,j)=(x(i,1,j)-mn(i,1,j))*h(i,1,j)/ 1(pp(f1(i+1,1,j))+pn(f1(i,1,j))+pp(f2(i,1,j+1))+pn(f2(i,1,j))+ep) 404 continue call updatelr(cp,np,mp,l,np,mp,1) call updatelr(cn,np,mp,l,np,mp,1) do 405 j=1,n2m do 405 i=illim2,np v1(i,1,j)=pp(v1(i,1,j))* 1 ( amin1(1.,cp(i,1,j),cn(i-1,1,j))*pp(sign(1., x(i-1,1,j))) 1 +amin1(1.,cp(i-1,1,j),cn(i,1,j))*pp(sign(1.,-x(i-1,1,j))) ) 2 -pn(v1(i,1,j))* 2 ( amin1(1.,cp(i-1,1,j),cn(i,1,j))*pp(sign(1., x(i,1 ,j ))) 2 +amin1(1.,cp(i,1,j),cn(i-1,1,j))*pp(sign(1.,-x(i,1 ,j ))) ) 405 continue do 406 j=2,n2m do 406 i=1,np v2(i,1,j)=pp(v2(i,1,j))* 1 ( amin1(1.,cp(i,1,j),cn(i,1,j-1))*pp(sign(1., x(i,1,j-1))) 1 +amin1(1.,cp(i,1,j-1),cn(i,1,j))*pp(sign(1.,-x(i,1,j-1))) ) 1 -pn(v2(i,1,j))* 2 ( amin1(1.,cp(i,1,j-1),cn(i,1,j))*pp(sign(1., x(i,1 ,j ))) 2 +amin1(1.,cp(i,1,j),cn(i,1,j-1))*pp(sign(1.,-x(i,1 ,j ))) ) 406 continue #if (POLES == 0) if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m v1(1,1,j)=v1(-1,1,j) enddo end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j)=v1(np+3,1,j) enddo end if else if (leftedge.eq.1) then do j=1,n2m v1(1,1,j)=0. enddo end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j)=0. enddo end if end if #endif if (iprec.eq.1) then do i=1,np v2(i,1, 1)=0. v2(i,1,n2)=0. end do else do i=1,np v2(i,1, 1)=-v2(i,1, 2)*iboz+v2(i,1,n2m)*ibcz v2(i,1,n2)=-v2(i,1,n2m)*iboz+v2(i,1, 2)*ibcz enddo endif endif 3 continue 6 continue call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(31) #endif return end subroutine mpdatm2(u1,u2,x,h,iflg) include 'param.nml' include 'msg.inc' dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(isor=1,nonos=1,idiv=0) parameter(n1=np+1,n2=l+1) parameter(n1m=n1-1,n2m=n2-1,n2mm=n2-2) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+l)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(l,2),scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc data ep/1.e-10/ c pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 rat2(z1,z2)=(z2-z1)*.5 rat4(z0,z1,z2,z3)=(z3+z2-z1-z0)*.25 vdyf(x1,x2,a,r)=(abs(a)-a**2/r)*rat2(x1,x2) cex vdyf(x1,x2,a,r)=(abs(a)-a**2/r+2.*ampd*r)*rat2(x1,x2) vcorr(a,b,y0,y1,y2,y3,r)=-0.125*a*b/r*rat4(y0,y1,y2,y3) vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r vcor31(a,x0,x1,x2,x3,r)= . -(a -3.*abs(a)*a/r+2.*a**3/r**2)/3.*rat4(x1,x2,x0,x3) vcor32(a,b,y0,y1,y2,y3,r)= . 0.25*b/r*(abs(a)-2.*a**2/r)*rat4(y0,y1,y2,y3) c iprec=0 c if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib #if (TIMEPLT == 1) call ttbeg(32) #endif call update(x,np,mp,l,np,mp,iupx) itmx=2-liner iboz=1-ibcz #if (POLES == 0) ibox=1-ibcx ibc=ibcx illim = 1 + leftedge iulim = np #else ibox=0 ibc=1 illim = 1 iulim = np #endif do j=1,n2m do i=illim,iulim v1(i,1,j) = u1(i,1,j) end do end do #if (POLES == 0) if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j) = ubc(1,j,1) end do end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j) = ubc(1,j,2) end do end if #endif do i=1,np do j=2,n2m v2(i,1,j) = u2(i,1,j) end do v2(i,1, 1) = wbc(i,1,1) v2(i,1,n2) = wbc(i,1,2) enddo if(nonos.eq.1) then do j=1,n2m #if (POLES == 0) jm=ibcz*(j-1+(n2-j)/n2m*(n2-2))+iboz*max0(j-1,1 ) jp=ibcz*(j+1 -j /n2m*(n2-2))+iboz*min0(j+1,n2m) #else jm=j-1 jp=j+1 #endif do i=1,np #if (POLES == 0) if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if cvec im=ibc*(i-1+(n1-i)/n1m*(n1-2))+ibo*max0(i-1,1 ) cvec ip=ibc*(i+1 -i /n1m*(n1-2))+ibo*min0(i+1,n1m) #else im = i - 1 ip = i + 1 #endif mx(i,1,j)=amax1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp)) mn(i,1,j)=amin1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp)) end do end do endif c1=1. c2=0. do 3 k=1,itmx #if (POLES == 0) if((k.eq.1).and.(ibcx.eq.0)) call mp2bc(x,iflg,bcx,n1m,n2m) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do 331 j=1,n2m do 331 i=illim,iulim 331 f1(i,1,j)=donor(c1*x(i-1,1,j)+c2,c1*x(i,1,j)+c2,v1(i,1,j)) cex . -c1*ampd*.5*(h(i,1,j)+h(i-1,1,j))*(x(i,1,j)-x(i-1,1,j)) #if (POLES == 0) if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m f1(1,1,j)=f1(-1,1,j) end do end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=f1(np+3,1,j) enddo end if else if (leftedge.eq.1) then do j=1,n2m f1(1,1,j)=donor(c1*bcx(j,1)+c2,c1*x(1,1,j)+c2,v1(1,1,j)) end do end if if (rightedge.eq.1) then do j=1,n2m f1(np+1,1,j)=donor(c1*x(np,1,j)+c2,c1*bcx(j,2)+c2, . v1(np+1,1,j)) enddo end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif #endif do 332 j=2,n2m do 332 i=1,np 332 f2(i,1,j)=donor(c1*x(i,1,j-1)+c2,c1*x(i,1,j)+c2,v2(i,1,j)) cex . -c1*ampd*.5*(h(i,1,j)+h(i,1,j-1))*(x(i,1,j)-x(i,1,j-1)) if (iprec.eq.1) then do i=1,np f2(i,1, 1)=donor(c1*x(i,1, 1)+c2,c1*x(i,1, 1)+c2,v2(i,1, 1)) f2(i,1,n2)=donor(c1*x(i,1,n2m)+c2,c1*x(i,1,n2m)+c2,v2(i,1,n2)) end do else do i=1,np f2(i,1, 1)=-f2(i,1, 2 )*iboz+f2(i,1,n2m)*ibcz f2(i,1,n2)=-f2(i,1,n2m)*iboz+f2(i,1, 2 )*ibcz end do end if do 333 j=1,n2m do 333 i=1,np 333 x(i,1,j)=x(i,1,j)-(f1(i+1,1,j)-f1(i,1,j)+f2(i,1,j+1)-f2(i,1,j))/ . h(i,1,j) if(k.eq.itmx) go to 6 c1=0. c2=1. #if (POLES == 0) illim = 1 iulim = np + 1*rightedge #else illim = 1 iulim = np #endif do 49 j=1,n2m do 49 i=illim,iulim f1(i,1,j)=v1(i,1,j) 49 v1(i,1,j)=0. do 50 j=1,n2 do 50 i=1,np f2(i,1,j)=v2(i,1,j) 50 v2(i,1,j)=0. if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if call updatelr(f2,np,mp,l+1,np,mp,1) call updatelr(x,np,mp,l,np,mp,iupx) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do 51 j=2,n2-2 do 51 i=illim,iulim 51 v1(i,1,j)=vdyf(x(i-1,1,j),x(i,1,j),f1(i,1,j),.5* . (h(i-1,1,j)+h(i,1,j))) * +vcorr(f1(i,1,j),f2(i-1,1,j)+f2(i-1,1,j+1)+f2(i,1,j+1)+f2(i,1,j), * x(i-1,1,j-1),x(i,1,j-1),x(i-1,1,j+1),x(i,1,j+1), * .5*(h(i-1,1,j)+h(i,1,j))) if(ibcz.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1),.5* . (h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1),f2(i-1,1,1)+f2(i-1,1,2)+f2(i,1,2)+f2(i,1,1), . x(i-1,1,n2mm),x(i,1,n2mm),x(i-1,1,2),x(i,1,2), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=v1(i,1,1) enddo else !ibcz test do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1),.5* . (h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=vdyf(x(i-1,1,n2m),x(i,1,n2m),f1(i,1,n2m),.5* . (h(i-1,1,n2m)+h(i,1,n2m))) enddo endif if(idiv.eq.1) then #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do 511 j=2-ibcz,n2-2+ibcz do 511 i=illim,iulim v1d=-vdiv1(f1(i-1,1,j),f1(i,1,j),f1(i+1,1,j),.5* . (h(i-1,1,j)+h(i,1,j))) * -vdiv2(f1(i,1,j),f2(i-1,1,j+1),f2(i,1,j+1),f2(i-1,1,j), * f2(i,1,j), .5*(h(i-1,1,j)+h(i,1,j))) 511 v1(i,1,j)=v1(i,1,j)+(pp(v1d)*x(i-1,1,j)-pn(v1d)*x(i,1,j)) endif #if (POLES == 0) illim = 1 + leftedge iulim = np - 1*rightedge #else illim = 1 iulim = np #endif do 52 j=2,n2m do 52 i=illim,iulim 52 v2(i,1,j)=vdyf(x(i,1,j-1),x(i,1,j),f2(i,1,j),.5* . (h(i,1,j-1)+h(i,1,j))) * +vcorr(f2(i,1,j), f1(i,1,j-1)+f1(i,1,j)+f1(i+1,1,j)+ . f1(i+1,1,j-1), * x(i-1,1,j-1),x(i-1,1,j),x(i+1,1,j-1),x(i+1,1,j), * .5*(h(i,1,j-1)+h(i,1,j))) #if (POLES == 0) if(ibcx.eq.1) then if (leftedge.eq.1) then do j=2,n2m v2(1,1,j)=vdyf(x(1,1,j-1),x(1,1,j),f2(1,1,j),.5* . (h(1,1,j-1)+h(1,1,j))) * +vcorr(f2(1,1,j), f1(1,1,j-1)+f1(1,1,j)+f1(2,1,j)+ . f1(2,1,j-1),x(-1,1,j-1),x(-1,1,j), . x(2,1,j-1),x(2,1,j), * .5*(h(1,1,j-1)+h(1,1,j))) #if (PARALLEL == 0) v2(n1m,1,j)=v2(1,1,j) #endif end do end if #if (PARALLEL > 0) call updatelr(v2,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do j=2,n2m v2(np,1,j)=v2(np+1,1,j) enddo end if #endif endif #endif if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge #else illim = 1 iulim = np #endif do 521 j=2,n2m do 521 i=illim,iulim v2d=-vdiv1(f2(i,1,j-1),f2(i,1,j),f2(i,1,j+1), . .5*(h(i,1,j-1)+h(i,1,j))) * -vdiv2(f2(i,1,j),f1(i+1,1,j-1),f1(i+1,1,j),f1(i,1,j-1), . f1(i,1,j),.5*(h(i,1,j-1)+h(i,1,j))) 521 v2(i,1,j)=v2(i,1,j)+(pp(v2d)*x(i,1,j-1)-pn(v2d)*x(i,1,j)) endif if(isor.eq.3) then #if (POLES == 0) illim = 1 + 2*leftedge iulim = np - 1*rightedge #else illim = 1 iulim = np #endif do 61 j=2-ibcz,n2-2+ibcz do 61 i=illim,iulim 61 v1(i,1,j)=v1(i,1,j) +vcor31(f1(i,1,j), 1 x(i-2,1,j),x(i-1,1,j),x(i,1,j),x(i+1,1,j), . .5*(h(i-1,1,j)+h(i,1,j))) c #if (POLES == 0) if(ibcx.eq.1) then if (leftedge.eq.1) then do j=2-ibcz,n2-2+ibcz v1(2,1,j)=v1(2,1,j) +vcor31(f1(2,1,j), 1 x(-1,1,j),x(1,1,j),x(2,1,j),x(3,1,j), . .5*(h(1,1,j)+h(2,1,j))) end do end if if (rightedge.eq.1) then do j=2-ibcz,n2-2+ibcz v1(np,1,j)=v1(np,1,j) +vcor31(f1(np,1,j),x(np-2,1,j), . x(np-1,1,j), 1 x(np,1,j),x(np+2,1,j),.5*(h(np-1,1,j)+h(np,1,j))) enddo end if endif #endif #if (POLES == 0) illim = 1 + (2-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge #else illim = 1 iulim = np #endif do 62 j=2,n2-2 do 62 i=illim,iulim 62 v1(i,1,j)=v1(i,1,j) 1 +vcor32(f1(i,1,j),f2(i-1,1,j)+f2(i-1,1,j+1)+f2(i,1,j+1)+ * f2(i,1,j), * x(i,1,j-1),x(i-1,1,j+1),x(i-1,1,j-1),x(i,1,j+1), * .5*(h(i-1,1,j)+h(i,1,j))) if(ibcz.eq.1) then do i=illim,iulim v1(i,1,1)=v1(i,1,1) 1 +vcor32(f1(i,1,1),f2(i-1,1,1)+f2(i-1,1,2)+f2(i,1,2)+ * f2(i,1,1), * x(i,1,n2mm),x(i-1,1,2),x(i-1,1,n2mm),x(i,1,2), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n2m)=v1(i,1,1) enddo endif #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge #else illim = 1 iulim = np #endif do 63 j=3,n2-2 do 63 i=illim,iulim 63 v2(i,1,j)=v2(i,1,j) +vcor31(f2(i,1,j), 1 x(i,1,j-2),x(i,1,j-1),x(i,1,j),x(i,1,j+1), . .5*(h(i,1,j-1)+h(i,1,j))) if(ibcz.eq.1) then do i=illim,iulim v2(i,1,2)=v2(i,1,2) +vcor31(f2(i,1,2), 1 x(i,1,n2mm),x(i,1,1),x(i,1,2),x(i,1,3),.5* . (h(i,1,1)+h(i,1,2))) v2(i,1,n2m)=v2(i,1,n2m) +vcor31(f2(i,1,n2m), 1 x(i,1,n2m-2),x(i,1,n2mm),x(i,1,n2m),x(i,1,2),.5* . (h(i,1,n2mm)+h(i,1,n2m))) enddo endif #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge #else illim = 1 iulim = np #endif do 64 j=3-ibcz,n2-2+ibcz do 64 i=illim,iulim 64 v2(i,1,j)=v2(i,1,j) 1 +vcor32(f2(i,1,j),f1(i,1,j-1)+f1(i+1,1,j-1)+f1(i+1,1,j)+ . f1(i,1,j), * x(i+1,1,j-1),x(i-1,1,j),x(i-1,1,j-1),x(i+1,1,j), * .5*(h(i,1,j-1)+h(i,1,j))) #if (POLES == 0) if(ibcx.eq.1) then if (leftedge.eq.1) then do j=3-ibcz,n2-2+ibcz v2(1,1,j)=v2(1,1,j) 1 +vcor32(f2(1,1,j),f1(1,1,j-1)+f1(2,1,j-1)+ . f1(2,1,j)+f1(1,1,j), * x(2,1,j-1),x(-1,1,j),x(-1,1,j-1),x(2,1,j), * .5*(h(1,1,j-1)+h(1,1,j))) #if (PARALLEL == 0) v2(n1m,1,j)=v2(1,1,j) #endif end do end if #if (PARALLEL > 0) call updatelr(v2,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do j=3-ibcz,n2-2+ibcz v2(np,1,j)=v2(np+1,1,j) end do end if #endif endif #endif endif #if (POLES == 0) if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j)=v1(-1,1,j) end do end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j)=v1(np+3,1,j) end do end if end if #endif if (iprec.eq.1) then do i=1,np v2(i,1, 1)=0. v2(i,1,n2)=0. end do else do i=1,np v2(i,1, 1)=-v2(i,1, 2)*iboz+v2(i,1,n2m)*ibcz v2(i,1,n2)=-v2(i,1,n2m)*iboz+v2(i,1, 2)*ibcz enddo endif if(nonos.eq.1) then c non-osscilatory option do 401 j=1,n2m #if (POLES == 0) jm=ibcz*(j-1+(n2-j)/n2m*(n2-2))+iboz*max0(j-1,1 ) jp=ibcz*(j+1 -j /n2m*(n2-2))+iboz*min0(j+1,n2m) #else jm=j-1 jp=j+1 #endif do 401 i=1,np #if (POLES == 0) if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if cvec im=ibcx*(i-1+(n1-i)/n1m*(n1-2))+ibox*max0(i-1,1 ) cvec ip=ibcx*(i+1 -i /n1m*(n1-2))+ibox*min0(i+1,n1m) #else im = i - 1 ip = i + 1 #endif mx(i,1,j)=amax1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp), . mx(i,1,j)) 401 mn(i,1,j)=amin1(x(im,1,j),x(i,1,j),x(ip,1,j),x(i,1,jm),x(i,1,jp), . mn(i,1,j)) #if (POLES == 0) iulim = np + 1*rightedge #else iulim = np #endif do 402 j=1,n2m do 402 i=1,iulim 402 f1(i,1,j)=donor(c2,c2,v1(i,1,j)) if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if do 403 j=1,n2 do 403 i=1,np 403 f2(i,1,j)=donor(c2,c2,v2(i,1,j)) do 404 j=1,n2m do 404 i=1,np cp(i,1,j)=(mx(i,1,j)-x(i,1,j))*h(i,1,j)/ 1(pn(f1(i+1,1,j))+pp(f1(i,1,j))+pn(f2(i,1,j+1))+pp(f2(i,1,j))+ep) cn(i,1,j)=(x(i,1,j)-mn(i,1,j))*h(i,1,j)/ 1(pp(f1(i+1,1,j))+pn(f1(i,1,j))+pp(f2(i,1,j+1))+pn(f2(i,1,j))+ep) 404 continue call updatelr(cp,np,mp,l,np,mp,1) call updatelr(cn,np,mp,l,np,mp,1) #if (POLES == 0) illim = 1 + leftedge #else illim = 1 #endif do j=1,n2m do i=illim,np v1(i,1,j)=pp(v1(i,1,j))*amin1(1.,cp(i,1,j ),cn(i-1,1,j)) * -pn(v1(i,1,j))*amin1(1.,cp(i-1,1,j),cn(i ,1,j)) end do end do do j=2,n2m do i=1,np v2(i,1,j)=pp(v2(i,1,j))*amin1(1.,cp(i,1,j ),cn(i,1,j-1)) * -pn(v2(i,1,j))*amin1(1.,cp(i,1,j-1),cn(i,1,j )) end do end do #if (POLES == 0) if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j)=v1(-1,1,j) end do end if if (rightedge.eq.1) then do j=1,n2m v1(np+1,1,j)=v1(np+3,1,j) end do end if end if #endif if (iprec.eq.1) then do i=1,np v2(i,1, 1)=0. v2(i,1,n2)=0. end do else do i=1,np v2(i,1, 1)=-v2(i,1, 2)*iboz+v2(i,1,n2m)*ibcz v2(i,1,n2)=-v2(i,1,n2m)*iboz+v2(i,1, 2)*ibcz enddo endif endif 3 continue 6 continue call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(32) #endif return end subroutine mp2bc(x,iflg,bcx,n1,n2) include 'param.nml' include 'msg.inc' dimension x(1-ih:np+ih,1-ih:mp+ih,l),bcx(n2,2) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . prf(1-ih:np+ih,1-ih:mp+ih,l,3), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (TIMEPLT == 1) call ttbeg(33) #endif #if (POLES == 0) if(iflg.eq.1) then if(implgw.eq.1) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=0. end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=0. enddo end if else if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=prf( 1,1,k,1) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=prf(np,1,k,1) enddo end if endif goto 999 endif if(iflg.eq.11) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=prf( 1,1,k,1) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=prf(np,1,k,1) enddo end if goto 999 endif if(iflg.eq.2.or.iflg.eq.3) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=prf( 1,1,k,iflg) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=prf(np,1,k,iflg) enddo end if goto 999 endif if(iflg.eq.51) then if (leftedge.eq.1) then do k=1,n2 g110w=1./((1-icylind)*gmm(1,1,k)*cosa(1,1)+icylind*1.) g220w=1./gmm(1,1,k) g11w=strxx(1,1)*g110w g21w=strxy(1,1)*g220w bcx(k,1)=g11w*prf(1,1,k,2)+g21w*prf(1,1,k,3)+strxd(1,1) end do end if if (rightedge.eq.1) then do k=1,n2 g110e=1./((1-icylind)*gmm(np,1,k)*cosa(np,1)+icylind*1.) g220e=1./gmm(np,1,k) g11e=strxx(np,1)*g110e g21e=strxy(np,1)*g220e bcx(k,2)=g11e*prf(np,1,k,2)+g21e*prf(np,1,k,3)+strxd(np,1) enddo end if goto 999 endif if(iflg.eq.52) then if (leftedge.eq.1) then do k=1,n2 g110w=1./((1-icylind)*gmm(1,1,k)*cosa(1,1)+icylind*1.) g220w=1./gmm(1,1,k) g12w=stryx(1,1)*g110w g22w=stryy(1,1)*g220w bcx(k,1)=g12w*prf(1,1,k,2)+g22w*prf(1,1,k,3)+stryd(1,1) end do end if if (rightedge.eq.1) then do k=1,n2 g110e=1./((1-icylind)*gmm(np,1,k)*cosa(np,1)+icylind*1.) g220e=1./gmm(np,1,k) g12e=stryx(np,1)*g110e g22e=stryy(np,1)*g220e bcx(k,2)=g12e*prf(np,1,k,2)+g22e*prf(np,1,k,3)+stryd(np,1) enddo end if goto 999 endif if(iflg.eq.4.or.iflg.eq.53.or.iflg.eq.12) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=0. end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=0. enddo end if goto 999 endif if(mhd.eq.1) then if(iflg.ge.31.and.iflg.le.33) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=prfb( 1,1,k,iflg-30) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=prfb(np,1,k,iflg-30) enddo end if return endif endif #if (MOISTMOD > 0) if(iflg.eq.6) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=qve( 1,1,k) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=qve(np,1,k) enddo end if goto 999 endif #endif if(iflg.ge.7) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=0. end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=0. enddo end if goto 999 endif #endif 999 continue #if (TIMEPLT == 1) call ttend(33) #endif return end #else subroutine mpdata3(u1,u2,u3,x,h,iflg) include 'param.nml' include 'msg.inc' parameter(iord0=2,isor0=1,nonos=1,idiv=0) c parameter(iord0=2,isor=3,nonos=1,idiv=0) parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . u3(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+1+2*ih)*l) parameter(iv3f3=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ibcxa=(mp+2*ih)*l,ibcya=(np+2*ih)*l) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+iv3f3+ibcxa+ibcya)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+1+ih, l), . v3(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+1+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(1-ih:mp+ih, l, 2), . bcy(1-ih:np+ih, l, 2), . scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/diffus/ sk(l),skr(l),sls common/ctherm/ rg,cpp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/refstprof/ trs(l),thrs(l),prs(l),rhors(l) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) data ep/1.e-10/ c pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 vdyf(x1,x2,a,r)=(abs(a)-a**2/r)*(abs(x2)-abs(x1)) 1 /(abs(x2)+abs(x1)+ep) vcorr(a,b,y1,y2,r)=-0.125*a*b*y1/(y2*r) vcor31(a,x0,x1,x2,x3,r)= -(a -3.*abs(a)*a/r+2.*a**3/r**2)/3. 1 *(abs(x0)+abs(x3)-abs(x1)-abs(x2)) 2 /(abs(x0)+abs(x3)+abs(x1)+abs(x2)+ep) vcor32(a,b,y1,y2,r)=0.25*b/r*(abs(a)-2.*a**2/r)*y1/y2 vcor33(a,b,c,y1,y2,r)=-a*b*c/(24.*r**2)*y1/y2 c vcor33(a,b,c,y1,y2,r)=-a*b*c/(24.**r**2)*y1/y2 vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r c #if (TIMEPLT == 1) call ttbeg(34) #endif if(iflg.ge.2.and.iflg.le.4) then isor=3 c isor=isor0 else isor=isor0 endif ! do j=1,mp ! do i=1,np ! if(iflg.eq.31.or.iflg.eq.32) then !mod bbc ! x(i,j, 1) = 0 ! x(i,j,l) = 0. ! endif ! if(iflg.eq.33) then ! x(i,j,1) = x(i,j,2) ! x(i,j,l) = x(i,j,l-1) ! endif ! end do ! end do call update(x,np,mp,l,np,mp,iup) iord=iord0 if(isor.eq.3) iord=max0(iord,3) !mod mhd c if(isor.eq.3.and.iflg.lt.31) iord=max0(iord,3) c iord=3 if(liner.eq.1) iord=1 #if (POLES == 0) ibox=1-ibcx iboy=1-ibcy #else ibox=0 iboy=0 #endif iboz=1-ibcz iprec=0 c if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib pbc=1. c if(iflg.eq.2.or.iflg.eq.3) pbc=pflip if(iflg.eq.2.or.iflg.eq.3.or.iflg.eq.31.or.iflg.eq.32) pbc=pflip do k=2,n3m do j=1,mp do i=1,np v3(i,j,k) = u3(i,j,k) enddo end do end do do j=1,mp do i=1,np v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,n3m do j=1,mp do i=illim,iulim v1(i,j,k) = u1(i,j,k) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1( 1,j,k) = ubc(j,k,1) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k) = ubc(j,k,2) end do end do end if C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + j3*botedge julim = mp do k=1,n3m do j=jllim,mp do i=1,np v2(i,j,k) = u2(i,j,k) end do end do end do if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k) = vbc(i,k,1) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k) = vbc(i,k,2) end do end do end if if (nonos.eq.1) then C----------------/ #if (POLES == 0) C----------------/ do k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - 1 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + 1 end if do i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do C----------------/ #else /* POLES */ C----------------/ jllim2 = 1 + j3*botedge julim2 = mp - j3*topedge do k=1,n3m km=max0(k-1,1) kp=min0(k+1,l) do j=jllim2,julim2 jm = j - 1 jp = j + 1 do i=1,np im = i - 1 ip = i + 1 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ endif do 30 itr=1,iord #if (POLES == 0) if((itr.eq.1).and.((ibcx*ibcy).eq.0)) . call mp3bc(x,iflg,bcx,bcy,np,mp,n3m) #endif COLD call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do 331 k=1,n3m do 331 j=1,mp do 331 i=illim,iulim 331 f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) c if(itr.eq.1.and.kampd(1).ne.0) then c if(itr.eq.iord) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=1,n3m do j=1,mp do i=illim,iulim c ampdx=ampd(1,j,1)*.5*(h(i,j,k)+h(i-1,j,k)) ampdx=sk(k)*.5*(h(i,j,k)+h(i-1,j,k))*dt*dxi**2 if (iflg.eq.1) then f1(i,j,k)=f1(i,j,k)-ampdx*(x(i,j,k)-x(i-1,j,k)) & -skr(k)*.5*(h(i,j,k)+h(i-1,j,k))*(x(i,j,k)-x(i-1,j,k)) & *dt*dxi**2*trs(k)/thrs(k) else f1(i,j,k)=f1(i,j,k)-ampdx*(x(i,j,k)-x(i-1,j,k)) endif enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=f1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)= f1(np+3,j,k) end do end do end if else if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=donor(bcx(j,k,1),x(1,j,k),v1(1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=donor(x(np,j,k),bcx(j,k,2),v1(np+1,j,k)) end do end do end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + botedge julim = mp do 332 k=1,n3m do 332 j=jllim,mp do 332 i=1,np 332 f2(i,j,k)=donor(x(i,j-1,k),x(i,j,k),v2(i,j,k)) c if(itr.eq.1.and.kampd(2).ne.0) then c if(itr.eq.iord) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=1,n3m do j=jllim,mp do i=1,np c ampdy=.5*(ampd(1,j,2)+ampd(1,j-1,2)) c & *.5*(h(i,j,k)+h(i,j-1,k)) ampdy=sk(k)*.5*(h(i,j,k)+h(i,j-1,k))*dt*dyi**2 if (iflg.eq.1) then f2(i,j,k)=f2(i,j,k)-ampdy*(x(i,j,k)-x(i,j-1,k)) & -skr(k)*.5*(h(i,j,k)+h(i,j-1,k))*(x(i,j,k)-x(i,j-1,k)) & *dt*dyi**2*trs(k)/thrs(k) else f2(i,j,k)=f2(i,j,k)-ampdy*(x(i,j,k)-x(i,j-1,k)) endif enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1 ,k)=f2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k) enddo enddo end if else if (botedge.eq.1) then do k=1,n3m do i=1,np if (iflg.eq.1) then f2(i,1,k)=donor(bcy(i,k,1),x(i,1,k),v2(i,1,k)) c f2(i,1,k)=-f2(i,2,k) else f2(i,1,k)=-f2(i,2,k) endif end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np if (iflg.eq.1) then f2(i,mp+1,k)=donor(x(i,mp,k),bcy(i,k,2),v2(i,mp+1,k)) c f2(i,mp+1,k)=-f2(i,mp,k) else f2(i,mp+1,k)=-f2(i,mp,k) endif enddo enddo end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if endif C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np f2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np f2(i,mp+1,k)= 0. enddo enddo endif if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 333 k=2,n3m do 333 j=1,mp do 333 i=1,np 333 f3(i,j,k)=donor(x(i,j,k-1),x(i,j,k),v3(i,j,k)) c if(itr.eq.1.and.kampd(3).ne.0) then c if(itr.eq.iord) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=2,n3m do j=1,mp do i=1,np c ampdz=ampd(1,j,3)*.5*(h(i,j,k)+h(i,j,k-1)) if (iflg.eq.1) then ampdz=sk(k)*.5*(h(i,j,k)+h(i,j,k-1))*dt*dzi**2 & *(trs(k)+trs(k-1))/(thrs(k)+thrs(k-1)) f3(i,j,k)=f3(i,j,k)-ampdz*(x(i,j,k)-x(i,j,k-1)) & -skr(k)*.5*(h(i,j,k)+h(i,j,k-1))*dt*dzi**2 & *(x(i,j,k)*trs(k)/thrs(k)-x(i,j,k-1)*trs(k-1)/thrs(k-1)) else ampdz=sk(k)*.5*(h(i,j,k)+h(i,j,k-1))*dt*dzi**2 f3(i,j,k)=f3(i,j,k)-ampdz*(x(i,j,k)-x(i,j,k-1)) endif enddo enddo enddo endif if (iprec.eq.1) then do j=1,mp do i=1,np f3(i,j, 1)=donor(x(i,j, 1),x(i,j, 1),v3(i,j, 1)) f3(i,j,n3)=donor(x(i,j,n3m),x(i,j,n3m),v3(i,j,n3)) end do end do else do j=1,mp do i=1,np cdf f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz cdf f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2)*ibcz if (iflg.eq.0) then c if (itr.eq.iord.and.iflg.eq.1) then c if (itr.eq.0.and.iflg.eq.1) then !solar flux in dissip c-------- special for solar luminosity dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi hfbt=hf00 gactp=1./(gi(i,j)*gmus(n3m)) + *((1-icylind)*gmm(i,j,n3m)**2*cosa(i,j) + +icylind*gmm(i,j,n3m))*dnmi * dt*dzi hftp=hf00*(gacbt/gactp) C + *23. f3(i,j, 1)=2.*hfbt*gacbt-f3(i,j, 2) f3(i,j,n3)=2.*hftp*gactp-f3(i,j,n3m) c f3(i,j,n3)= f3(i,j,n3m) else c if (iflg.ge.31.and.iflg.le.33) then !mod bbc c f3(i,j, 1)= f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz c f3(i,j,n3)= f3(i,j,n3m)*iboz+f3(i,j, 2)*ibcz c else f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2)*ibcz c endif endif enddo enddo end if c if (iflg.eq.1) then do 334 k=1,n3m do 334 j=1,mp do 334 i=1,np 334 x(i,j,k)=x(i,j,k)-( f1(i+1,j,k)-f1(i,j,k) . +f2(i,j+1,k)-f2(i,j,k) . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k) c . +(f3(i,j,k+1)-f3(i,j,k))*thrs(k)/trs(k) c . )/h(i,j,k) c else c do 339 k=1,n3m c do 339 j=1,mp c do 339 i=1,np c 339 x(i,j,k)=x(i,j,k)-( f1(i+1,j,k)-f1(i,j,k) c . +f2(i,j+1,k)-f2(i,j,k) c . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k) c endif c !mod bbc ! if(iflg.eq.33) then ! do j=1,mp ! do i=1,np ! x(i,j,1) = x(i,j,2) ! x(i,j,l) = x(i,j,l-1) ! enddo ! enddo ! endif if(itr.eq.iord) go to 6 #if (POLES == 0) iulim = np + rightedge #else iulim = np #endif do 48 k=1,n3m do 48 j=1,mp do 48 i=1,iulim f1(i,j,k)=v1(i,j,k) 48 v1(i,j,k)=0. julim = mp + topedge do 49 k=1,n3m do 49 j=1,julim do 49 i=1,np f2(i,j,k)=v2(i,j,k) 49 v2(i,j,k)=0. do 50 k=1,n3 do 50 j=1,mp do 50 i=1,np f3(i,j,k)=v3(i,j,k) 50 v3(i,j,k)=0. c---------------------------------------------- compute antidiffusive velocities in x direction c---------------------------------------------- call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) if (rightedge.eq.0) then call update(f1,np,mp,l,np+1,mp,1) else call update(f1,np+1,mp,l,np+1,mp,1) end if #else call update(f1,np,mp,l,np+1,mp,1) #endif if (topedge.eq.0) then call update(f2,np,mp,l,np,mp+1,1) else call update(f2,np,mp+1,l,np,mp+1,1) end if call update(f3,np,mp,l+1,np,mp,1) #if (POLES == 0) jllim = 1 + botedge julim = mp - topedge illim = 1 + leftedge #else jllim = 1 julim = mp illim = 1 #endif do 51 k=2,n3-2 do 51 j=jllim,julim do 51 i=illim,np 51 v1(i,j,k)=vdyf(x(i-1,j,k),x(i,j,k),f1(i,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i-1,j+1,k))+abs(x(i,j+1,k)) * -abs(x(i-1,j-1,k))-abs(x(i,j-1,k)), * abs(x(i-1,j+1,k))+abs(x(i,j+1,k)) * +abs(x(i-1,j-1,k))+abs(x(i,j-1,k))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i-1,j,k+1))+abs(x(i,j,k+1)) * -abs(x(i-1,j,k-1))-abs(x(i,j,k-1)), * abs(x(i-1,j,k+1))+abs(x(i,j,k+1)) * +abs(x(i-1,j,k-1))+abs(x(i,j,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,np v1(i,1,k)=vdyf(x(i-1,1,k),x(i,1,k),f1(i,1,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * abs(x(i-1, 2,k))+abs(x(i, 2,k)) * -abs(x(i-1,-1,k))-abs(x(i,-1,k)), * abs(x(i-1, 2,k))+abs(x(i, 2,k)) * +abs(x(i-1,-1,k))+abs(x(i,-1,k))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i-1,1,k+1))+abs(x(i,1,k+1)) * -abs(x(i-1,1,k-1))-abs(x(i,1,k-1)), * abs(x(i-1,1,k+1))+abs(x(i,1,k+1)) * +abs(x(i-1,1,k-1))+abs(x(i,1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,np v1(i,mp,k)=v1(i,mp+1,k) end do end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,np v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * -abs(x(i-1,j-1,1))-abs(x(i,j-1,1)), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * +abs(x(i-1,j-1,1))+abs(x(i,j-1,1))+ep, * .5*(h(i-1,j ,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i-1,j, 2 ))+abs(x(i,j, 2 )) * -abs(x(i-1,j,n3-2))-abs(x(i,j,n3-2)), * abs(x(i-1,j, 2 ))+abs(x(i,j, 2 )) * +abs(x(i-1,j,n3-2))+abs(x(i,j,n3-2))+ep, * .5*(h(i-1,j, 1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * -abs(x(i-1,-1,1))-abs(x(i,-1,1)), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * +abs(x(i-1,-1,1))+abs(x(i,-1,1))+ep, * .5*(h(i-1, 1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i-1,1, 2 ))+abs(x(i,1, 2 )) * -abs(x(i-1,1,n3-2))-abs(x(i,1,n3-2)), * abs(x(i-1,1, 2 ))+abs(x(i,1, 2 )) * +abs(x(i-1,1,n3-2))+abs(x(i,1,n3-2))+ep, * .5*(h(i-1,1, 1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,np v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,np v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * -abs(x(i-1,j-1,1))-abs(x(i,j-1,1)), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * +abs(x(i-1,j-1,1))+abs(x(i,j-1,1))+ep, * .5*(h(i-1,j ,1)+h(i,j,1))) v1(i,j,n3m)=vdyf(x(i-1,j,n3m),x(i,j,n3m),f1(i,j,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m))) * +vcorr(f1(i,j,n3m), * f2(i-1,j,n3m)+f2(i-1,j+1,n3m)+f2(i,j+1,n3m)+f2(i,j,n3m), * abs(x(i-1,j+1,n3m))+abs(x(i,j+1,n3m)) * -abs(x(i-1,j-1,n3m))-abs(x(i,j-1,n3m)), * abs(x(i-1,j+1,n3m))+abs(x(i,j+1,n3m)) * +abs(x(i-1,j-1,n3m))+abs(x(i,j-1,n3m))+ep, * .5*(h(i-1,j,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * -abs(x(i-1,-1,1))-abs(x(i,-1,1)), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * +abs(x(i-1,-1,1))+abs(x(i,-1,1))+ep, * .5*(h(i-1, 1,1)+h(i,1,1))) v1(i,1,n3m)=vdyf(x(i-1,1,n3m),x(i,1,n3m),f1(i,1,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) * +vcorr(f1(i,1,n3m), * f2(i-1,1,n3m)+f2(i-1,2,n3m)+f2(i,2,n3m)+f2(i,1,n3m), * abs(x(i-1, 2,n3m))+abs(x(i, 2,n3m)) * -abs(x(i-1,-1,n3m))-abs(x(i,-1,n3m)), * abs(x(i-1, 2,n3m))+abs(x(i, 2,n3m)) * +abs(x(i-1,-1,n3m))+abs(x(i,-1,n3m))+ep, * .5*(h(i-1,1,n3m)+h(i,1,n3m))) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i,1, 1 ) v1(i,n2m,n3m)=v1(i,1,n3m) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,np v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp+1,n3m) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) jllim = 1 + (1-ibcy)*botedge julim = mp + (-1+ibcy)*topedge illim = 1 + leftedge #else illim = 1 jllim = 1 julim = mp #endif do 511 k=2-ibcz,n3-2+ibcz do 511 j=jllim,julim do 511 i=illim,np 511 v1(i,j,k)=v1(i,j,k) * -vdiv1(f1(i-1,j,k),f1(i,j,k),f1(i+1,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f2(i-1,j+1,k),f2(i,j+1,k),f2(i-1,j,k), * f2(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f3(i-1,j,k+1),f3(i,j,k+1),f3(i-1,j,k), * f3(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) endif if(isor.eq.3) then !mod mhd c if(isor.eq.3.and.iflg.lt.31) then #if (POLES == 0) illim = 1 + 2*leftedge iulim = np - 1*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 61 k=2-ibcz,n3-2+ibcz do 61 j=jllim,julim do 61 i=illim,iulim 61 v1(i,j,k)=v1(i,j,k) +vcor31(f1(i,j,k), 1 x(i-2,j,k),x(i-1,j,k),x(i,j,k),x(i+1,j,k), 1 .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if(leftedge.eq.1) then do k=2-ibcz,n3-2+ibcz do j=jllim,julim v1(2,j,k)=v1(2,j,k) +vcor31(f1(2,j,k), 1 x(-1,j,k),x(1,j,k),x(2,j,k),x(3,j,k), 1 .5*(h(1,j,k)+h(2,j,k))) end do end do end if if(rightedge.eq.1) then do k=2-ibcz,n3-2+ibcz do j=jllim,julim v1(np,j,k)=v1(np,j,k) +vcor31(f1(np,j,k), 1 x(np-2,j,k),x(np-1,j,k),x(np,j,k),x(np+2,j,k), 1 .5*(h(np-1,j,k)+h(np,j,k))) end do end do end if endif C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) illim = 1 + (2-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 62 k=2,n3-2 do 62 j=jllim,julim do 62 i=illim,iulim 62 v1(i,j,k)=v1(i,j,k) 1 +vcor32(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k))-abs(x(i,j-1,k))-abs(x(i-1,j+1,k)) * +abs(x(i-1,j-1,k)), abs(x(i,j+1,k))+abs(x(i,j-1,k)) * +abs(x(i-1,j+1,k))+abs(x(i-1,j-1,k))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) 1 +vcor32(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i,j,k+1))-abs(x(i,j,k-1))-abs(x(i-1,j,k+1)) * +abs(x(i-1,j,k-1)), abs(x(i,j,k+1))+abs(x(i,j,k-1)) * +abs(x(i-1,j,k+1))+abs(x(i-1,j,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=v1(i,1,k) 1 +vcor32(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * abs(x(i,2,k))-abs(x(i,-1,k))-abs(x(i-1,2,k)) * +abs(x(i-1,-1,k)), abs(x(i,2,k))+abs(x(i,-1,k)) * +abs(x(i-1,2,k))+abs(x(i-1,-1,k))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) 1 +vcor32(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i,1,k+1))-abs(x(i,1,k-1))-abs(x(i-1,1,k+1)) * +abs(x(i-1,1,k-1)), abs(x(i,1,k+1))+abs(x(i,1,k-1)) * +abs(x(i-1,1,k+1))+abs(x(i-1,1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif end do end do end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ do 63 k=2,n3-2 do 63 j=jllim,julim do 63 i=illim,iulim 63 v1(i,j,k)=v1(i,j,k) + vcor33(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1, k)+f2(i,j+1, k)+f2(i,j,k), * f3(i-1,j,k)+f3(i-1,j ,k+1)+f3(i,j ,k+1)+f3(i,j,k), * abs(x(i-1,j+1,k+1))-abs(x(i-1,j-1,k+1)) * -abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i ,j+1,k+1))-abs(x(i ,j-1,k+1)) * -abs(x(i ,j+1,k-1))+abs(x(i ,j-1,k-1)), * abs(x(i-1,j+1,k+1))+abs(x(i-1,j-1,k+1)) * +abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i ,j+1,k+1))+abs(x(i ,j-1,k+1)) * +abs(x(i ,j+1,k-1))+abs(x(i ,j-1,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=v1(i,1,k) + vcor33(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2, k)+f2(i,2, k)+f2(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i-1,2,k+1))-abs(x(i-1,-1,k+1)) * -abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i ,2,k+1))-abs(x(i ,-1,k+1)) * -abs(x(i ,2,k-1))+abs(x(i ,-1,k-1)), * abs(x(i-1,2,k+1))+abs(x(i-1,-1,k+1)) * +abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i ,2,k+1))+abs(x(i ,-1,k+1)) * +abs(x(i ,2,k-1))+abs(x(i ,-1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v1(i,j,1)=v1(i,j,1) 1 +vcor32(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i ,j+1,1))-abs(x(i ,j-1,1)) * -abs(x(i-1,j+1,1))+abs(x(i-1,j-1,1)), * abs(x(i ,j+1,1))+abs(x(i ,j-1,1)) * +abs(x(i-1,j+1,1))+abs(x(i-1,j-1,1))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) 1 +vcor32(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i ,j,2))-abs(x(i ,j,n3-2)) * -abs(x(i-1,j,2))+abs(x(i-1,j,n3-2)), * abs(x(i ,j,2))+abs(x(i ,j,n3-2)) * +abs(x(i-1,j,2))+abs(x(i-1,j,n3-2))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=v1(i,1,1) 1 +vcor32(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i ,2,1))-abs(x(i ,-1,1)) * -abs(x(i-1,2,1))+abs(x(i-1,-1,1)), * abs(x(i ,2,1))+abs(x(i ,-1,1)) * +abs(x(i-1,2,1))+abs(x(i-1,-1,1))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) 1 +vcor32(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i ,1,2))-abs(x(i ,1,n3-2)) * -abs(x(i-1,1,2))+abs(x(i-1,1,n3-2)), * abs(x(i ,1,2))+abs(x(i ,1,n3-2)) * +abs(x(i-1,1,2))+abs(x(i-1,1,n3-2))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif C----------------/ #endif /* POLES */ C----------------/ do j=jllim,julim do i=illim,iulim v1(i,j,1)=v1(i,j,1) + vcor33(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i-1,j+1, 2))-abs(x(i-1,j-1, 2)) * -abs(x(i-1,j+1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i ,j+1, 2))-abs(x(i ,j-1, 2)) * -abs(x(i ,j+1,n3-2))+abs(x(i ,j-1,n3-2)), * abs(x(i-1,j+1, 2))+abs(x(i-1,j-1, 2)) * +abs(x(i-1,j+1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i ,j+1, 2))+abs(x(i ,j-1, 2)) * +abs(x(i ,j+1,n3-2))+abs(x(i ,j-1,n3-2))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=v1(i,1,1) + vcor33(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i-1,2, 2))-abs(x(i-1,-1, 2)) * -abs(x(i-1,2,n3-2))+abs(x(i-1,-1,n3-2)) * +abs(x(i ,2, 2))-abs(x(i ,-1, 2)) * -abs(x(i ,2,n3-2))+abs(x(i ,-1,n3-2)), * abs(x(i-1,2, 2))+abs(x(i-1,-1, 2)) * +abs(x(i-1,2,n3-2))+abs(x(i-1,-1,n3-2)) * +abs(x(i ,2, 2))+abs(x(i ,-1, 2)) * +abs(x(i ,2,n3-2))+abs(x(i ,-1,n3-2))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 endif ! isor=3 c---------------------------------------------- compute antidiffusive velocities in y direction c---------------------------------------------- #if (POLES == 0) jllim = 1 + botedge julim = mp illim = 1 + leftedge iulim = np - rightedge #else jllim = 1 + botedge julim = mp illim = 1 iulim = np #endif do 52 k=2,n3-2 do 52 j=jllim,julim do 52 i=illim,iulim 52 v2(i,j,k)=vdyf(x(i,j-1,k),x(i,j,k),f2(i,j,k), * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f1(i,j-1,k)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j-1,k), * abs(x(i+1,j-1,k))+abs(x(i+1,j,k)) * -abs(x(i-1,j-1,k))-abs(x(i-1,j,k)), * abs(x(i+1,j-1,k))+abs(x(i+1,j,k)) * +abs(x(i-1,j-1,k))+abs(x(i-1,j,k))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f3(i,j-1,k)+f3(i,j,k)+f3(i,j,k+1)+f3(i,j-1,k+1), * abs(x(i,j-1,k+1))+abs(x(i,j,k+1)) * -abs(x(i,j-1,k-1))-abs(x(i,j,k-1)), * abs(x(i,j-1,k+1))+abs(x(i,j,k+1)) * +abs(x(i,j-1,k-1))+abs(x(i,j,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f1(1,j-1,k)+f1(1,j,k)+f1(2,j,k)+f1(2,j-1,k), * abs(x( 2,j-1,k))+abs(x( 2,j,k)) * -abs(x(-1,j-1,k))-abs(x(-1,j,k)), * abs(x( 2,j-1,k))+abs(x( 2,j,k)) * +abs(x(-1,j-1,k))+abs(x(-1,j,k))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * abs(x(1,j-1,k+1))+abs(x(1,j,k+1)) * -abs(x(1,j-1,k-1))-abs(x(1,j,k-1)), * abs(x(1,j-1,k+1))+abs(x(1,j,k+1)) * +abs(x(1,j-1,k-1))+abs(x(1,j,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=2,n3-2 do i=1,np v2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=2,n3-2 do i=1,np v2(i,mp+1,k)= 0. enddo enddo endif C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * -abs(x(i-1,j-1,1))-abs(x(i-1,j,1)), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * +abs(x(i-1,j-1,1))+abs(x(i-1,j,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f3(i,j-1,1)+f3(i,j,1)+f3(i,j,2)+f3(i,j-1,2), * abs(x(i,j-1, 2))+abs(x(i,j, 2)) * -abs(x(i,j-1,n3-2))-abs(x(i,j,n3-2)), * abs(x(i,j-1, 2))+abs(x(i,j, 2)) * +abs(x(i,j-1,n3-2))+abs(x(i,j,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * -abs(x(-1,j-1,1))-abs(x(-1,j,1)), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * +abs(x(-1,j-1,1))+abs(x(-1,j,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f3(1,j-1,1)+f3(1,j,1)+f3(1,j,2)+f3(1,j-1,2), * abs(x(1,j-1, 2))+abs(x(1,j, 2)) * -abs(x(1,j-1,n3-2))-abs(x(1,j,n3-2)), * abs(x(1,j-1, 2))+abs(x(1,j, 2)) * +abs(x(1,j-1,n3-2))+abs(x(1,j,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1-1,j, 1 )=v2( 1 ,j,1) v2(n1-1,j,n3m)=v2(n1-1,j,1) #endif enddo endif ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * -abs(x(i-1,j-1,1))-abs(x(i-1,j,1)), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * +abs(x(i-1,j-1,1))+abs(x(i-1,j,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=vdyf(x(i,j-1,n3m),x(i,j,n3m),f2(i,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m))) * +vcorr(f2(i,j,n3m), c * f1(i,j-1,n3m)+f1(i,j,1)+f1(i+1,j,n3m)+f1(i+1,j-1,n3m), * f1(i,j-1,n3m)+f1(i,j,n3m)+f1(i+1,j,n3m)+f1(i+1,j-1,n3m), !mod Andii * abs(x(i+1,j-1,n3m))+abs(x(i+1,j,n3m)) * -abs(x(i-1,j-1,n3m))-abs(x(i-1,j,n3m)), * abs(x(i+1,j-1,n3m))+abs(x(i+1,j,n3m)) * +abs(x(i-1,j-1,n3m))+abs(x(i-1,j,n3m))+ep, * .5*(h(i,j-1,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * -abs(x(-1,j-1,1))-abs(x(-1,j,1)), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * +abs(x(-1,j-1,1))+abs(x(-1,j,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=vdyf(x(1,j-1,n3m),x(1,j,n3m),f2(1,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m))) * +vcorr(f2(1,j,n3m), * f1(1,j-1,n3m)+f1(1,j,n3m)+f1(2,j,n3m)+f1(2,j-1,n3m), * abs(x( 2,j-1,n3m))+abs(x( 2,j,n3m)) * -abs(x(-1,j-1,n3m))-abs(x(-1,j,n3m)), * abs(x( 2,j-1,n3m))+abs(x( 2,j,n3m)) * +abs(x(-1,j-1,n3m))+abs(x(-1,j,n3m))+ep, * .5*(h(1,j-1,n3m)+h(1,j,n3m))) #if (PARALLEL == 0) v2(n1-1,j, 1 )=v2(1,j, 1 ) v2(n1-1,j,n3m)=v2(1,j,n3m) #endif enddo endif ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,mp v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np+1,j,n3m) end do end if #endif endif !ibcx=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do i=1,np v2(i, 1 , 1 )= 0. v2(i, 1 ,n3m)= 0. enddo endif if (topedge.eq.1) then do i=1,np v2(i,mp+1, 1 )= 0. v2(i,mp+1,n3m )= 0. enddo endif C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + 1*botedge julim = mp #else jllim = 1 julim = mp + j3*topedge illim = 1 iulim = np #endif do 521 k=2-ibcz,n3-2+ibcz do 521 j=jllim,julim do 521 i=illim,iulim 521 v2(i,j,k)=v2(i,j,k) * -vdiv1(f2(i,j-1,k),f2(i,j,k),f2(i,j+1,k), * .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f1(i+1,j-1,k),f1(i+1,j,k),f1(i,j-1,k), * f1(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f3(i,j-1,k+1),f3(i,j,k+1),f3(i,j-1,k), * f3(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) endif if(isor.eq.3) then !mod mhd c if(isor.eq.3.and.iflg.lt.31) then #if (POLES == 0) jllim = 1 + 2*botedge julim = mp - j3*topedge illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge #else jllim = 1 + 2*j3*botedge julim = mp - j3*topedge illim = 1 iulim = np #endif do 71 k=2-ibcz,n3-2-ibcz do 71 j=jllim,julim do 71 i=illim,iulim 71 v2(i,j,k)=v2(i,j,k) +vcor31(f2(i,j,k), 1 x(i,j-2,k),x(i,j-1,k),x(i,j,k),x(i,j+1,k), 1 .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2-ibcz,n3-2+ibcz do i=illim,iulim v2(i,2,k)=v2(i,2,k) +vcor31(f2(i,2,k), 1 x(i,-1,k),x(i,1,k),x(i,2,k),x(i,3,k), 1 .5*(h(i,1,k)+h(i,2,k))) enddo enddo end if if (topedge.eq.1) then do k=2-ibcz,n3-2+ibcz do i=illim,iulim v2(i,mp,k)=v2(i,mp,k) +vcor31(f2(i,mp,k), 1 x(i,mp-2,k),x(i,mp-1,k),x(i,mp,k),x(i,mp+2,k), 1 .5*(h(i,mp-1,k)+h(i,mp,k))) enddo enddo end if endif !ibcy=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np v2(i,2,k)=v2(i,2,k) +vcor31(f2(i,2,k), 1 x(i,1-j3,k),x(i,1,k),x(i,2,k),x(i,3,k), 1 .5*(h(i,1,k)+h(i,2,k))) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np v2(i,mp,k)=v2(i,mp,k) +vcor31(f2(i,mp,k), 1 x(i,mp-2*j3,k),x(i,mp-j3,k),x(i,mp,k),x(i,mp+j3,k), 1 .5*(h(i,mp-j3,k)+h(i,mp,k))) end do end do end if C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) jllim = 1 + (2-ibcy)*botedge julim = mp - (1-ibcy)*topedge illim = 1 + leftedge iulim = np - rightedge #else jllim = 1+botedge julim = mp illim = 1 iulim = np #endif do 72 k=2,n3-2 do 72 j=jllim,julim do 72 i=illim,iulim 72 v2(i,j,k)=v2(i,j,k) 1 +vcor32(f2(i,j,k), * f1(i,j-1,k)+f1(i+1,j-1,k)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j,k))-abs(x(i-1,j,k))-abs(x(i+1,j-1,k)) * +abs(x(i-1,j-1,k)), abs(x(i+1,j,k))+abs(x(i-1,j,k)) * +abs(x(i+1,j-1,k))+abs(x(i-1,j-1,k))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) 1 +vcor32(f2(i,j,k), * f3(i,j-1,k)+f3(i,j-1,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i,j,k+1))-abs(x(i,j,k-1))-abs(x(i,j-1,k+1)) * +abs(x(i,j-1,k-1)), abs(x(i,j,k+1))+abs(x(i,j,k-1)) * +abs(x(i,j-1,k+1))+abs(x(i,j-1,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=v2(1,j,k) 1 +vcor32(f2(1,j,k), * f1(1,j-1,k)+f1(2,j-1,k)+f1(2,j,k)+f1(1,j,k), * abs(x( 2,j,k))-abs(x(-1,j,k))-abs(x(2,j-1,k)) * +abs(x(-1,j-1,k)), abs(x(2,j,k))+abs(x(-1,j,k)) * +abs(x(2,j-1,k))+abs(x(-1,j-1,k))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) 1 +vcor32(f2(1,j,k), * f3(1,j-1,k)+f3(1,j-1,k+1)+f3(1,j,k+1)+f3(1,j,k), * abs(x(1,j,k+1))-abs(x(1,j,k-1))-abs(x(1,j-1,k+1)) * +abs(x(1,j-1,k-1)), abs(x(1,j,k+1))+abs(x(1,j,k-1)) * +abs(x(1,j-1,k+1))+abs(x(1,j-1,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ do 73 k=2,n3-2 do 73 j=jllim,julim do 73 i=illim,iulim 73 v2(i,j,k)=v2(i,j,k) + vcor33(f2(i,j,k), * f1(i,j-1,k)+f1(i+1,j-1,k)+f1(i+1,j,k)+f1(i,j,k), * f3(i,j-1,k)+f3(i,j-1,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i+1,j-1,k+1))-abs(x(i-1,j-1,k+1)) * -abs(x(i+1,j-1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1, j ,k+1))-abs(x(i-1, j ,k+1)) * -abs(x(i+1, j ,k-1))+abs(x(i-1, j ,k-1)), * abs(x(i+1,j-1,k+1))+abs(x(i-1,j-1,k+1)) * +abs(x(i+1,j-1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1, j ,k+1))+abs(x(i-1, j ,k+1)) * +abs(x(i+1, j ,k-1))+abs(x(i-1, j ,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=v2(1,j,k) + vcor33(f2(1,j,k), * f1(1,j-1,k)+f1( 2 ,j-1,k)+f1( 2 ,j,k)+f1(1,j,k), * f3(1,j-1,k)+f3(1,j-1,k+1)+f3(1,j,k+1)+f3(1,j,k), * abs(x(2,j-1,k+1))-abs(x(-1,j-1,k+1)) * -abs(x(2,j-1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x(2, j ,k+1))-abs(x(-1, j ,k+1)) * -abs(x(2, j ,k-1))+abs(x(-1, j ,k-1)), * abs(x(2,j-1,k+1))+abs(x(-1,j-1,k+1)) * +abs(x(2,j-1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x(2, j ,k+1))+abs(x(-1, j ,k+1)) * +abs(x(2, j ,k-1))+abs(x(-1, j ,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=v2(i,j,1) 1 +vcor32(f2(i,j,1), * f1(i,j-1,1)+f1(i+1,j-1,1)+f1(i+1,j,1)+f1(i,j,1), * abs(x(i+1,j,1))-abs(x(i-1,j,1))-abs(x(i+1,j-1,1)) * +abs(x(i-1,j-1,1)), abs(x(i+1,j,1))+abs(x(i-1,j,1)) * +abs(x(i+1,j-1,1))+abs(x(i-1,j-1,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) 1 +vcor32(f2(i,j,1), * f3(i,j-1,1)+f3(i,j-1, 2 )+f3(i,j, 2 )+f3(i,j,1), * abs(x(i,j,2))-abs(x(i,j,n3-2))-abs(x(i,j-1,2)) * +abs(x(i,j-1,n3-2)), abs(x(i,j,2))+abs(x(i,j,n3-2)) * +abs(x(i,j-1,2))+abs(x(i,j-1,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=v2(1,j,1) 1 +vcor32(f2(1,j,1), * f1(1,j-1,1)+f1(2,j-1,1)+f1(2,j,1)+f1(1,j,1), * abs(x(2,j,1))-abs(x(-1,j,1))-abs(x(2,j-1,1)) * +abs(x(-1,j-1,1)), abs(x(2,j,1))+abs(x(-1,j,1)) * +abs(x(2,j-1,1))+abs(x(-1,j-1,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) 1 +vcor32(f2(1,j,1), * f3(1,j-1,1)+f3(1,j-1,2)+f3(1,j,2)+f3(1,j,1), * abs(x(1,j,2))-abs(x(1,j,n3-2))-abs(x(1,j-1,2)) * +abs(x(1,j-1,n3-2)), abs(x(1,j,2))+abs(x(1,j,n3-2)) * +abs(x(1,j-1,2))+abs(x(1,j-1,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1m,j, 1 )=v2( 1 ,j,1) v2(n1m,j,n3m)=v2(n1m,j,1) #endif enddo endif #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ do j=jllim,julim do i=illim,iulim v2(i,j,1)=v2(i,j,1) + vcor33(f2(i,j,1), * f1(i,j-1,1)+f1(i+1,j-1,1)+f1(i+1,j,1)+f1(i,j,1), * f3(i,j-1,1)+f3( i ,j-1,2)+f3( i ,j,2)+f3(i,j,1), * abs(x(i+1,j-1, 2 ))-abs(x(i-1,j-1, 2 )) * -abs(x(i+1,j-1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i+1, j , 2 ))-abs(x(i-1, j , 2 )) * -abs(x(i+1, j ,n3-2))+abs(x(i-1, j ,n3-2)), * abs(x(i+1,j-1, 2 ))+abs(x(i-1,j-1, 2 )) * +abs(x(i+1,j-1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i+1, j , 2 ))+abs(x(i-1, j , 2 )) * +abs(x(i+1, j ,n3-2))+abs(x(i-1, j ,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=v2(1,j,1) + vcor33(f2(1,j,1), * f1(1,j-1,1)+f1(2,j-1,1)+f1(2,j,1)+f1(1,j,1), * f3(1,j-1,1)+f3(1,j-1,2)+f3(1,j,2)+f3(1,j,1), * abs(x(2,j-1, 2 ))-abs(x(-1,j-1, 2 )) * -abs(x(2,j-1,n3-2))+abs(x(-1,j-1,n3-2)) * +abs(x(2, j , 2 ))-abs(x(-1, j , 2 )) * -abs(x(2, j ,n3-2))+abs(x(-1, j ,n3-2)), * abs(x(2,j-1, 2 ))+abs(x(-1,j-1, 2 )) * +abs(x(2,j-1,n3-2))+abs(x(-1,j-1,n3-2)) * +abs(x(2, j , 2 ))+abs(x(-1, j , 2 )) * +abs(x(2, j ,n3-2))+abs(x(-1, j ,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1m,j, 1 )=v2( 1 ,j,1) v2(n1m,j,n3m)=v2(n1m,j,1) #endif enddo endif #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 endif ! isor=3 c---------------------------------------------- compute antidiffusive velocities in z direction c---------------------------------------------- #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 53 k=2,n3m do 53 j=jllim,julim do 53 i=illim,iulim 53 v3(i,j,k)=vdyf(x(i,j,k-1),x(i,j,k),f3(i,j,k), * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f1(i,j,k-1)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j,k-1), * abs(x(i+1,j,k-1))+abs(x(i+1,j,k)) * -abs(x(i-1,j,k-1))-abs(x(i-1,j,k)), * abs(x(i+1,j,k-1))+abs(x(i+1,j,k)) * +abs(x(i-1,j,k-1))+abs(x(i-1,j,k))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k-1))+abs(x(i,j+1,k)) * -abs(x(i,j-1,k-1))-abs(x(i,j-1,k)), * abs(x(i,j+1,k-1))+abs(x(i,j+1,k)) * +abs(x(i,j-1,k-1))+abs(x(i,j-1,k))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3m do j=jllim,julim v3(1,j,k)=vdyf(x(1,j,k-1),x(1,j,k),f3(1,j,k), * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f1(1,j,k-1)+f1(1,j,k)+f1(2,j,k)+f1(2,j,k-1), * abs(x( 2,j,k-1))+abs(x( 2,j,k)) * -abs(x(-1,j,k-1))-abs(x(-1,j,k)), * abs(x( 2,j,k-1))+abs(x( 2,j,k)) * +abs(x(-1,j,k-1))+abs(x(-1,j,k))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * abs(x(1,j+1,k-1))+abs(x(1,j+1,k)) * -abs(x(1,j-1,k-1))-abs(x(1,j-1,k)), * abs(x(1,j+1,k-1))+abs(x(1,j+1,k)) * +abs(x(1,j-1,k-1))+abs(x(1,j-1,k))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1-1,j,k)=v3(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=2,n3m do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) end do end do end if #endif endif !ibcx=1 if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,1,k)=vdyf(x(i,1,k-1),x(i,1,k),f3(i,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f1(i,1,k-1)+f1(i,1,k)+f1(i+1,1,k)+f1(i+1,1,k-1), * abs(x(i+1,1,k-1))+abs(x(i+1,1,k)) * -abs(x(i-1,1,k-1))-abs(x(i-1,1,k)), * abs(x(i+1,1,k-1))+abs(x(i+1,1,k)) * +abs(x(i-1,1,k-1))+abs(x(i-1,1,k))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * abs(x(i, 2,k-1))+abs(x(i, 2,k)) * -abs(x(i,-1,k-1))-abs(x(i,-1,k)), * abs(x(i, 2,k-1))+abs(x(i, 2,k)) * +abs(x(i,-1,k-1))+abs(x(i,-1,k))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) end do end do end if #endif if(ibcx.eq.1) then if (leftedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(1,1,k)=vdyf(x(1,1,k-1),x(1,1,k),f3(1,1,k), * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f1(1,1,k-1)+f1(1,1,k)+f1(2,1,k)+f1(2,1,k-1), * abs(x( 2,1,k-1))+abs(x( 2,1,k)) * -abs(x(-1,1,k-1))-abs(x(-1,1,k)), * abs(x( 2,1,k-1))+abs(x( 2,1,k)) * +abs(x(-1,1,k-1))+abs(x(-1,1,k))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * abs(x(1, 2,k-1))+abs(x(1, 2,k)) * -abs(x(1,-1,k-1))-abs(x(1,-1,k)), * abs(x(1, 2,k-1))+abs(x(1, 2,k)) * +abs(x(1,-1,k-1))+abs(x(1,-1,k))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m,n2m,k)=v3(1,1,k) v3(n1m, 1 ,k)=v3(1,1,k) v3( 1 ,n2m,k)=v3(1,1,k) #endif enddo end if #if (PARALLEL > 0) call update(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(np,mp,k)=v3(np+1,mp+1,k) end do end if if (rightedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(np,1,k)=v3(np+1,1,k) end do end if if (leftedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(1,mp,k)=v3(1,mp+1,k) end do end if #endif endif !ibcx=1 endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 531 k=2,n3m do 531 j=jllim,julim do 531 i=illim,iulim 531 v3(i,j,k)=v3(i,j,k) * -vdiv1(f3(i,j,k-1),f3(i,j,k),f3(i,j,k+1), * .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f1(i+1,j,k-1),f1(i+1,j,k),f1(i,j,k-1), * f1(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f2(i,j+1,k-1),f2(i,j+1,k),f2(i,j,k-1), * f2(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) endif if(isor.eq.3) then !mod mhd c if(isor.eq.3.and.iflg.lt.31) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 81 k=3,n3-2 do 81 j=jllim,julim do 81 i=illim,iulim 81 v3(i,j,k)=v3(i,j,k) +vcor31(f3(i,j,k), 1 x(i,j,k-2),x(i,j,k-1),x(i,j,k),x(i,j,k+1), 1 .5*(h(i,j,k-1)+h(i,j,k))) if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v3(i,j,2)=v3(i,j,2) +vcor31(f3(i,j,2), 1 x(i,j,n3-2),x(i,j,1),x(i,j,2),x(i,j,3), 1 .5*(h(i,j,1)+h(i,j,2))) v3(i,j,n3-1)=v3(i,j,n3-1) +vcor31(f3(i,j,n3-1), 1 x(i,j,n3-3),x(i,j,n3-2),x(i,j,n3-1),x(i,j,2), 1 .5*(h(i,j,n3-2)+h(i,j,n3-1))) enddo enddo endif #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 82 k=3-ibcz,n3-2+ibcz do 82 j=jllim,julim do 82 i=illim,iulim 82 v3(i,j,k)=v3(i,j,k) 1 +vcor32(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k))-abs(x(i,j-1,k))-abs(x(i,j+1,k-1)) * +abs(x(i,j-1,k-1)), abs(x(i,j+1,k))+abs(x(i,j-1,k)) * +abs(x(i,j+1,k-1))+abs(x(i,j-1,k-1))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) 1 +vcor32(f3(i,j,k), * f1(i,j,k-1)+f1(i+1,j,k-1)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j,k))-abs(x(i-1,j,k))-abs(x(i+1,j,k-1)) * +abs(x(i-1,j,k-1)), abs(x(i+1,j,k))+abs(x(i-1,j,k)) * +abs(x(i+1,j,k-1))+abs(x(i-1,j,k-1))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,1,k)=v3(i,1,k) 1 +vcor32(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * abs(x(i,2,k))-abs(x(i,-1,k))-abs(x(i,2,k-1)) * +abs(x(i,-1,k-1)), abs(x(i,2,k))+abs(x(i,-1,k)) * +abs(x(i,2,k-1))+abs(x(i,-1,k-1))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) 1 +vcor32(f3(i,1,k), * f1(i,1,k-1)+f1(i+1,1,k-1)+f1(i+1,1,k)+f1(i,1,k), * abs(x(i+1,1,k))-abs(x(i-1,1,k))-abs(x(i+1,1,k-1)) * +abs(x(i-1,1,k-1)), abs(x(i+1,1,k))+abs(x(i-1,1,k)) * +abs(x(i+1,1,k-1))+abs(x(i-1,1,k-1))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ do 83 k=3-ibcz,n3-2+ibcz do 83 j=jllim,julim do 83 i=illim,iulim 83 v3(i,j,k)=v3(i,j,k) + vcor33(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * f1(i,j,k-1)+f1(i+1,j,k-1)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j+1,k-1))-abs(x(i+1,j-1,k-1)) * -abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1,j+1, k ))-abs(x(i+1,j-1, k )) * -abs(x(i-1,j+1, k ))+abs(x(i-1,j-1, k )), * abs(x(i+1,j+1,k-1))+abs(x(i+1,j-1,k-1)) * +abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1,j+1, k ))+abs(x(i+1,j-1, k )) * +abs(x(i-1,j+1, k ))+abs(x(i-1,j-1, k ))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,1,k)=v3(i,1,k) + vcor33(f3(i,1,k), * f2(i,1,k-1)+f2(i, 2 ,k-1)+f2(i, 2 ,k)+f2(i,1,k), * f1(i,1,k-1)+f1(i+1,1,k-1)+f1(i+1,1,k)+f1(i,1,k), * abs(x(i+1,2,k-1))-abs(x(i+1,-1,k-1)) * -abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i+1,2, k ))-abs(x(i+1,-1, k )) * -abs(x(i-1,2, k ))+abs(x(i-1,-1, k )), * abs(x(i+1,2,k-1))+abs(x(i+1,-1,k-1)) * +abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i+1,2, k ))+abs(x(i+1,-1, k )) * +abs(x(i-1,2, k ))+abs(x(i-1,-1, k ))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 if(ibcx.eq.1) then if(leftedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(1,j,k)=v3(1,j,k) 1 +vcor32(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * abs(x(1,j+1, k ))-abs(x(1,j-1, k )) * -abs(x(1,j+1,k-1))+abs(x(1,j-1,k-1)), * abs(x(1,j+1, k ))+abs(x(1,j-1, k )) * +abs(x(1,j+1,k-1))+abs(x(1,j-1,k-1))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) 1 +vcor32(f3(1,j,k), * f1(1,j,k-1)+f1(2,j,k-1)+f1(2,j,k)+f1(1,j,k), * abs(x(2,j, k ))-abs(x(-1,j, k )) * -abs(x(2,j,k-1))+abs(x(-1,j,k-1)), * abs(x(2,j, k ))+abs(x(-1,j, k )) * +abs(x(2,j,k-1))+abs(x(-1,j,k-1))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo end if #endif if(ibcy.eq.1) then if ((leftedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,1,k)=v3(1,1,k) 1 +vcor32(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * abs(x(1,2,k))-abs(x(1,-1,k))-abs(x(1,2,k-1))+abs(x(1,-1,k-1)), * abs(x(1,2,k))+abs(x(1,-1,k))+abs(x(1,2,k-1))+abs(x(1,-1,k-1)) * +ep, * .5*(h(1,1,k-1)+h(1,1,k))) 1 +vcor32(f3(1,1,k), * f1(1,1,k-1)+f1(2,1,k-1)+f1(2,1,k)+f1(1,1,k), * abs(x(2,1,k))-abs(x(-1,1,k))-abs(x(2,1,k-1))+abs(x(-1,1,k-1)), * abs(x(2,1,k))+abs(x(-1,1,k))+abs(x(2,1,k-1))+abs(x(-1,1,k-1)) * +ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m, 1 ,k)=v3(1, 1 ,k) v3( 1 ,n2m,k)=v3(1, 1 ,k) v3(n1m,n2m,k)=v3(1,n2m,k) #endif enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if ((rightedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,1,k)=v3(np+1,1,k) enddo end if call updatebt(v3,np,mp,l+1,np,mp,1) if ((topedge.eq.1).and.(leftedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,mp,k)=v3(1,mp+1,k) enddo end if if ((topedge.eq.1).and.(rightedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,mp,k)=v3(np,mp+1,k) enddo end if #endif endif !ibcy=1 if(leftedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(1,j,k)=v3(1,j,k) + vcor33(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * f1(1,j,k-1)+f1(2, j ,k-1)+f1(2, j ,k)+f1(1,j,k), * abs(x( 2,j+1,k-1))-abs(x( 2,j-1,k-1)) * -abs(x(-1,j+1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x( 2,j+1, k ))-abs(x( 2,j-1, k )) * -abs(x(-1,j+1, k ))+abs(x(-1,j-1, k )), * abs(x( 2,j+1,k-1))+abs(x( 2,j-1,k-1)) * +abs(x(-1,j+1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x( 2,j+1, k ))+abs(x( 2,j-1, k )) * +abs(x(-1,j+1, k ))+abs(x(-1,j-1, k ))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo end if #endif if(ibcy.eq.1) then if ((leftedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,1,k)=v3(1,1,k) + vcor33(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * f1(1,1,k-1)+f1(2,1,k-1)+f1(2,1,k)+f1(1,1,k), * abs(x( 2,2,k-1))-abs(x( 2,-1,k-1)) * -abs(x(-1,2,k-1))+abs(x(-1,-1,k-1)) * +abs(x( 2,2, k ))-abs(x( 2,-1, k )) * -abs(x(-1,2, k ))+abs(x(-1,-1, k )), * abs(x( 2,2,k-1))+abs(x( 2,-1,k-1)) * +abs(x(-1,2,k-1))+abs(x(-1,-1,k-1)) * +abs(x( 2,2, k ))+abs(x( 2,-1, k )) * +abs(x(-1,2, k ))+abs(x(-1,-1, k ))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m, 1 ,k)=v3(1, 1 ,k) v3( 1 ,n2m,k)=v3(1, 1 ,k) v3(n1m,n2m,k)=v3(1,n2m,k) #endif enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if ((rightedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,1,k)=v3(np+1,1,k) enddo end if call updatebt(v3,np,mp,l+1,np,mp,1) if ((topedge.eq.1).and.(leftedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,mp,k)=v3(1,mp+1,k) enddo end if if ((topedge.eq.1).and.(rightedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,mp,k)=v3(np,mp+1,k) enddo end if #endif endif !ibcy=1 endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ endif !isor=3 #if (POLES == 0) COLD if (ibcx.eq.1) then COLD do k=1,n3m COLD do j=1,n2m COLD v1(1 ,j,k)=v1(n1m,j,k) COLD v1(n1,j,k)=v1(2 ,j,k) COLD end do COLD end do COLD end if COLD if (ibcy.eq.1) then COLD do k=1,n3m COLD do i=1,n1m COLD v2(i, 1,k)=v2(i,n2m,k) COLD v2(i,n2,k)=v2(i,2 ,k) COLD end do COLD end do COLD end if #else call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if #endif COLD if (iflg.ne.8) then COLD do j=1,n2m COLD do i=1,n1m COLD v3(i,j, 1)=-v3(i,j, 2)*(1-ibcz)+v3(i,j,n3m)*ibcz COLD v3(i,j,n3)=-v3(i,j,n3m)*(1-ibcz)+v3(i,j, 2 )*ibcz COLD enddo COLD enddo COLD end if if(nonos.eq.1) then c non-osscilatory option C----------------/ #if (POLES == 0) C----------------/ do 401 k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do 401 j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - j3 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + j3 end if do 401 i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) 401 mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) C----------------/ #else /* POLES */ C----------------/ do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do j=jllim2,julim2 jm = j - j3 jp = j + j3 do i=1,np im = i - 1 ip = i + 1 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k),x(i+1,1,k),mx(i,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k),x(i+1,1,k),mn(i,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k),mx(i,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k),mn(i,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) illim = 1 + leftedge #else illim = 1 #endif do 402 k=1,n3m do 402 j=1,mp do 402 i=illim,np 402 f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) C----------------/ #if (POLES == 0) C----------------/ if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1,j,k)=f1(-1,j,k)*ibcx end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=f1(np+3,j,k)*ibcx end do end do end if C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) #endif #if (POLES == 0) jllim = 1 + j3*botedge #else jllim = 1 #endif do 403 k=1,n3m do 403 j=jllim,mp do 403 i=1,np 403 f2(i,j,k)=donor(x(i,j-1,k),x(i,j,k),v2(i,j,k)) C----------------/ #if (POLES == 0) C----------------/ if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=f2(i,-1,k)*ibcy end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k)*ibcy end do end do end if C----------------/ #else /* POLES */ C----------------/ if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 4033 k=2,n3m do 4033 j=1,mp do 4033 i=1,np 4033 f3(i,j,k)=donor(x(i,j,k-1),x(i,j,k),v3(i,j,k)) if (iprec.eq.1) then do j=1,mp do i=1,np f3(i,j, 1)=0. f3(i,j,n3)=0. enddo enddo else do j=1,mp do i=1,np f3(i,j, 1)=-f3(i,j, 2 )*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2 )*ibcz enddo enddo endif do 404 k=1,n3m do 404 j=1,mp do 404 i=1,np cp(i,j,k)=(mx(i,j,k)-x(i,j,k))*h(i,j,k)/ 1( pn(f1(i+1,j,k))+pp(f1(i,j,k)) 2 +pn(f2(i,j+1,k))+pp(f2(i,j,k)) 3 +pn(f3(i,j,k+1))+pp(f3(i,j,k))+ep) cn(i,j,k)=(x(i,j,k)-mn(i,j,k))*h(i,j,k)/ 1( pp(f1(i+1,j,k))+pn(f1(i,j,k)) 2 +pp(f2(i,j+1,k))+pn(f2(i,j,k)) 3 +pp(f3(i,j,k+1))+pn(f3(i,j,k))+ep) 404 continue call update2(cp,np,mp,l,np,mp,1) call update2(cn,np,mp,l,np,mp,1) do k=1,n3m do j=1,mp do i=illim,np v1(i,j,k)=pp(v1(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i-1,j,k))*pp(sign(1., x(i-1,j,k))) 1 +amin1(1.,cp(i-1,j,k),cn(i,j,k))*pp(sign(1.,-x(i-1,j,k))) ) 2 -pn(v1(i,j,k))* 2 ( amin1(1.,cp(i-1,j,k),cn(i,j,k))*pp(sign(1., x(i ,j,k ))) 2 +amin1(1.,cp(i,j,k),cn(i-1,j,k))*pp(sign(1.,-x(i ,j,k ))) ) enddo enddo enddo do k=1,n3m do j=jllim,mp do i=1,np v2(i,j,k)=pp(v2(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i,j-1,k))*pp(sign(1., x(i,j-1,k))) 1 +amin1(1.,cp(i,j-1,k),cn(i,j,k))*pp(sign(1.,-x(i,j-1,k))) ) 1 -pn(v2(i,j,k))* 2 ( amin1(1.,cp(i,j-1,k),cn(i,j,k))*pp(sign(1., x(i,j ,k))) 2 +amin1(1.,cp(i,j,k),cn(i,j-1,k))*pp(sign(1.,-x(i,j ,k))) ) enddo enddo enddo do k=2,n3m do j=1,mp do i=1,np v3(i,j,k)=pp(v3(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i,j,k-1))*pp(sign(1., x(i,j,k-1))) 1 +amin1(1.,cp(i,j,k-1),cn(i,j,k))*pp(sign(1.,-x(i,j,k-1))) ) 1 -pn(v3(i,j,k))* 2 ( amin1(1.,cp(i,j,k-1),cn(i,j,k))*pp(sign(1., x(i,j,k ))) 2 +amin1(1.,cp(i,j,k),cn(i,j,k-1))*pp(sign(1.,-x(i,j,k ))) ) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) end do end do end if end if if (ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3 ,k) end do end do end if end if C----------------/ #else /* POLES */ C----------------/ call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ if (iprec.eq.1) then do j=1,mp do i=1,np v3(i,j, 1)=0. v3(i,j,n3)=0. enddo enddo else do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2 )*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz enddo enddo endif 30 continue 6 continue c enforce cyclicity if (istab.eq.1.and.isphere.eq.0) then iencyc=1 else iencyc=0 endif if (iencyc.eq.1) then if(ibcx.eq.1) then call updatelr(x,np,mp,l,np,mp,1) if(rightedge.eq.1) then do k=1,L do j=1,mp x(np,j,k)=x(np+1,j,k) enddo enddo endif endif if(ibcy.eq.1) then call updatebt(x,np,mp,l,np,mp,1) if(topedge.eq.1) then do k=1,L do i=1,np x(i,mp,k)=x(i,mp+j3,k) enddo enddo endif endif if(ibcz.eq.1) then do j=1,mp do i=1,np x(i,j,l)=x(i,j,1) enddo enddo endif endif call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(34) #endif return end subroutine mpdata3_fil(u1,u2,u3,x,h,iflg) include 'param.nml' include 'msg.inc' parameter(iord0=2,isor=1,nonos=1,idiv=0) parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . u3(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+1+2*ih)*l) parameter(iv3f3=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ibcxa=(mp+2*ih)*l,ibcya=(np+2*ih)*l) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+iv3f3+ibcxa+ibcya)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+1+ih, l), . v3(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+1+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(1-ih:mp+ih, l, 2), . bcy(1-ih:np+ih, l, 2), . scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc data ep/1.e-10/ c pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 vdyf(x1,x2,a,r,ampl)=(0*2.*ampl*r+abs(a)-a**2/r)*(abs(x2)-abs(x1)) 1 /(abs(x2)+abs(x1)+ep) vcorr(a,b,y1,y2,r)=-0.125*a*b*y1/(y2*r) vcor31(a,x0,x1,x2,x3,r)= -(a -3.*abs(a)*a/r+2.*a**3/r**2)/3. 1 *(abs(x0)+abs(x3)-abs(x1)-abs(x2)) 2 /(abs(x0)+abs(x3)+abs(x1)+abs(x2)+ep) vcor32(a,b,y1,y2,r)=0.25*b/r*(abs(a)-2.*a**2/r)*y1/y2 vcor33(a,b,c,y1,y2,r)=-a*b*c/(24.**r**2)*y1/y2 vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r c #if (TIMEPLT == 1) call ttbeg(34) #endif call update(x,np,mp,l,np,mp,iup) iord=iord0 if(isor.eq.3) iord=max0(iord,3) if(liner.eq.1) iord=1 #if (POLES == 0) ibox=1-ibcx iboy=1-ibcy #else ibox=0 iboy=0 #endif iboz=1-ibcz iprec=0 c if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib pbc=1. c if(iflg.eq.2.or.iflg.eq.3) pbc=pflip if(iflg.eq.2.or.iflg.eq.3.or.iflg.eq.31.or.iflg.eq.32) pbc=pflip do k=2,n3m do j=1,mp do i=1,np v3(i,j,k) = u3(i,j,k) enddo end do end do do j=1,mp do i=1,np v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,n3m do j=1,mp do i=illim,iulim v1(i,j,k) = u1(i,j,k) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1( 1,j,k) = ubc(j,k,1) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k) = ubc(j,k,2) end do end do end if C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + j3*botedge julim = mp do k=1,n3m do j=jllim,mp do i=1,np v2(i,j,k) = u2(i,j,k) end do end do end do if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k) = vbc(i,k,1) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k) = vbc(i,k,2) end do end do end if if (nonos.eq.1) then C----------------/ #if (POLES == 0) C----------------/ do k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - 1 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + 1 end if do i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do C----------------/ #else /* POLES */ C----------------/ jllim2 = 1 + j3*botedge julim2 = mp - j3*topedge do k=1,n3m km=max0(k-1,1) kp=min0(k+1,l) do j=jllim2,julim2 jm = j - 1 jp = j + 1 do i=1,np im = i - 1 ip = i + 1 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ endif do 30 itr=1,iord #if (POLES == 0) if((itr.eq.1).and.((ibcx*ibcy).eq.0)) . call mp3bc(x,iflg,bcx,bcy,np,mp,n3m) #endif COLD call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do 331 k=1,n3m do 331 j=1,mp do 331 i=illim,iulim 331 f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) c if(itr.eq.1.and.kampd(1).ne.0) then if(itr.eq.iord) then do k=1,n3m do j=1,mp do i=illim,iulim ampdx=ampd(1,j,1)*.5*(h(i,j,k)+h(i-1,j,k)) f1(i,j,k)=f1(i,j,k)-ampdx*(x(i,j,k)-x(i-1,j,k)) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=f1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)= f1(np+3,j,k) end do end do end if else if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=donor(bcx(j,k,1),x(1,j,k),v1(1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=donor(x(np,j,k),bcx(j,k,2),v1(np+1,j,k)) end do end do end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + botedge julim = mp do 332 k=1,n3m do 332 j=jllim,mp do 332 i=1,np 332 f2(i,j,k)=donor(x(i,j-1,k),x(i,j,k),v2(i,j,k)) c if(itr.eq.1.and.kampd(2).ne.0) then if(itr.eq.iord) then do k=1,n3m do j=jllim,mp do i=1,np ampdy=.5*(ampd(1,j,2)+ampd(1,j-1,2)) & *.5*(h(i,j,k)+h(i,j-1,k)) f2(i,j,k)=f2(i,j,k)-ampdy*(x(i,j,k)-x(i,j-1,k)) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1 ,k)=f2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k) enddo enddo end if else if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1 ,k)=donor(bcy(i,k,1),x(i,1,k),v2(i,1,k)) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=donor(x(i,mp,k),bcy(i,k,2),v2(i,mp+1,k)) enddo enddo end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if endif C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np f2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np f2(i,mp+1,k)= 0. enddo enddo endif if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 333 k=2,n3m do 333 j=1,mp do 333 i=1,np 333 f3(i,j,k)=donor(x(i,j,k-1),x(i,j,k),v3(i,j,k)) c if(itr.eq.1.and.kampd(3).ne.0) then if(itr.eq.iord) then do k=2,n3m do j=1,mp do i=1,np ampdz=ampd(1,j,3)*.5*(h(i,j,k)+h(i,j,k-1)) f3(i,j,k)=f3(i,j,k)-ampdz*(x(i,j,k)-x(i,j,k-1)) enddo enddo enddo endif if (iprec.eq.1) then do j=1,mp do i=1,np f3(i,j, 1)=donor(x(i,j, 1),x(i,j, 1),v3(i,j, 1)) f3(i,j,n3)=donor(x(i,j,n3m),x(i,j,n3m),v3(i,j,n3)) end do end do else do j=1,mp do i=1,np f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2)*ibcz enddo enddo end if do 334 k=1,n3m do 334 j=1,mp do 334 i=1,np 334 x(i,j,k)=x(i,j,k)-( f1(i+1,j,k)-f1(i,j,k) . +f2(i,j+1,k)-f2(i,j,k) . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k) if(itr.eq.iord) go to 6 #if (POLES == 0) iulim = np + rightedge #else iulim = np #endif do 48 k=1,n3m do 48 j=1,mp do 48 i=1,iulim f1(i,j,k)=v1(i,j,k) 48 v1(i,j,k)=0. julim = mp + topedge do 49 k=1,n3m do 49 j=1,julim do 49 i=1,np f2(i,j,k)=v2(i,j,k) 49 v2(i,j,k)=0. do 50 k=1,n3 do 50 j=1,mp do 50 i=1,np f3(i,j,k)=v3(i,j,k) 50 v3(i,j,k)=0. c---------------------------------------------- compute antidiffusive velocities in x direction c---------------------------------------------- call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) if (rightedge.eq.0) then call update(f1,np,mp,l,np+1,mp,1) else call update(f1,np+1,mp,l,np+1,mp,1) end if #else call update(f1,np,mp,l,np+1,mp,1) #endif if (topedge.eq.0) then call update(f2,np,mp,l,np,mp+1,1) else call update(f2,np,mp+1,l,np,mp+1,1) end if call update(f3,np,mp,l+1,np,mp,1) #if (POLES == 0) jllim = 1 + botedge julim = mp - topedge illim = 1 + leftedge #else jllim = 1 julim = mp illim = 1 #endif do 51 k=2,n3-2 do 51 j=jllim,julim do 51 i=illim,np 51 v1(i,j,k)=vdyf(x(i-1,j,k),x(i,j,k),f1(i,j,k), * .5*(h(i-1,j,k)+h(i,j,k)),ampd(1,j,1)*max0(2-itr,0)) * +vcorr(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i-1,j+1,k))+abs(x(i,j+1,k)) * -abs(x(i-1,j-1,k))-abs(x(i,j-1,k)), * abs(x(i-1,j+1,k))+abs(x(i,j+1,k)) * +abs(x(i-1,j-1,k))+abs(x(i,j-1,k))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i-1,j,k+1))+abs(x(i,j,k+1)) * -abs(x(i-1,j,k-1))-abs(x(i,j,k-1)), * abs(x(i-1,j,k+1))+abs(x(i,j,k+1)) * +abs(x(i-1,j,k-1))+abs(x(i,j,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,np v1(i,1,k)=vdyf(x(i-1,1,k),x(i,1,k),f1(i,1,k), * .5*(h(i-1,1,k)+h(i,1,k)),ampd(1,1,1)*max0(2-itr,0)) * +vcorr(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * abs(x(i-1, 2,k))+abs(x(i, 2,k)) * -abs(x(i-1,-1,k))-abs(x(i,-1,k)), * abs(x(i-1, 2,k))+abs(x(i, 2,k)) * +abs(x(i-1,-1,k))+abs(x(i,-1,k))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i-1,1,k+1))+abs(x(i,1,k+1)) * -abs(x(i-1,1,k-1))-abs(x(i,1,k-1)), * abs(x(i-1,1,k+1))+abs(x(i,1,k+1)) * +abs(x(i-1,1,k-1))+abs(x(i,1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,np v1(i,mp,k)=v1(i,mp+1,k) end do end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,np v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1)),ampd(1,j,1)*max0(2-itr,0)) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * -abs(x(i-1,j-1,1))-abs(x(i,j-1,1)), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * +abs(x(i-1,j-1,1))+abs(x(i,j-1,1))+ep, * .5*(h(i-1,j ,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i-1,j, 2 ))+abs(x(i,j, 2 )) * -abs(x(i-1,j,n3-2))-abs(x(i,j,n3-2)), * abs(x(i-1,j, 2 ))+abs(x(i,j, 2 )) * +abs(x(i-1,j,n3-2))+abs(x(i,j,n3-2))+ep, * .5*(h(i-1,j, 1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1)),ampd(1,1,1)*max0(2-itr,0)) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * -abs(x(i-1,-1,1))-abs(x(i,-1,1)), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * +abs(x(i-1,-1,1))+abs(x(i,-1,1))+ep, * .5*(h(i-1, 1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i-1,1, 2 ))+abs(x(i,1, 2 )) * -abs(x(i-1,1,n3-2))-abs(x(i,1,n3-2)), * abs(x(i-1,1, 2 ))+abs(x(i,1, 2 )) * +abs(x(i-1,1,n3-2))+abs(x(i,1,n3-2))+ep, * .5*(h(i-1,1, 1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,np v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,np v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1)),ampd(1,j,1)*max0(2-itr,0)) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * -abs(x(i-1,j-1,1))-abs(x(i,j-1,1)), * abs(x(i-1,j+1,1))+abs(x(i,j+1,1)) * +abs(x(i-1,j-1,1))+abs(x(i,j-1,1))+ep, * .5*(h(i-1,j ,1)+h(i,j,1))) v1(i,j,n3m)=vdyf(x(i-1,j,n3m),x(i,j,n3m),f1(i,j,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m)),ampd(1,j,1)*max0(2-itr,0)) * +vcorr(f1(i,j,n3m), * f2(i-1,j,n3m)+f2(i-1,j+1,n3m)+f2(i,j+1,n3m)+f2(i,j,n3m), * abs(x(i-1,j+1,n3m))+abs(x(i,j+1,n3m)) * -abs(x(i-1,j-1,n3m))-abs(x(i,j-1,n3m)), * abs(x(i-1,j+1,n3m))+abs(x(i,j+1,n3m)) * +abs(x(i-1,j-1,n3m))+abs(x(i,j-1,n3m))+ep, * .5*(h(i-1,j,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,np v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1)),ampd(1,1,1)*max0(2-itr,0)) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * -abs(x(i-1,-1,1))-abs(x(i,-1,1)), * abs(x(i-1, 2,1))+abs(x(i, 2,1)) * +abs(x(i-1,-1,1))+abs(x(i,-1,1))+ep, * .5*(h(i-1, 1,1)+h(i,1,1))) v1(i,1,n3m)=vdyf(x(i-1,1,n3m),x(i,1,n3m),f1(i,1,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m)),ampd(1,1,1)*max0(2-itr,0)) * +vcorr(f1(i,1,n3m), * f2(i-1,1,n3m)+f2(i-1,2,n3m)+f2(i,2,n3m)+f2(i,1,n3m), * abs(x(i-1, 2,n3m))+abs(x(i, 2,n3m)) * -abs(x(i-1,-1,n3m))-abs(x(i,-1,n3m)), * abs(x(i-1, 2,n3m))+abs(x(i, 2,n3m)) * +abs(x(i-1,-1,n3m))+abs(x(i,-1,n3m))+ep, * .5*(h(i-1,1,n3m)+h(i,1,n3m))) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i,1, 1 ) v1(i,n2m,n3m)=v1(i,1,n3m) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,np v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp+1,n3m) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) jllim = 1 + (1-ibcy)*botedge julim = mp + (-1+ibcy)*topedge illim = 1 + leftedge #else illim = 1 jllim = 1 julim = mp #endif do 511 k=2-ibcz,n3-2+ibcz do 511 j=jllim,julim do 511 i=illim,np 511 v1(i,j,k)=v1(i,j,k) * -vdiv1(f1(i-1,j,k),f1(i,j,k),f1(i+1,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f2(i-1,j+1,k),f2(i,j+1,k),f2(i-1,j,k), * f2(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f3(i-1,j,k+1),f3(i,j,k+1),f3(i-1,j,k), * f3(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) endif if(isor.eq.3) then #if (POLES == 0) illim = 1 + 2*leftedge iulim = np - 1*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 61 k=2-ibcz,n3-2+ibcz do 61 j=jllim,julim do 61 i=illim,iulim 61 v1(i,j,k)=v1(i,j,k) +vcor31(f1(i,j,k), 1 x(i-2,j,k),x(i-1,j,k),x(i,j,k),x(i+1,j,k), 1 .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if(leftedge.eq.1) then do k=2-ibcz,n3-2+ibcz do j=jllim,julim v1(2,j,k)=v1(2,j,k) +vcor31(f1(2,j,k), 1 x(-1,j,k),x(1,j,k),x(2,j,k),x(3,j,k), 1 .5*(h(1,j,k)+h(2,j,k))) end do end do end if if(rightedge.eq.1) then do k=2-ibcz,n3-2+ibcz do j=jllim,julim v1(np,j,k)=v1(np,j,k) +vcor31(f1(np,j,k), 1 x(np-2,j,k),x(np-1,j,k),x(np,j,k),x(np+2,j,k), 1 .5*(h(np-1,j,k)+h(np,j,k))) end do end do end if endif C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) illim = 1 + (2-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + 1*botedge julim = mp - 1*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 62 k=2,n3-2 do 62 j=jllim,julim do 62 i=illim,iulim 62 v1(i,j,k)=v1(i,j,k) 1 +vcor32(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k))-abs(x(i,j-1,k))-abs(x(i-1,j+1,k)) * +abs(x(i-1,j-1,k)), abs(x(i,j+1,k))+abs(x(i,j-1,k)) * +abs(x(i-1,j+1,k))+abs(x(i-1,j-1,k))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) 1 +vcor32(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i,j,k+1))-abs(x(i,j,k-1))-abs(x(i-1,j,k+1)) * +abs(x(i-1,j,k-1)), abs(x(i,j,k+1))+abs(x(i,j,k-1)) * +abs(x(i-1,j,k+1))+abs(x(i-1,j,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=v1(i,1,k) 1 +vcor32(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * abs(x(i,2,k))-abs(x(i,-1,k))-abs(x(i-1,2,k)) * +abs(x(i-1,-1,k)), abs(x(i,2,k))+abs(x(i,-1,k)) * +abs(x(i-1,2,k))+abs(x(i-1,-1,k))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) 1 +vcor32(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i,1,k+1))-abs(x(i,1,k-1))-abs(x(i-1,1,k+1)) * +abs(x(i-1,1,k-1)), abs(x(i,1,k+1))+abs(x(i,1,k-1)) * +abs(x(i-1,1,k+1))+abs(x(i-1,1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif end do end do end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ do 63 k=2,n3-2 do 63 j=jllim,julim do 63 i=illim,iulim 63 v1(i,j,k)=v1(i,j,k) + vcor33(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1, k)+f2(i,j+1, k)+f2(i,j,k), * f3(i-1,j,k)+f3(i-1,j ,k+1)+f3(i,j ,k+1)+f3(i,j,k), * abs(x(i-1,j+1,k+1))-abs(x(i-1,j-1,k+1)) * -abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i ,j+1,k+1))-abs(x(i ,j-1,k+1)) * -abs(x(i ,j+1,k-1))+abs(x(i ,j-1,k-1)), * abs(x(i-1,j+1,k+1))+abs(x(i-1,j-1,k+1)) * +abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i ,j+1,k+1))+abs(x(i ,j-1,k+1)) * +abs(x(i ,j+1,k-1))+abs(x(i ,j-1,k-1))+ep, * .5*(h(i-1,j,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=v1(i,1,k) + vcor33(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2, k)+f2(i,2, k)+f2(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * abs(x(i-1,2,k+1))-abs(x(i-1,-1,k+1)) * -abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i ,2,k+1))-abs(x(i ,-1,k+1)) * -abs(x(i ,2,k-1))+abs(x(i ,-1,k-1)), * abs(x(i-1,2,k+1))+abs(x(i-1,-1,k+1)) * +abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i ,2,k+1))+abs(x(i ,-1,k+1)) * +abs(x(i ,2,k-1))+abs(x(i ,-1,k-1))+ep, * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v1(i,j,1)=v1(i,j,1) 1 +vcor32(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * abs(x(i ,j+1,1))-abs(x(i ,j-1,1)) * -abs(x(i-1,j+1,1))+abs(x(i-1,j-1,1)), * abs(x(i ,j+1,1))+abs(x(i ,j-1,1)) * +abs(x(i-1,j+1,1))+abs(x(i-1,j-1,1))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) 1 +vcor32(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i ,j,2))-abs(x(i ,j,n3-2)) * -abs(x(i-1,j,2))+abs(x(i-1,j,n3-2)), * abs(x(i ,j,2))+abs(x(i ,j,n3-2)) * +abs(x(i-1,j,2))+abs(x(i-1,j,n3-2))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=v1(i,1,1) 1 +vcor32(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * abs(x(i ,2,1))-abs(x(i ,-1,1)) * -abs(x(i-1,2,1))+abs(x(i-1,-1,1)), * abs(x(i ,2,1))+abs(x(i ,-1,1)) * +abs(x(i-1,2,1))+abs(x(i-1,-1,1))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) 1 +vcor32(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i ,1,2))-abs(x(i ,1,n3-2)) * -abs(x(i-1,1,2))+abs(x(i-1,1,n3-2)), * abs(x(i ,1,2))+abs(x(i ,1,n3-2)) * +abs(x(i-1,1,2))+abs(x(i-1,1,n3-2))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif C----------------/ #endif /* POLES */ C----------------/ do j=jllim,julim do i=illim,iulim v1(i,j,1)=v1(i,j,1) + vcor33(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * abs(x(i-1,j+1, 2))-abs(x(i-1,j-1, 2)) * -abs(x(i-1,j+1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i ,j+1, 2))-abs(x(i ,j-1, 2)) * -abs(x(i ,j+1,n3-2))+abs(x(i ,j-1,n3-2)), * abs(x(i-1,j+1, 2))+abs(x(i-1,j-1, 2)) * +abs(x(i-1,j+1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i ,j+1, 2))+abs(x(i ,j-1, 2)) * +abs(x(i ,j+1,n3-2))+abs(x(i ,j-1,n3-2))+ep, * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=v1(i,1,1) + vcor33(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * abs(x(i-1,2, 2))-abs(x(i-1,-1, 2)) * -abs(x(i-1,2,n3-2))+abs(x(i-1,-1,n3-2)) * +abs(x(i ,2, 2))-abs(x(i ,-1, 2)) * -abs(x(i ,2,n3-2))+abs(x(i ,-1,n3-2)), * abs(x(i-1,2, 2))+abs(x(i-1,-1, 2)) * +abs(x(i-1,2,n3-2))+abs(x(i-1,-1,n3-2)) * +abs(x(i ,2, 2))+abs(x(i ,-1, 2)) * +abs(x(i ,2,n3-2))+abs(x(i ,-1,n3-2))+ep, * .5*(h(i-1,1,1)+h(i,1,1))) v1(i, 1 ,n3m)=v1(i, 1 ,1) #if (PARALLEL == 0) v1(i,n2m, 1 )=v1(i, 1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i, mp ,1) end do end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 endif ! isor=3 c---------------------------------------------- compute antidiffusive velocities in y direction c---------------------------------------------- #if (POLES == 0) jllim = 1 + botedge julim = mp illim = 1 + leftedge iulim = np - rightedge #else jllim = 1 + botedge julim = mp illim = 1 iulim = np #endif do 52 k=2,n3-2 do 52 j=jllim,julim do 52 i=illim,iulim 52 v2(i,j,k)=vdyf(x(i,j-1,k),x(i,j,k),f2(i,j,k), * .5*(h(i,j-1,k)+h(i,j,k)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(i,j,k), * f1(i,j-1,k)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j-1,k), * abs(x(i+1,j-1,k))+abs(x(i+1,j,k)) * -abs(x(i-1,j-1,k))-abs(x(i-1,j,k)), * abs(x(i+1,j-1,k))+abs(x(i+1,j,k)) * +abs(x(i-1,j-1,k))+abs(x(i-1,j,k))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f3(i,j-1,k)+f3(i,j,k)+f3(i,j,k+1)+f3(i,j-1,k+1), * abs(x(i,j-1,k+1))+abs(x(i,j,k+1)) * -abs(x(i,j-1,k-1))-abs(x(i,j,k-1)), * abs(x(i,j-1,k+1))+abs(x(i,j,k+1)) * +abs(x(i,j-1,k-1))+abs(x(i,j,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(1,j,k), * f1(1,j-1,k)+f1(1,j,k)+f1(2,j,k)+f1(2,j-1,k), * abs(x( 2,j-1,k))+abs(x( 2,j,k)) * -abs(x(-1,j-1,k))-abs(x(-1,j,k)), * abs(x( 2,j-1,k))+abs(x( 2,j,k)) * +abs(x(-1,j-1,k))+abs(x(-1,j,k))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * abs(x(1,j-1,k+1))+abs(x(1,j,k+1)) * -abs(x(1,j-1,k-1))-abs(x(1,j,k-1)), * abs(x(1,j-1,k+1))+abs(x(1,j,k+1)) * +abs(x(1,j-1,k-1))+abs(x(1,j,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=2,n3-2 do i=1,np v2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=2,n3-2 do i=1,np v2(i,mp+1,k)= 0. enddo enddo endif C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * -abs(x(i-1,j-1,1))-abs(x(i-1,j,1)), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * +abs(x(i-1,j-1,1))+abs(x(i-1,j,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f3(i,j-1,1)+f3(i,j,1)+f3(i,j,2)+f3(i,j-1,2), * abs(x(i,j-1, 2))+abs(x(i,j, 2)) * -abs(x(i,j-1,n3-2))-abs(x(i,j,n3-2)), * abs(x(i,j-1, 2))+abs(x(i,j, 2)) * +abs(x(i,j-1,n3-2))+abs(x(i,j,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * -abs(x(-1,j-1,1))-abs(x(-1,j,1)), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * +abs(x(-1,j-1,1))+abs(x(-1,j,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f3(1,j-1,1)+f3(1,j,1)+f3(1,j,2)+f3(1,j-1,2), * abs(x(1,j-1, 2))+abs(x(1,j, 2)) * -abs(x(1,j-1,n3-2))-abs(x(1,j,n3-2)), * abs(x(1,j-1, 2))+abs(x(1,j, 2)) * +abs(x(1,j-1,n3-2))+abs(x(1,j,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1-1,j, 1 )=v2( 1 ,j,1) v2(n1-1,j,n3m)=v2(n1-1,j,1) #endif enddo endif ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * -abs(x(i-1,j-1,1))-abs(x(i-1,j,1)), * abs(x(i+1,j-1,1))+abs(x(i+1,j,1)) * +abs(x(i-1,j-1,1))+abs(x(i-1,j,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=vdyf(x(i,j-1,n3m),x(i,j,n3m),f2(i,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(i,j,n3m), * f1(i,j-1,n3m)+f1(i,j,1)+f1(i+1,j,n3m)+f1(i+1,j-1,n3m), * abs(x(i+1,j-1,n3m))+abs(x(i+1,j,n3m)) * -abs(x(i-1,j-1,n3m))-abs(x(i-1,j,n3m)), * abs(x(i+1,j-1,n3m))+abs(x(i+1,j,n3m)) * +abs(x(i-1,j-1,n3m))+abs(x(i-1,j,n3m))+ep, * .5*(h(i,j-1,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * -abs(x(-1,j-1,1))-abs(x(-1,j,1)), * abs(x( 2,j-1,1))+abs(x( 2,j,1)) * +abs(x(-1,j-1,1))+abs(x(-1,j,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=vdyf(x(1,j-1,n3m),x(1,j,n3m),f2(1,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m)), * 0.5*(ampd(1,j,2)+ampd(1,j-1,2))*max0(2-itr,0)) * +vcorr(f2(1,j,n3m), * f1(1,j-1,n3m)+f1(1,j,n3m)+f1(2,j,n3m)+f1(2,j-1,n3m), * abs(x( 2,j-1,n3m))+abs(x( 2,j,n3m)) * -abs(x(-1,j-1,n3m))-abs(x(-1,j,n3m)), * abs(x( 2,j-1,n3m))+abs(x( 2,j,n3m)) * +abs(x(-1,j-1,n3m))+abs(x(-1,j,n3m))+ep, * .5*(h(1,j-1,n3m)+h(1,j,n3m))) #if (PARALLEL == 0) v2(n1-1,j, 1 )=v2(1,j, 1 ) v2(n1-1,j,n3m)=v2(1,j,n3m) #endif enddo endif ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,mp v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np+1,j,n3m) end do end if #endif endif !ibcx=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do i=1,np v2(i, 1 , 1 )= 0. v2(i, 1 ,n3m)= 0. enddo endif if (topedge.eq.1) then do i=1,np v2(i,mp+1, 1 )= 0. v2(i,mp+1,n3m )= 0. enddo endif C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + 1*botedge julim = mp #else jllim = 1 julim = mp + rightedge illim = 1 iulim = np #endif do 521 k=2-ibcz,n3-2+ibcz do 521 j=jllim,julim do 521 i=illim,iulim 521 v2(i,j,k)=v2(i,j,k) * -vdiv1(f2(i,j-1,k),f2(i,j,k),f2(i,j+1,k), * .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f1(i+1,j-1,k),f1(i+1,j,k),f1(i,j-1,k), * f1(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f3(i,j-1,k+1),f3(i,j,k+1),f3(i,j-1,k), * f3(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) endif if(isor.eq.3) then #if (POLES == 0) jllim = 1 + 2*botedge julim = mp - 1*topedge illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge #else jllim = 1 + 2*botedge julim = mp - 1*topedge illim = 1 iulim = np #endif do 71 k=2-ibcz,n3-2-ibcz do 71 j=jllim,julim do 71 i=illim,iulim 71 v2(i,j,k)=v2(i,j,k) +vcor31(f2(i,j,k), 1 x(i,j-2,k),x(i,j-1,k),x(i,j,k),x(i,j+1,k), 1 .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2-ibcz,n3-2+ibcz do i=illim,iulim v2(i,2,k)=v2(i,2,k) +vcor31(f2(i,2,k), 1 x(i,-1,k),x(i,1,k),x(i,2,k),x(i,3,k), 1 .5*(h(i,1,k)+h(i,2,k))) enddo enddo end if if (topedge.eq.1) then do k=2-ibcz,n3-2+ibcz do i=illim,iulim v2(i,mp,k)=v2(i,mp,k) +vcor31(f2(i,mp,k), 1 x(i,mp-2,k),x(i,mp-1,k),x(i,mp,k),x(i,mp+2,k), 1 .5*(h(i,mp-1,k)+h(i,mp,k))) enddo enddo end if endif !ibcy=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np v2(i,2,k)=v2(i,2,k) +vcor31(f2(i,2,k), 1 pbc*x(i,1-j3,k),x(i,1,k),x(i,2,k),x(i,3,k), 1 .5*(h(i,1,k)+h(i,2,k))) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np v2(i,mp,k)=v2(i,mp,k) +vcor31(f2(i,mp,k), 1 x(i,mp-2*j3,k),x(i,mp-j3,k),x(i,mp,k),pbc*x(i,mp+j3,k), 1 .5*(h(i,mp-j3,k)+h(i,mp,k))) end do end do end if C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) jllim = 1 + (2-ibcy)*botedge julim = mp - (1-ibcy)*topedge illim = 1 + leftedge iulim = np - rightedge #else jllim = 1+botedge julim = mp illim = 1 iulim = np #endif do 72 k=2,n3-2 do 72 j=jllim,julim do 72 i=illim,iulim 72 v2(i,j,k)=v2(i,j,k) 1 +vcor32(f2(i,j,k), * f1(i,j-1,k)+f1(i+1,j-1,k)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j,k))-abs(x(i-1,j,k))-abs(x(i+1,j-1,k)) * +abs(x(i-1,j-1,k)), abs(x(i+1,j,k))+abs(x(i-1,j,k)) * +abs(x(i+1,j-1,k))+abs(x(i-1,j-1,k))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) 1 +vcor32(f2(i,j,k), * f3(i,j-1,k)+f3(i,j-1,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i,j,k+1))-abs(x(i,j,k-1))-abs(x(i,j-1,k+1)) * +abs(x(i,j-1,k-1)), abs(x(i,j,k+1))+abs(x(i,j,k-1)) * +abs(x(i,j-1,k+1))+abs(x(i,j-1,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=v2(1,j,k) 1 +vcor32(f2(1,j,k), * f1(1,j-1,k)+f1(2,j-1,k)+f1(2,j,k)+f1(1,j,k), * abs(x( 2,j,k))-abs(x(-1,j,k))-abs(x(2,j-1,k)) * +abs(x(-1,j-1,k)), abs(x(2,j,k))+abs(x(-1,j,k)) * +abs(x(2,j-1,k))+abs(x(-1,j-1,k))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) 1 +vcor32(f2(1,j,k), * f3(1,j-1,k)+f3(1,j-1,k+1)+f3(1,j,k+1)+f3(1,j,k), * abs(x(1,j,k+1))-abs(x(1,j,k-1))-abs(x(1,j-1,k+1)) * +abs(x(1,j-1,k-1)), abs(x(1,j,k+1))+abs(x(1,j,k-1)) * +abs(x(1,j-1,k+1))+abs(x(1,j-1,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ do 73 k=2,n3-2 do 73 j=jllim,julim do 73 i=illim,iulim 73 v2(i,j,k)=v2(i,j,k) + vcor33(f2(i,j,k), * f1(i,j-1,k)+f1(i+1,j-1,k)+f1(i+1,j,k)+f1(i,j,k), * f3(i,j-1,k)+f3(i,j-1,k+1)+f3(i,j,k+1)+f3(i,j,k), * abs(x(i+1,j-1,k+1))-abs(x(i-1,j-1,k+1)) * -abs(x(i+1,j-1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1, j ,k+1))-abs(x(i-1, j ,k+1)) * -abs(x(i+1, j ,k-1))+abs(x(i-1, j ,k-1)), * abs(x(i+1,j-1,k+1))+abs(x(i-1,j-1,k+1)) * +abs(x(i+1,j-1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1, j ,k+1))+abs(x(i-1, j ,k+1)) * +abs(x(i+1, j ,k-1))+abs(x(i-1, j ,k-1))+ep, * .5*(h(i,j-1,k)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=v2(1,j,k) + vcor33(f2(1,j,k), * f1(1,j-1,k)+f1( 2 ,j-1,k)+f1( 2 ,j,k)+f1(1,j,k), * f3(1,j-1,k)+f3(1,j-1,k+1)+f3(1,j,k+1)+f3(1,j,k), * abs(x(2,j-1,k+1))-abs(x(-1,j-1,k+1)) * -abs(x(2,j-1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x(2, j ,k+1))-abs(x(-1, j ,k+1)) * -abs(x(2, j ,k-1))+abs(x(-1, j ,k-1)), * abs(x(2,j-1,k+1))+abs(x(-1,j-1,k+1)) * +abs(x(2,j-1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x(2, j ,k+1))+abs(x(-1, j ,k+1)) * +abs(x(2, j ,k-1))+abs(x(-1, j ,k-1))+ep, * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=v2(i,j,1) 1 +vcor32(f2(i,j,1), * f1(i,j-1,1)+f1(i+1,j-1,1)+f1(i+1,j,1)+f1(i,j,1), * abs(x(i+1,j,1))-abs(x(i-1,j,1))-abs(x(i+1,j-1,1)) * +abs(x(i-1,j-1,1)), abs(x(i+1,j,1))+abs(x(i-1,j,1)) * +abs(x(i+1,j-1,1))+abs(x(i-1,j-1,1))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) 1 +vcor32(f2(i,j,1), * f3(i,j-1,1)+f3(i,j-1, 2 )+f3(i,j, 2 )+f3(i,j,1), * abs(x(i,j,2))-abs(x(i,j,n3-2))-abs(x(i,j-1,2)) * +abs(x(i,j-1,n3-2)), abs(x(i,j,2))+abs(x(i,j,n3-2)) * +abs(x(i,j-1,2))+abs(x(i,j-1,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=v2(1,j,1) 1 +vcor32(f2(1,j,1), * f1(1,j-1,1)+f1(2,j-1,1)+f1(2,j,1)+f1(1,j,1), * abs(x(2,j,1))-abs(x(-1,j,1))-abs(x(2,j-1,1)) * +abs(x(-1,j-1,1)), abs(x(2,j,1))+abs(x(-1,j,1)) * +abs(x(2,j-1,1))+abs(x(-1,j-1,1))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) 1 +vcor32(f2(1,j,1), * f3(1,j-1,1)+f3(1,j-1,2)+f3(1,j,2)+f3(1,j,1), * abs(x(1,j,2))-abs(x(1,j,n3-2))-abs(x(1,j-1,2)) * +abs(x(1,j-1,n3-2)), abs(x(1,j,2))+abs(x(1,j,n3-2)) * +abs(x(1,j-1,2))+abs(x(1,j-1,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1m,j, 1 )=v2( 1 ,j,1) v2(n1m,j,n3m)=v2(n1m,j,1) #endif enddo endif #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ do j=jllim,julim do i=illim,iulim v2(i,j,1)=v2(i,j,1) + vcor33(f2(i,j,1), * f1(i,j-1,1)+f1(i+1,j-1,1)+f1(i+1,j,1)+f1(i,j,1), * f3(i,j-1,1)+f3( i ,j-1,2)+f3( i ,j,2)+f3(i,j,1), * abs(x(i+1,j-1, 2 ))-abs(x(i-1,j-1, 2 )) * -abs(x(i+1,j-1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i+1, j , 2 ))-abs(x(i-1, j , 2 )) * -abs(x(i+1, j ,n3-2))+abs(x(i-1, j ,n3-2)), * abs(x(i+1,j-1, 2 ))+abs(x(i-1,j-1, 2 )) * +abs(x(i+1,j-1,n3-2))+abs(x(i-1,j-1,n3-2)) * +abs(x(i+1, j , 2 ))+abs(x(i-1, j , 2 )) * +abs(x(i+1, j ,n3-2))+abs(x(i-1, j ,n3-2))+ep, * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=v2(1,j,1) + vcor33(f2(1,j,1), * f1(1,j-1,1)+f1(2,j-1,1)+f1(2,j,1)+f1(1,j,1), * f3(1,j-1,1)+f3(1,j-1,2)+f3(1,j,2)+f3(1,j,1), * abs(x(2,j-1, 2 ))-abs(x(-1,j-1, 2 )) * -abs(x(2,j-1,n3-2))+abs(x(-1,j-1,n3-2)) * +abs(x(2, j , 2 ))-abs(x(-1, j , 2 )) * -abs(x(2, j ,n3-2))+abs(x(-1, j ,n3-2)), * abs(x(2,j-1, 2 ))+abs(x(-1,j-1, 2 )) * +abs(x(2,j-1,n3-2))+abs(x(-1,j-1,n3-2)) * +abs(x(2, j , 2 ))+abs(x(-1, j , 2 )) * +abs(x(2, j ,n3-2))+abs(x(-1, j ,n3-2))+ep, * .5*(h(1,j-1,1)+h(1,j,1))) v2( 1 ,j,n3m)=v2( 1 ,j,1) #if (PARALLEL == 0) v2(n1m,j, 1 )=v2( 1 ,j,1) v2(n1m,j,n3m)=v2(n1m,j,1) #endif enddo endif #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2( np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 endif ! isor=3 c---------------------------------------------- compute antidiffusive velocities in z direction c---------------------------------------------- #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp - topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 53 k=2,n3m do 53 j=jllim,julim do 53 i=illim,iulim 53 v3(i,j,k)=vdyf(x(i,j,k-1),x(i,j,k),f3(i,j,k), * .5*(h(i,j,k-1)+h(i,j,k)),ampd(1,j,3)*max0(2-itr,0)) * +vcorr(f3(i,j,k), * f1(i,j,k-1)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j,k-1), * abs(x(i+1,j,k-1))+abs(x(i+1,j,k)) * -abs(x(i-1,j,k-1))-abs(x(i-1,j,k)), * abs(x(i+1,j,k-1))+abs(x(i+1,j,k)) * +abs(x(i-1,j,k-1))+abs(x(i-1,j,k))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k-1))+abs(x(i,j+1,k)) * -abs(x(i,j-1,k-1))-abs(x(i,j-1,k)), * abs(x(i,j+1,k-1))+abs(x(i,j+1,k)) * +abs(x(i,j-1,k-1))+abs(x(i,j-1,k))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3m do j=jllim,julim v3(1,j,k)=vdyf(x(1,j,k-1),x(1,j,k),f3(1,j,k), * .5*(h(1,j,k-1)+h(1,j,k)),ampd(1,j,3)*max0(2-itr,0)) * +vcorr(f3(1,j,k), * f1(1,j,k-1)+f1(1,j,k)+f1(2,j,k)+f1(2,j,k-1), * abs(x( 2,j,k-1))+abs(x( 2,j,k)) * -abs(x(-1,j,k-1))-abs(x(-1,j,k)), * abs(x( 2,j,k-1))+abs(x( 2,j,k)) * +abs(x(-1,j,k-1))+abs(x(-1,j,k))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * abs(x(1,j+1,k-1))+abs(x(1,j+1,k)) * -abs(x(1,j-1,k-1))-abs(x(1,j-1,k)), * abs(x(1,j+1,k-1))+abs(x(1,j+1,k)) * +abs(x(1,j-1,k-1))+abs(x(1,j-1,k))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1-1,j,k)=v3(1,j,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=2,n3m do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) end do end do end if #endif endif !ibcx=1 if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,1,k)=vdyf(x(i,1,k-1),x(i,1,k),f3(i,1,k), * .5*(h(i,1,k-1)+h(i,1,k)),ampd(1,1,3)*max0(2-itr,0)) * +vcorr(f3(i,1,k), * f1(i,1,k-1)+f1(i,1,k)+f1(i+1,1,k)+f1(i+1,1,k-1), * abs(x(i+1,1,k-1))+abs(x(i+1,1,k)) * -abs(x(i-1,1,k-1))-abs(x(i-1,1,k)), * abs(x(i+1,1,k-1))+abs(x(i+1,1,k)) * +abs(x(i-1,1,k-1))+abs(x(i-1,1,k))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * abs(x(i, 2,k-1))+abs(x(i, 2,k)) * -abs(x(i,-1,k-1))-abs(x(i,-1,k)), * abs(x(i, 2,k-1))+abs(x(i, 2,k)) * +abs(x(i,-1,k-1))+abs(x(i,-1,k))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) end do end do end if #endif if(ibcx.eq.1) then if (leftedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(1,1,k)=vdyf(x(1,1,k-1),x(1,1,k),f3(1,1,k), * .5*(h(1,1,k-1)+h(1,1,k)),ampd(1,1,3)*max0(2-itr,0)) * +vcorr(f3(1,1,k), * f1(1,1,k-1)+f1(1,1,k)+f1(2,1,k)+f1(2,1,k-1), * abs(x( 2,1,k-1))+abs(x( 2,1,k)) * -abs(x(-1,1,k-1))-abs(x(-1,1,k)), * abs(x( 2,1,k-1))+abs(x( 2,1,k)) * +abs(x(-1,1,k-1))+abs(x(-1,1,k))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * abs(x(1, 2,k-1))+abs(x(1, 2,k)) * -abs(x(1,-1,k-1))-abs(x(1,-1,k)), * abs(x(1, 2,k-1))+abs(x(1, 2,k)) * +abs(x(1,-1,k-1))+abs(x(1,-1,k))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m,n2m,k)=v3(1,1,k) v3(n1m, 1 ,k)=v3(1,1,k) v3( 1 ,n2m,k)=v3(1,1,k) #endif enddo end if #if (PARALLEL > 0) call update(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(np,mp,k)=v3(np+1,mp+1,k) end do end if if (rightedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(np,1,k)=v3(np+1,1,k) end do end if if (leftedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(1,mp,k)=v3(1,mp+1,k) end do end if #endif endif !ibcx=1 endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 531 k=2,n3m do 531 j=jllim,julim do 531 i=illim,iulim 531 v3(i,j,k)=v3(i,j,k) * -vdiv1(f3(i,j,k-1),f3(i,j,k),f3(i,j,k+1), * .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f1(i+1,j,k-1),f1(i+1,j,k),f1(i,j,k-1), * f1(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f2(i,j+1,k-1),f2(i,j+1,k),f2(i,j,k-1), * f2(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) endif if(isor.eq.3) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 81 k=3,n3-2 do 81 j=jllim,julim do 81 i=illim,iulim 81 v3(i,j,k)=v3(i,j,k) +vcor31(f3(i,j,k), 1 x(i,j,k-2),x(i,j,k-1),x(i,j,k),x(i,j,k+1), 1 .5*(h(i,j,k-1)+h(i,j,k))) if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v3(i,j,2)=v3(i,j,2) +vcor31(f3(i,j,2), 1 x(i,j,n3-2),x(i,j,1),x(i,j,2),x(i,j,3), 1 .5*(h(i,j,1)+h(i,j,2))) v3(i,j,n3-1)=v3(i,j,n3-1) +vcor31(f3(i,j,n3-1), 1 x(i,j,n3-3),x(i,j,n3-2),x(i,j,n3-1),x(i,j,2), 1 .5*(h(i,j,n3-2)+h(i,j,n3-1))) enddo enddo endif #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp - topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 82 k=3-ibcz,n3-2+ibcz do 82 j=jllim,julim do 82 i=illim,iulim 82 v3(i,j,k)=v3(i,j,k) 1 +vcor32(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * abs(x(i,j+1,k))-abs(x(i,j-1,k))-abs(x(i,j+1,k-1)) * +abs(x(i,j-1,k-1)), abs(x(i,j+1,k))+abs(x(i,j-1,k)) * +abs(x(i,j+1,k-1))+abs(x(i,j-1,k-1))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) 1 +vcor32(f3(i,j,k), * f1(i,j,k-1)+f1(i+1,j,k-1)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j,k))-abs(x(i-1,j,k))-abs(x(i+1,j,k-1)) * +abs(x(i-1,j,k-1)), abs(x(i+1,j,k))+abs(x(i-1,j,k)) * +abs(x(i+1,j,k-1))+abs(x(i-1,j,k-1))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,1,k)=v3(i,1,k) 1 +vcor32(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * abs(x(i,2,k))-abs(x(i,-1,k))-abs(x(i,2,k-1)) * +abs(x(i,-1,k-1)), abs(x(i,2,k))+abs(x(i,-1,k)) * +abs(x(i,2,k-1))+abs(x(i,-1,k-1))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) 1 +vcor32(f3(i,1,k), * f1(i,1,k-1)+f1(i+1,1,k-1)+f1(i+1,1,k)+f1(i,1,k), * abs(x(i+1,1,k))-abs(x(i-1,1,k))-abs(x(i+1,1,k-1)) * +abs(x(i-1,1,k-1)), abs(x(i+1,1,k))+abs(x(i-1,1,k)) * +abs(x(i+1,1,k-1))+abs(x(i-1,1,k-1))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 C----------------/ #endif /* POLES */ C----------------/ do 83 k=3-ibcz,n3-2+ibcz do 83 j=jllim,julim do 83 i=illim,iulim 83 v3(i,j,k)=v3(i,j,k) + vcor33(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * f1(i,j,k-1)+f1(i+1,j,k-1)+f1(i+1,j,k)+f1(i,j,k), * abs(x(i+1,j+1,k-1))-abs(x(i+1,j-1,k-1)) * -abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1,j+1, k ))-abs(x(i+1,j-1, k )) * -abs(x(i-1,j+1, k ))+abs(x(i-1,j-1, k )), * abs(x(i+1,j+1,k-1))+abs(x(i+1,j-1,k-1)) * +abs(x(i-1,j+1,k-1))+abs(x(i-1,j-1,k-1)) * +abs(x(i+1,j+1, k ))+abs(x(i+1,j-1, k )) * +abs(x(i-1,j+1, k ))+abs(x(i-1,j-1, k ))+ep, * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,1,k)=v3(i,1,k) + vcor33(f3(i,1,k), * f2(i,1,k-1)+f2(i, 2 ,k-1)+f2(i, 2 ,k)+f2(i,1,k), * f1(i,1,k-1)+f1(i+1,1,k-1)+f1(i+1,1,k)+f1(i,1,k), * abs(x(i+1,2,k-1))-abs(x(i+1,-1,k-1)) * -abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i+1,2, k ))-abs(x(i+1,-1, k )) * -abs(x(i-1,2, k ))+abs(x(i-1,-1, k )), * abs(x(i+1,2,k-1))+abs(x(i+1,-1,k-1)) * +abs(x(i-1,2,k-1))+abs(x(i-1,-1,k-1)) * +abs(x(i+1,2, k ))+abs(x(i+1,-1, k )) * +abs(x(i-1,2, k ))+abs(x(i-1,-1, k ))+ep, * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=3-ibcz,n3-2+ibcz do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif endif !ibcy=1 if(ibcx.eq.1) then if(leftedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(1,j,k)=v3(1,j,k) 1 +vcor32(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * abs(x(1,j+1, k ))-abs(x(1,j-1, k )) * -abs(x(1,j+1,k-1))+abs(x(1,j-1,k-1)), * abs(x(1,j+1, k ))+abs(x(1,j-1, k )) * +abs(x(1,j+1,k-1))+abs(x(1,j-1,k-1))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) 1 +vcor32(f3(1,j,k), * f1(1,j,k-1)+f1(2,j,k-1)+f1(2,j,k)+f1(1,j,k), * abs(x(2,j, k ))-abs(x(-1,j, k )) * -abs(x(2,j,k-1))+abs(x(-1,j,k-1)), * abs(x(2,j, k ))+abs(x(-1,j, k )) * +abs(x(2,j,k-1))+abs(x(-1,j,k-1))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo end if #endif if(ibcy.eq.1) then if ((leftedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,1,k)=v3(1,1,k) 1 +vcor32(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * abs(x(1,2,k))-abs(x(1,-1,k))-abs(x(1,2,k-1))+abs(x(1,-1,k-1)), * abs(x(1,2,k))+abs(x(1,-1,k))+abs(x(1,2,k-1))+abs(x(1,-1,k-1)) * +ep, * .5*(h(1,1,k-1)+h(1,1,k))) 1 +vcor32(f3(1,1,k), * f1(1,1,k-1)+f1(2,1,k-1)+f1(2,1,k)+f1(1,1,k), * abs(x(2,1,k))-abs(x(-1,1,k))-abs(x(2,1,k-1))+abs(x(-1,1,k-1)), * abs(x(2,1,k))+abs(x(-1,1,k))+abs(x(2,1,k-1))+abs(x(-1,1,k-1)) * +ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m, 1 ,k)=v3(1, 1 ,k) v3( 1 ,n2m,k)=v3(1, 1 ,k) v3(n1m,n2m,k)=v3(1,n2m,k) #endif enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if ((rightedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,1,k)=v3(np+1,1,k) enddo end if call updatebt(v3,np,mp,l+1,np,mp,1) if ((topedge.eq.1).and.(leftedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,mp,k)=v3(1,mp+1,k) enddo end if if ((topedge.eq.1).and.(rightedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,mp,k)=v3(np,mp+1,k) enddo end if #endif endif !ibcy=1 if(leftedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(1,j,k)=v3(1,j,k) + vcor33(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * f1(1,j,k-1)+f1(2, j ,k-1)+f1(2, j ,k)+f1(1,j,k), * abs(x( 2,j+1,k-1))-abs(x( 2,j-1,k-1)) * -abs(x(-1,j+1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x( 2,j+1, k ))-abs(x( 2,j-1, k )) * -abs(x(-1,j+1, k ))+abs(x(-1,j-1, k )), * abs(x( 2,j+1,k-1))+abs(x( 2,j-1,k-1)) * +abs(x(-1,j+1,k-1))+abs(x(-1,j-1,k-1)) * +abs(x( 2,j+1, k ))+abs(x( 2,j-1, k )) * +abs(x(-1,j+1, k ))+abs(x(-1,j-1, k ))+ep, * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=3-ibcz,n3-2+ibcz do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo end if #endif if(ibcy.eq.1) then if ((leftedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,1,k)=v3(1,1,k) + vcor33(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * f1(1,1,k-1)+f1(2,1,k-1)+f1(2,1,k)+f1(1,1,k), * abs(x( 2,2,k-1))-abs(x( 2,-1,k-1)) * -abs(x(-1,2,k-1))+abs(x(-1,-1,k-1)) * +abs(x( 2,2, k ))-abs(x( 2,-1, k )) * -abs(x(-1,2, k ))+abs(x(-1,-1, k )), * abs(x( 2,2,k-1))+abs(x( 2,-1,k-1)) * +abs(x(-1,2,k-1))+abs(x(-1,-1,k-1)) * +abs(x( 2,2, k ))+abs(x( 2,-1, k )) * +abs(x(-1,2, k ))+abs(x(-1,-1, k ))+ep, * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m, 1 ,k)=v3(1, 1 ,k) v3( 1 ,n2m,k)=v3(1, 1 ,k) v3(n1m,n2m,k)=v3(1,n2m,k) #endif enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if ((rightedge.eq.1).and.(botedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,1,k)=v3(np+1,1,k) enddo end if call updatebt(v3,np,mp,l+1,np,mp,1) if ((topedge.eq.1).and.(leftedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(1,mp,k)=v3(1,mp+1,k) enddo end if if ((topedge.eq.1).and.(rightedge.eq.1)) then do k=3-ibcz,n3-2+ibcz v3(np,mp,k)=v3(np,mp+1,k) enddo end if #endif endif !ibcy=1 endif !ibcx=1 C----------------/ #endif /* POLES */ C----------------/ endif !isor=3 #if (POLES == 0) COLD if (ibcx.eq.1) then COLD do k=1,n3m COLD do j=1,n2m COLD v1(1 ,j,k)=v1(n1m,j,k) COLD v1(n1,j,k)=v1(2 ,j,k) COLD end do COLD end do COLD end if COLD if (ibcy.eq.1) then COLD do k=1,n3m COLD do i=1,n1m COLD v2(i, 1,k)=v2(i,n2m,k) COLD v2(i,n2,k)=v2(i,2 ,k) COLD end do COLD end do COLD end if #else call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if #endif COLD if (iflg.ne.8) then COLD do j=1,n2m COLD do i=1,n1m COLD v3(i,j, 1)=-v3(i,j, 2)*(1-ibcz)+v3(i,j,n3m)*ibcz COLD v3(i,j,n3)=-v3(i,j,n3m)*(1-ibcz)+v3(i,j, 2 )*ibcz COLD enddo COLD enddo COLD end if if(nonos.eq.1) then c non-osscilatory option C----------------/ #if (POLES == 0) C----------------/ do 401 k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do 401 j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - j3 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + j3 end if do 401 i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) 401 mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) C----------------/ #else /* POLES */ C----------------/ do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do j=jllim2,julim2 jm = j - j3 jp = j + j3 do i=1,np im = i - 1 ip = i + 1 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k),x(i+1,1,k),mx(i,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k),x(i+1,1,k),mn(i,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k),mx(i,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k),mn(i,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) illim = 1 + leftedge #else illim = 1 #endif do 402 k=1,n3m do 402 j=1,mp do 402 i=illim,np 402 f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) C----------------/ #if (POLES == 0) C----------------/ if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1,j,k)=f1(-1,j,k)*ibcx end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=f1(np+3,j,k)*ibcx end do end do end if C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) #endif #if (POLES == 0) jllim = 1 + 1*botedge #else jllim = 1 #endif do 403 k=1,n3m do 403 j=jllim,mp do 403 i=1,np 403 f2(i,j,k)=donor(x(i,j-1,k),x(i,j,k),v2(i,j,k)) C----------------/ #if (POLES == 0) C----------------/ if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=f2(i,-1,k)*ibcy end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k)*ibcy end do end do end if C----------------/ #else /* POLES */ C----------------/ if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 4033 k=2,n3m do 4033 j=1,mp do 4033 i=1,np 4033 f3(i,j,k)=donor(x(i,j,k-1),x(i,j,k),v3(i,j,k)) if (iprec.eq.1) then do j=1,mp do i=1,np f3(i,j, 1)=0. f3(i,j,n3)=0. enddo enddo else do j=1,mp do i=1,np f3(i,j, 1)=-f3(i,j, 2 )*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2 )*ibcz enddo enddo endif do 404 k=1,n3m do 404 j=1,mp do 404 i=1,np cp(i,j,k)=(mx(i,j,k)-x(i,j,k))*h(i,j,k)/ 1( pn(f1(i+1,j,k))+pp(f1(i,j,k)) 2 +pn(f2(i,j+1,k))+pp(f2(i,j,k)) 3 +pn(f3(i,j,k+1))+pp(f3(i,j,k))+ep) cn(i,j,k)=(x(i,j,k)-mn(i,j,k))*h(i,j,k)/ 1( pp(f1(i+1,j,k))+pn(f1(i,j,k)) 2 +pp(f2(i,j+1,k))+pn(f2(i,j,k)) 3 +pp(f3(i,j,k+1))+pn(f3(i,j,k))+ep) 404 continue call update2(cp,np,mp,l,np,mp,1) call update2(cn,np,mp,l,np,mp,1) do k=1,n3m do j=1,mp do i=illim,np v1(i,j,k)=pp(v1(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i-1,j,k))*pp(sign(1., x(i-1,j,k))) 1 +amin1(1.,cp(i-1,j,k),cn(i,j,k))*pp(sign(1.,-x(i-1,j,k))) ) 2 -pn(v1(i,j,k))* 2 ( amin1(1.,cp(i-1,j,k),cn(i,j,k))*pp(sign(1., x(i ,j,k ))) 2 +amin1(1.,cp(i,j,k),cn(i-1,j,k))*pp(sign(1.,-x(i ,j,k ))) ) enddo enddo enddo do k=1,n3m do j=jllim,mp do i=1,np v2(i,j,k)=pp(v2(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i,j-1,k))*pp(sign(1., x(i,j-1,k))) 1 +amin1(1.,cp(i,j-1,k),cn(i,j,k))*pp(sign(1.,-x(i,j-1,k))) ) 1 -pn(v2(i,j,k))* 2 ( amin1(1.,cp(i,j-1,k),cn(i,j,k))*pp(sign(1., x(i,j ,k))) 2 +amin1(1.,cp(i,j,k),cn(i,j-1,k))*pp(sign(1.,-x(i,j ,k))) ) enddo enddo enddo do k=2,n3m do j=1,mp do i=1,np v3(i,j,k)=pp(v3(i,j,k))* 1 ( amin1(1.,cp(i,j,k),cn(i,j,k-1))*pp(sign(1., x(i,j,k-1))) 1 +amin1(1.,cp(i,j,k-1),cn(i,j,k))*pp(sign(1.,-x(i,j,k-1))) ) 1 -pn(v3(i,j,k))* 2 ( amin1(1.,cp(i,j,k-1),cn(i,j,k))*pp(sign(1., x(i,j,k ))) 2 +amin1(1.,cp(i,j,k),cn(i,j,k-1))*pp(sign(1.,-x(i,j,k ))) ) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) end do end do end if end if if (ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3 ,k) end do end do end if end if C----------------/ #else /* POLES */ C----------------/ call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ if (iprec.eq.1) then do j=1,mp do i=1,np v3(i,j, 1)=0. v3(i,j,n3)=0. enddo enddo else do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2 )*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz enddo enddo endif 30 continue 6 continue call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(34) #endif return end subroutine mpdatm3(u1,u2,u3,x,h,iflg) include 'param.nml' include 'msg.inc' parameter(nonos=1,idiv=0) dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . u3(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+1+2*ih)*l) parameter(iv3f3=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ibcxa=(mp+2*ih)*l,ibcya=(np+2*ih)*l) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+iv3f3+ibcxa+ibcya)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+1+ih, l), . v3(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+1+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(1-ih:mp+ih, l, 2), . bcy(1-ih:np+ih, l, 2), . scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/diffus/ sk(l),skr(l),sls data ep/1.e-10/ c pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 rat2(z1,z2)=(z2-z1)*.5 rat4(z0,z1,z2,z3)=(z3+z2-z1-z0)*.25 vdyf(x1,x2,a,r)=(abs(a)-a**2/r)*rat2(x1,x2) cex vdyf(x1,x2,a,r)=(abs(a)-a**2/r+2.*ampd*r)*rat2(x1,x2) vcorr(a,b,y0,y1,y2,y3,r)=-0.125*a*b/r*rat4(y0,y1,y2,y3) vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r c #if (TIMEPLT == 1) call ttbeg(35) #endif ! do j=1,mp ! do i=1,np ! if(iflg.eq.31.or.iflg.eq.32) then !mod bbc ! x(i,j, 1) = 0 ! x(i,j,l) = 0. ! endif ! if(iflg.eq.33) then ! x(i,j,1) = x(i,j,2) ! x(i,j,l) = x(i,j,l-1) ! endif ! end do ! end do call update(x,np,mp,l,np,mp,iup) iboz=1-ibcz #if (POLES == 0) ibox=1-ibcx iboy=1-ibcy ibcxy=ibcx*ibcy #else ibox=0 iboy=0 ibcxy=1 #endif itmx=2-liner iprec=0 c if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib pbc=1. c if(iflg.eq.2.or.iflg.eq.3) pbc=pflip if(iflg.eq.2.or.iflg.eq.3.or.iflg.eq.31.or.iflg.eq.32) pbc=pflip do k=2,n3m do j=1,mp do i=1,np v3(i,j,k) = u3(i,j,k) enddo end do end do do j=1,mp do i=1,np v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,n3m do j=1,mp do i=illim,iulim v1(i,j,k) = u1(i,j,k) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1( 1,j,k) = ubc(j,k,1) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k) = ubc(j,k,2) end do end do end if C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + botedge julim = mp do k=1,n3m do j=jllim,julim do i=1,np v2(i,j,k) = u2(i,j,k) end do end do end do if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k) = vbc(i,k,1) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k) = vbc(i,k,2) end do end do end if if (nonos.eq.1) then C----------------/ #if (POLES == 0) C----------------/ do k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+(1-ibcz)*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+(1-ibcz)*min0(k+1,n3m) do j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - j3 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + j3 end if do i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do C----------------/ #else /* POLES */ C----------------/ jllim2 = 1 + botedge julim2 = mp - topedge do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do j=jllim2,julim2 jm = j - j3 jp = j + j3 do i=1,np im = i - 1 ip = i + 1 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ endif c1=1. c2=0. do 30 itr=1,itmx if((itr.eq.1).and.(ibcxy.eq.0)) . call mp3bc(x,iflg,bcx,bcy,np,mp,n3m) COLD call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) illim = 1 + leftedge iulim = np #else illim = 1 iulim = np #endif do k=1,n3m do j=1,mp do i=illim,iulim f1(i,j,k)=donor(c1*x(i-1,j,k)+c2,c1*x(i,j,k)+c2,v1(i,j,k)) end do end do end do c if(itr.eq.1.and.kampd(1).ne.0) then c if(itr.eq.itmx) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=1,n3m do j=1,mp do i=illim,iulim c ampdx=c1*ampd(1,j,1)*0.5*(h(i,j,k)+h(i-1,j,k)) ampdx=sk(k)*0.5*(h(i,j,k)+h(i-1,j,k))*dt*dxi**2 f1(i,j,k)=f1(i,j,k)-ampdx*(x(i,j,k)-x(i-1,j,k)) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=f1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=f1(np+3,j,k) end do end do end if else if (leftedge.eq.1) then do k=1,n3m do j=1,mp c special icylind, tank c f1(1 ,j,k)=-f1(2,j,k) f1(1 ,j,k)=donor(c1*bcx(j,k,1)+c2,c1*x(1,j,k)+c2,v1(1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp c special tank c f1(np+1,j,k)=-f1(np,j,k) f1(np+1,j,k)= . donor(c1*x(np,j,k)+c2,c1*bcx(j,k,2)+c2,v1(np+1,j,k)) end do end do end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif C----------------/ #else /* POLES */ C----------------/ call updatelr(f1,np,mp,l,np+1,mp,1) C----------------/ #endif /* POLES */ C----------------/ jllim = 1 + botedge julim = mp do k=1,n3m do j=jllim,julim do i=1,np f2(i,j,k)=donor(c1*x(i,j-1,k)+c2,c1*x(i,j,k)+c2,v2(i,j,k)) end do end do end do c if(itr.eq.1.and.kampd(2).ne.0) then c if(itr.eq.itmx) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=1,n3m do j=jllim,julim do i=1,np c ampdy=c1*0.5*(ampd(1,j,2)+ampd(1,j-1,2)) c & *0.5*( h(i,j,k)+ h(i,j-1,k)) ampdy=sk(k)*0.5*( h(i,j,k)+ h(i,j-1,k))*dt*dyi**2 f2(i,j,k)=f2(i,j,k)-ampdy*(x(i,j,k)-x(i,j-1,k)) enddo enddo enddo endif C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=f2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k) end do end do end if else if (botedge.eq.1) then do k=1,n3m do i=1,np c f2(i,1,k)=donor(c1*bcy(i,k,1)+c2,c1*x(i,1,k)+c2,v2(i,1,k)) f2(i,1,k)=-f2(i,2,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np c f2(i,mp+1,k)= c . donor(c1*x(i,mp,k)+c2,c1*bcy(i,k,2)+c2,v2(i,mp+1,k)) f2(i,mp+1,k)=-f2(i,mp,k) end do end do end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if endif C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=1,l do i=1,np f2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=1,l do i=1,np f2(i,mp+1,k)= 0. enddo enddo endif if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ do 333 k=2,n3m do 333 j=1,mp do 333 i=1,np 333 f3(i,j,k)=donor(c1*x(i,j,k-1)+c2,c1*x(i,j,k)+c2,v3(i,j,k)) c if(itr.eq.1.and.kampd(3).ne.0) then c if(itr.eq.itmx) then if(itr.eq.0) then !modif no explicit diff in mpdata do k=2,n3m do j=1,mp do i=1,np c ampdz=c1*ampd(1,j,3)*0.5*(h(i,j,k)+h(i,j,k-1)) ampdz=sk(k)*0.5*(h(i,j,k)+h(i,j,k-1))*dt*dzi**2 f3(i,j,k)=f3(i,j,k)-ampdz*(x(i,j,k)-x(i,j,k-1)) enddo enddo enddo endif if (iprec.eq.1) then do j=1,mp do i=1,np f3(i,j, 1)=donor(c1*x(i,j, 1 )+c2,c1*x(i,j, 1 )+c2,v3(i,j,1 )) f3(i,j,n3)=donor(c1*x(i,j,n3m)+c2,c1*x(i,j,n3m)+c2,v3(i,j,n3)) end do end do else do j=1,mp do i=1,np if (iflg.eq.0) then c if (itr.eq.itmx.and.iflg.eq.1) then c-------- special for solar luminosity dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) gacbt=1./(gi(i,j)*gmus(1)) + *((1-icylind)*gmm(i,j,1)**2*cosa(i,j) + +icylind*gmm(i,j,1))*dnmi * dt*dzi hfbt=hf00 gactp=1./(gi(i,j)*gmus(n3m)) + *((1-icylind)*gmm(i,j,n3m)**2*cosa(i,j) + +icylind*gmm(i,j,n3m))*dnmi * dt*dzi hftp=hf00*(gacbt/gactp) C + *23. f3(i,j, 1)=2.*hfbt*gacbt-f3(i,j, 2) f3(i,j,n3)=2.*hftp*gactp-f3(i,j,n3m) c f3(i,j,n3)= f3(i,j,n3m) else f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2)*ibcz endif enddo enddo end if do k=1,n3m do j=1,mp do i=1,np x(i,j,k)=x(i,j,k)-( f1(i+1,j,k)-f1(i,j,k) . +f2(i,j+1,k)-f2(i,j,k) . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k) end do end do end do if(itr.eq.itmx) go to 6 c1=0. c2=1. #if (POLES == 0) iulim = np + rightedge julim = mp + topedge #else iulim = np julim = mp + topedge #endif do k=1,n3m do j=1,mp do i=1,iulim f1(i,j,k)=v1(i,j,k) v1(i,j,k)=0. end do end do end do do k=1,n3m do j=1,julim do i=1,np f2(i,j,k)=v2(i,j,k) v2(i,j,k)=0. end do end do end do do k=1,n3 do j=1,mp do i=1,np f3(i,j,k)=v3(i,j,k) v3(i,j,k)=0. end do end do end do call update(x,np,mp,l,np,mp,iup) #if (POLES == 0) if (rightedge.eq.0) then call update(f1,np,mp,l,np+1,mp,1) else call update(f1,np+1,mp,l,np+1,mp,1) end if #else call update(f1,np,mp,l,np+1,mp,1) #endif if (topedge.eq.0) then call update(f2,np,mp,l,np,mp+1,1) else call update(f2,np,mp+1,l,np,mp+1,1) end if call update(f3,np,mp,l+1,np,mp,1) c---------------------------------------------- compute antidiffusive velocities in x direction c---------------------------------------------- #if (POLES == 0) illim = 1 + leftedge iulim = np jllim = 1 + j3*botedge julim = mp - j3*topedge #else illim = 1 iulim = np jllim = 1 + j3*botedge julim = mp - j3*topedge #endif do k=2,n3-2 do j=jllim,julim do i=illim,iulim v1(i,j,k)=vdyf(x(i-1,j,k),x(i,j,k),f1(i,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * x(i-1,j-1,k),x(i,j-1,k),x(i-1,j+1,k),x(i,j+1,k), * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * x(i-1,j,k-1),x(i,j,k-1),x(i-1,j,k+1),x(i,j,k+1), * .5*(h(i-1,j,k)+h(i,j,k))) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=vdyf(x(i-1,1,k),x(i,1,k),f1(i,1,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * x(i-1,-1,k),x(i,-1,k),x(i-1,2,k),x(i,2,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * x(i-1,1,k-1),x(i,1,k-1),x(i-1,1,k+1),x(i,1,k+1), * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif end if C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=vdyf(x(i-1,1,k),x(i,1,k),f1(i,1,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * pbc*x(i-1,1-j3,k),pbc*x(i,1-j3,k), * x(i-1,2,k),x(i,2,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * x(i-1,1,k-1),x(i,1,k-1),x(i-1,1,k+1),x(i,1,k+1), * .5*(h(i-1,1,k)+h(i,1,k))) enddo enddo end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=vdyf(x(i-1,mp,k),x(i,mp,k),f1(i,mp,k), * .5*(h(i-1,mp,k)+h(i,mp,k))) * +vcorr(f1(i,mp,k), * f2(i-1,mp,k)+f2(i-1,mp+j3,k)+f2(i,mp+j3,k)+f2(i,mp,k), * x(i-1,mp-j3,k),x(i,mp-j3,k), * pbc*x(i-1,mp+j3,k),pbc*x(i,mp+j3,k), * .5*(h(i-1,mp,k)+h(i,mp,k))) * +vcorr(f1(i,mp,k), * f3(i-1,mp,k)+f3(i-1,mp,k+1)+f3(i,mp,k+1)+f3(i,mp,k), * x(i-1,mp,k-1),x(i,mp,k-1),x(i-1,mp,k+1),x(i,mp,k+1), * .5*(h(i-1,mp,k)+h(i,mp,k))) enddo enddo end if C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * x(i-1,j-1,1),x(i,j-1,1),x(i-1,j+1,1),x(i,j+1,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * x(i-1,j,n3-2),x(i,j,n3-2),x(i-1,j,2),x(i,j,2), * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * x(i-1,-1,1),x(i,-1,1),x(i-1,2,1),x(i,2,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * x(i-1,1,n3-2),x(i,1,n3-2),x(i-1,1,2),x(i,1,2), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n3m)=v1(i,1,1) #if (PARALLEL == 0) v1(i,n2m, 1)=v1(i,1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp ,1) enddo end if #endif endif !ibcy=1 C----------------/ #endif /* no POLES=1 for ibcz=1 */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,iulim v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * x(i-1,j-1,1),x(i,j-1,1),x(i-1,j+1,1),x(i,j+1,1), * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=vdyf(x(i-1,j,n3m),x(i,j,n3m),f1(i,j,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m))) * +vcorr(f1(i,j,n3m), * f2(i-1,j,n3m)+f2(i-1,j+1,n3m)+f2(i,j+1,n3m)+f2(i,j,n3m), * x(i-1,j-1,n3m),x(i,j-1,n3m),x(i-1,j+1,n3m),x(i,j+1,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * x(i-1,-1,1),x(i,-1,1),x(i-1,2,1),x(i,2,1), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n3m)=vdyf(x(i-1,1,n3m),x(i,1,n3m),f1(i,1,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) * +vcorr(f1(i,1,n3m), * f2(i-1,1,n3m)+f2(i-1,2,n3m)+f2(i,2,n3m)+f2(i,1,n3m), * x(i-1,-1,n3m),x(i,-1,n3m),x(i-1,2,n3m),x(i,2,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) #if (PARALLEL == 0) v1(i,n2m, 1)=v1(i,1 ,1) v1(i,n2m,n3m)=v1(i,1,n3m) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp+1,n3m) enddo end if #endif endif !ibcy=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * pbc*x(i-1,1-j3,1),pbc*x(i,1-j3,1), * x(i-1,2,1),x(i,2,1), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n3m)=vdyf(x(i-1,1,n3m),x(i,1,n3m),f1(i,1,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) * +vcorr(f1(i,1,n3m), * f2(i-1,1,n3m)+f2(i-1,2,n3m)+f2(i,2,n3m)+f2(i,1,n3m), * pbc*x(i-1,1-j3,n3m),pbc*x(i,1-j3,n3m), * x(i-1,2,n3m),x(i,2,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) enddo end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp,1)=vdyf(x(i-1,mp,1),x(i,mp,1),f1(i,mp,1), * .5*(h(i-1,mp,1)+h(i,mp,1))) * +vcorr(f1(i,mp,1), * f2(i-1,mp,1)+f2(i-1,mp+1,1) * +f2(i,mp+1,1)+f2(i,mp,1), * x(i-1,mp-j3,1),x(i,mp-j3,1), * pbc*x(i-1,mp+j3,1),pbc*x(i,mp+j3,1), * .5*(h(i-1,mp,1)+h(i,mp,1))) v1(i,mp,n3m)=vdyf(x(i-1,mp,n3m),x(i,mp,n3m),f1(i,mp,n3m), * .5*(h(i-1,mp,n3m)+h(i,mp,n3m))) * +vcorr(f1(i,mp,n3m), * f2(i-1,mp,n3m)+f2(i-1,mp+j3,n3m) * +f2(i,mp+j3,n3m)+f2(i,mp,n3m), * x(i-1,mp-j3,n3m),x(i,mp-j3,n3m), * pbc*x(i-1,mp+j3,n3m),pbc*x(i,mp+j3,n3m), * .5*(h(i-1,mp,n3m)+h(i,mp,n3m))) enddo end if C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) illim = 1 + leftedge iulim = np jllim = 1 + iboy*botedge julim = mp - iboy*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 511 k=2-ibcz,n3-2+ibcz do 511 j=jllim,julim do 511 i=illim,iulim v1d=-vdiv1(f1(i-1,j,k),f1(i,j,k),f1(i+1,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f2(i-1,j+1,k),f2(i,j+1,k),f2(i-1,j,k), * f2(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f3(i-1,j,k+1),f3(i,j,k+1),f3(i-1,j,k), * f3(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) 511 v1(i,j,k)=v1(i,j,k)+(pp(v1d)*x(i-1,j,k)-pn(v1d)*x(i,j,k)) endif c---------------------------------------------- compute antidiffusive velocities in y direction c---------------------------------------------- #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp #else illim = 1 iulim = np jllim = 1 + botedge julim = mp #endif do k=2,n3-2 do j=jllim,julim do i=illim,iulim v2(i,j,k)=vdyf(x(i,j-1,k),x(i,j,k),f2(i,j,k), * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f1(i,j-1,k)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j-1,k), * x(i-1,j-1,k),x(i-1,j,k),x(i+1,j-1,k),x(i+1,j,k), * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f3(i,j-1,k)+f3(i,j,k)+f3(i,j,k+1)+f3(i,j-1,k+1), * x(i,j-1,k-1),x(i,j,k-1),x(i,j-1,k+1),x(i,j,k+1), * .5*(h(i,j-1,k)+h(i,j,k))) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f1(1,j-1,k)+f1(1,j,k)+f1(2,j,k)+f1(2,j-1,k), * x(-1,j-1,k),x(-1,j,k),x(2,j-1,k),x(2,j,k), * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * x(1,j-1,k-1),x(1,j,k-1),x(1,j-1,k+1),x(1,j,k+1), * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif end do end do end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif else !ibcx=0 if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * x(1,j-1,k-1),x(1,j,k-1),x(1,j-1,k+1),x(1,j,k+1), * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) v2(n1m,j,k)=vdyf(x(n1m,j-1,k),x(n1m,j,k),f2(n1m,j,k), * .5*(h(n1m,j-1,k)+h(n1m,j,k))) * +vcorr(f2(n1m,j,k), * f3(n1m,j-1,k)+f3(n1m,j,k)+f3(n1m,j,k+1)+f3(n1m,j-1,k+1), * x(n1m,j-1,k-1),x(n1m,j,k-1),x(n1m,j-1,k+1),x(n1m,j,k+1), * .5*(h(n1m,j-1,k)+h(n1m,j,k))) #endif end do end do end if #if (PARALLEL > 0) if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=vdyf(x(np,j-1,k),x(np,j,k),f2(np,j,k), * .5*(h(np,j-1,k)+h(np,j,k))) * +vcorr(f2(np,j,k), * f3(np,j-1,k)+f3(np,j,k)+f3(np,j,k+1)+f3(np,j-1,k+1), * x(np,j-1,k-1),x(np,j,k-1),x(np,j-1,k+1),x(np,j,k+1), * .5*(h(np,j-1,k)+h(np,j,k))) end do end do end if #endif end if !ibcx test C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=2,n3-2 do i=1,np v2(i, 1 ,k)= 0. enddo enddo endif if (topedge.eq.1) then do k=2,n3-2 do i=1,np v2(i,mp+j3,k)= 0. enddo enddo endif C----------------/ #endif /* POLES */ C----------------/ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * x(i-1,j-1,1),x(i-1,j,1),x(i+1,j-1,1),x(i+1,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f3(i,j-1,1)+f3(i,j,1)+f3(i,j,2)+f3(i,j-1,2), * x(i,j-1,n3-2),x(i,j,n3-2),x(i,j-1,2),x(i,j,2), * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * x(-1,j-1,1),x(-1,j,1),x(2,j-1,1),x(2,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f3(1,j-1,1)+f3(1,j,1)+f3(1,j,2)+f3(1,j-1,2), * x(1,j-1,n3-2),x(1,j,n3-2),x(1,j-1,2),x(1,j,2), * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=v2(1,j,1) #if (PARALLEL == 0) v2(n1-1,j,1)=v2(1,j,1) v2(n1-1,j,n3m)=v2(n1-1,j,1) #endif enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np ,j,1) end do end if #endif endif !ibcx=1 C----------------/ #endif /* no POLES=1 for ibcz=1 */ C----------------/ else !ibcz test do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * x(i-1,j-1,1),x(i-1,j,1),x(i+1,j-1,1),x(i+1,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=vdyf(x(i,j-1,n3m),x(i,j,n3m),f2(i,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m))) * +vcorr(f2(i,j,n3m), * f1(i,j-1,n3m)+f1(i,j,n3m)+f1(i+1,j,n3m)+f1(i+1,j-1,n3m), * x(i-1,j-1,n3m),x(i-1,j,n3m),x(i+1,j-1,n3m),x(i+1,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m))) enddo enddo C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * x(-1,j-1,1),x(-1,j,1),x(2,j-1,1),x(2,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=vdyf(x(1,j-1,n3m),x(1,j,n3m),f2(1,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m))) * +vcorr(f2(1,j,n3m), * f1(1,j-1,n3m)+f1(1,j,n3m)+f1(2,j,n3m)+f1(2,j-1,n3m), * x(-1,j-1,n3m),x(-1,j,n3m),x(2,j-1,n3m),x(2,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m))) #if (PARALLEL == 0) v2(n1-1,j,1)=v2(1,j,1) v2(n1-1,j,n3m)=v2(1,j,n3m) #endif enddo end if ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np+1,j,n3m) end do end if #endif endif !ibcx=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do i=1,np v2(i, 1 ,1 )= 0. v2(i, 1 ,n3m)= 0. enddo endif if (topedge.eq.1) then do i=1,np v2(i,mp+j3,1 )= 0. v2(i,mp+j3,n3m)= 0. enddo endif C----------------/ #endif /* POLES */ C----------------/ endif !ibcz=1 if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge jllim = 1 + j3*botedge julim = mp #else illim = 1 iulim = np jllim = 1 julim = mp + j3*topedge #endif do 521 k=2-ibcz,n3-2+ibcz do 521 j=jllim,julim do 521 i=illim,iulim v2d=-vdiv1(f2(i,j-1,k),f2(i,j,k),f2(i,j+1,k), * .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f1(i+1,j-1,k),f1(i+1,j,k),f1(i,j-1,k), * f1(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f3(i,j-1,k+1),f3(i,j,k+1),f3(i,j-1,k), * f3(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) 521 v2(i,j,k)=v2(i,j,k)+(pp(v2d)*x(i,j-1,k)-pn(v2d)*x(i,j,k)) endif c---------------------------------------------- compute antidiffusive velocities in z direction c---------------------------------------------- #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp - topedge #else illim = 1 iulim = np jllim = 1 + botedge julim = mp - topedge #endif do 53 k=2,n3m do 53 j=jllim,julim do 53 i=illim,iulim 53 v3(i,j,k)=vdyf(x(i,j,k-1),x(i,j,k),f3(i,j,k), * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f1(i,j,k-1)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j,k-1), * x(i-1,j,k-1),x(i-1,j,k),x(i+1,j,k-1),x(i+1,j,k), * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * x(i,j-1,k-1),x(i,j-1,k),x(i,j+1,k-1),x(i,j+1,k), * .5*(h(i,j,k-1)+h(i,j,k))) C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3m do j=jllim,julim v3(1,j,k)=vdyf(x(1,j,k-1),x(1,j,k),f3(1,j,k), * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f1(1,j,k-1)+f1(1,j,k)+f1(2,j,k)+f1(2,j,k-1), * x(-1,j,k-1),x(-1,j,k),x(2,j,k-1),x(2,j,k), * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * x(1,j-1,k-1),x(1,j-1,k),x(1,j+1,k-1),x(1,j+1,k), * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=2,n3m do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo endif #endif end if !ibcx=1 if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,1,k)=vdyf(x(i,1,k-1),x(i,1,k),f3(i,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f1(i,1,k-1)+f1(i,1,k)+f1(i+1,1,k)+f1(i+1,1,k-1), * x(i-1,1,k-1),x(i-1,1,k),x(i+1,1,k-1),x(i+1,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * x(i,-1,k-1),x(i,-1,k),x(i,2,k-1),x(i,2,k), * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif if(ibcx.eq.1) then if (leftedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(1,1,k)=vdyf(x(1,1,k-1),x(1,1,k),f3(1,1,k), * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f1(1,1,k-1)+f1(1,1,k)+f1(2,1,k)+f1(2,1,k-1), * x(-1,1,k-1),x(-1,1,k),x(2,1,k-1),x(2,1,k), * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * x(1,-1,k-1),x(1,-1,k),x(1,2,k-1),x(1,2,k), * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m,n2m,k)=v3(1,1,k) v3(n1m, 1,k)=v3(1,1,k) v3( 1,n2m,k)=v3(1,1,k) #endif end do end if #if (PARALLEL > 0) call update(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(np,mp,k)=v3(np+1,mp+1,k) enddo endif if (rightedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(np,1,k)=v3(np+1,1,k) enddo endif if (leftedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(1,mp,k)=v3(1,mp+1,k) enddo endif #endif end if !ibcx=1 end if !ibcy=1 C----------------/ #else /* POLES */ C----------------/ if (botedge.eq.1) then do k=2,n3m do i=1,np v3(i,1,k)=vdyf(x(i,1,k-1),x(i,1,k),f3(i,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * + vcorr(f3(i,1,k), * f1(i,1,k-1)+f1(i,1,k)+f1(i+1,1,k)+f1(i+1,1,k-1), * x(i-1,1,k-1),x(i-1,1,k),x(i+1,1,k-1),x(i+1,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * + vcorr(f3(i,1,k), * f2(i,1,k-1)+f2(i,1+j3,k-1)+f2(i,1+j3,k)+f2(i,1,k), * pbc*x(i,1-j3,k-1),pbc*x(i,1-j3,k),x(i,1+j3,k-1),x(i,1+j3,k), * .5*(h(i,1,k-1)+h(i,1,k))) enddo enddo endif if (topedge.eq.1) then do k=2,n3m do i=1,np v3(i,mp,k)=vdyf(x(i,mp,k-1),x(i,mp,k),f3(i,mp,k), * .5*(h(i,mp,k-1)+h(i,mp,k))) * + vcorr(f3(i,mp,k), * f1(i,mp,k-1)+f1(i,mp,k)+f1(i+1,mp,k)+f1(i+1,mp,k-1), * x(i-1,mp,k-1),x(i-1,mp,k),x(i+1,mp,k-1),x(i+1,mp,k), * .5*(h(i,mp,k-1)+h(i,mp,k))) * + vcorr(f3(i,mp,k), * f2(i,mp,k-1)+f2(i,mp+j3,k-1)+f2(i,mp+j3,k)+f2(i,mp,k), * x(i,mp-j3,k-1),x(i,mp-j3,k),pbc*x(i,mp+j3,k-1),pbc*x(i,mp+j3,k), * .5*(h(i,mp,k-1)+h(i,mp,k))) enddo enddo endif C----------------/ #endif /* POLES */ C----------------/ if(idiv.eq.1) then #if (POLES == 0) illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp + (-1+ibcy)*topedge #else illim = 1 iulim = np jllim = 1 julim = mp #endif do 531 k=2,n3m do 531 j=jllim,julim do 531 i=illim,iulim v2d=-vdiv1(f3(i,j,k-1),f3(i,j,k),f3(i,j,k+1), * .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f1(i+1,j,k-1),f1(i+1,j,k),f1(i,j,k-1), * f1(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f2(i,j+1,k-1),f2(i,j+1,k),f2(i,j,k-1), * f2(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) 531 v3(i,j,k)=v3(i,j,k)+(pp(v2d)*x(i,j,k-1)-pn(v2d)*x(i,j,k)) endif C----------------/ #if (POLES == 0) C----------------/ if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) enddo enddo end if end if if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i,1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3,k) enddo enddo end if end if C----------------/ #else /* POLES */ C----------------/ call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ if (iprec.eq.0) then do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2)*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz end do end do end if if(nonos.eq.1) then c non-osscilatory option C----------------/ #if (POLES == 0) C----------------/ do 401 k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do 401 j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - 1 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + 1 end if do 401 i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) 401 mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) #else jllim = 1 + botedge julim = mp - topedge do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np im = i - 1 ip = i + 1 do j=jllim,julim jm = j - j3 jp = j + j3 mx(i,j,k)=amax1(x(im,j,k),x(i,j,k ),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km),mx(i,j,k)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k ),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km),mn(i,j,k)) end do end do end do if (botedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,1,k)=amax1(x(i-1,1,k),x(i,1,k ),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km),mx(i,1,k)) mn(i,1,k)=amin1(x(i-1,1,k),x(i,1,k ),x(i+1,1,k), . pbc*x(i,1-j3,k),x(i,1+j3,k),x(i,1,kp),x(i,1,km),mn(i,1,k)) end do end do end if if (topedge.eq.1) then do k=1,l km=max0(k-1,1) kp=min0(k+1,l) do i=1,np mx(i,mp,k)=amax1(x(i-1,mp,k),x(i,mp,k ),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km),mx(i,mp,k)) mn(i,mp,k)=amin1(x(i-1,mp,k),x(i,mp,k ),x(i+1,mp,k), . x(i,mp-j3,k),pbc*x(i,mp+j3,k),x(i,mp,kp),x(i,mp,km),mn(i,mp,k)) end do end do end if C----------------/ #endif /* POLES */ C----------------/ #if (POLES == 0) iulim = np + rightedge julim = mp + j3*topedge #else iulim = np julim = mp #endif do 402 k=1,n3m do 402 j=1,mp do 402 i=1,iulim 402 f1(i,j,k)=donor(c2,c2,v1(i,j,k)) do 403 k=1,n3m do 403 j=1,julim do 403 i=1,np 403 f2(i,j,k)=donor(c2,c2,v2(i,j,k)) do 4033 k=1,n3 do 4033 j=1,mp do 4033 i=1,np 4033 f3(i,j,k)=donor(c2,c2,v3(i,j,k)) #if (POLES == 0) if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if #else call updatelr(f1,np,mp,l,np+1,mp,1) #endif if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if do 444 k=1,n3m do 444 j=1,mp do 444 i=1,np cp(i,j,k)=(mx(i,j,k)-x(i,j,k))*h(i,j,k)/ 1( pn(f1(i+1,j,k))+pp(f1(i,j,k)) 2 +pn(f2(i,j+1,k))+pp(f2(i,j,k)) 3 +pn(f3(i,j,k+1))+pp(f3(i,j,k))+ep) cn(i,j,k)=(x(i,j,k)-mn(i,j,k))*h(i,j,k)/ 1( pp(f1(i+1,j,k))+pn(f1(i,j,k)) 2 +pp(f2(i,j+1,k))+pn(f2(i,j,k)) 3 +pp(f3(i,j,k+1))+pn(f3(i,j,k))+ep) 444 continue call update2(cp,np,mp,l,np,mp,1) call update2(cn,np,mp,l,np,mp,1) #if (POLES == 0) illim = 1 + leftedge iulim = np jllim = 1 + botedge julim = mp #else illim = 1 iulim = np jllim = 1 julim = mp + topedge #endif do k=1,n3m do j=1,mp do i=illim,iulim v1(i,j,k)= pp(v1(i,j,k))*amin1(1.,cp(i,j,k),cn(i-1,j,k)) * -pn(v1(i,j,k))*amin1(1.,cp(i-1,j,k),cn(i,j,k)) end do end do end do CAUTION: the following loop is coded to get around an apparent compiler problem on the T3D. do k=1,n3m do j=jllim,julim do i=1,np ct3d if (v2(i,j,k).ge.0.) then ct3d v2(i,j,k)= pp(v2(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j-1,k)) ct3d else ct3d v2(i,j,k)=-pn(v2(i,j,k))*amin1(1.,cp(i,j-1,k),cn(i,j,k)) ct3d end if v2(i,j,k)= pp(v2(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j-1,k)) . -pn(v2(i,j,k))*amin1(1.,cp(i,j-1,k),cn(i,j,k)) end do end do end do do k=2,n3m do j=1,mp do i=1,np v3(i,j,k)= pp(v3(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j,k-1)) * -pn(v3(i,j,k))*amin1(1.,cp(i,j,k-1),cn(i,j,k)) end do end do end do C----------------/ #if (POLES == 0) C----------------/ if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1 ,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) end do end do end if end if if (ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3,k) end do end do end if end if #else call updatelr(v1,np,mp,l,np+1,mp,1) if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,1) else call updatebt(v2,np,mp+1,l,np,mp+1,1) end if C----------------/ #endif /* POLES */ C----------------/ if (iprec.eq.0) then do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2)*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz enddo enddo end if endif 30 continue 6 continue c optional removal of roundoff error negatives in positive fileds c if(iflg.lt.2.or.iflg.gt.5) then c do k=1,l c do j=1,m c do i=1,n c x(i,j,k)=amax1(0.,x(i,j,k)) c enddo c enddo c enddo c endif c goto 999 c optional enforcing of perodicity cccccccccccccccccccccccc cyclic boundary forcing cccccccccccccccccccccccc #if (POLES == 0) if (ibcx.eq.1) then call updatelr(x,np,mp,L,np,mp,1) if (rightedge.eq.1) then do k=1,l do j=1,mp x(np,j,k)=x(np+1,j,k) end do end do end if end if if (ibcy.eq.1) then call updatebt(x,np,mp,L,np,mp,1) if (topedge.eq.1) then do k=1,l do i=1,np x(i,mp,k)=x(i,mp+1,k) end do end do end if end if #endif if (ibcz.eq.1) then do j=1,mp do i=1,np x(i,j,l)=x(i,j,1) end do end do end if ccccccccccccccccccccccccccccc cyclic boundary forcing done ccccccccccccccccccccccccccccc 999 continue call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(35) #endif return end subroutine mpdatm3B(u1,u2,u3,x,h,iflg,div) include 'param.nml' include 'msg.inc' parameter(nonos=1,idiv=0) dimension u1(1-ih:np+ih, 1-ih:mp+ih, l), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . u3(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . tempx(1-ih:np+ih, 1-ih:mp+ih, l), . div(1-ih:np+ih, 1-ih:mp+ih, l), . h(1-ih:np+ih, 1-ih:mp+ih, l) parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(iv1f1=(np+1+2*ih)*(mp+2*ih)*l) parameter(iv2f2=(np+2*ih)*(mp+1+2*ih)*l) parameter(iv3f3=(np+2*ih)*(mp+2*ih)*(l+1)) parameter(ibcxa=(mp+2*ih)*l,ibcya=(np+2*ih)*l) parameter(ifree=12*iarray-2*(iv1f1+iv2f2+iv3f3+ibcxa+ibcya)) common/blank/ cp(1-ih:np+ih, 1-ih:mp+ih, l), . cn(1-ih:np+ih, 1-ih:mp+ih, l), . mx(1-ih:np+ih, 1-ih:mp+ih, l), . mn(1-ih:np+ih, 1-ih:mp+ih, l), . v1(1-ih:np+ih+1,1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+1+ih, l), . v3(1-ih:np+ih, 1-ih:mp+ih, l+1), . f1(1-ih:np+1+ih,1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+1+ih, l), . f3(1-ih:np+ih, 1-ih:mp+ih, l+1), . bcx(1-ih:mp+ih, l, 2), . bcy(1-ih:np+ih, l, 2), . scr(ifree) common/advbc/ wbc(1-ih:np+ih, 1-ih:mp+ih, 2), . ubc(1-ih:mp+ih, l, 2), . vbc(1-ih:np+ih, l, 2) real mx,mn real ampdx(mp),ampdy(mp),ampdz(mp) !factors for polar absorber attenuation c common/mpfil/ liner,mpfl,ampd0(3) !mod filters common/mpfil/ liner,mpfl,ampd0(3),ampd(mp,3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/realtp/ zsib(1-ih:nibp+ih,1-ih:mibp+ih,lib),tsibi data ep/1.e-10/ c pp(y)= amax1(0.,y) pn(y)=-amin1(0.,y) donor(y1,y2,a)=pp(a)*y1-pn(a)*y2 rat2(z1,z2)=(z2-z1)*.5 rat4(z0,z1,z2,z3)=(z3+z2-z1-z0)*.25 vdyf(x1,x2,a,r,amp1)=(abs(a)-a**2/r+2.*amp1*r)*rat2(x1,x2) c vdyf(x1,x2,a,r)=(abs(a)-a**2/r)*rat2(x1,x2) !mod filters cex vdyf(x1,x2,a,r)=(abs(a)-a**2/r+2.*ampd*r)*rat2(x1,x2) vcorr(a,b,y0,y1,y2,y3,r)=-0.125*a*b/r*rat4(y0,y1,y2,y3) vdiv1(a1,a2,a3,r)=0.25*a2*(a3-a1)/r vdiv2(a,b1,b2,b3,b4,r)=0.25*a*(b1+b2-b3-b4)/r c #if (TIMEPLT == 1) call ttbeg(35) #endif call update(x,np,mp,l,np,mp,iup) do k=1,n3m do j=1,mp do i=1,np div(i,j,k)=x(i,j,k) tempx(i,j,k)=x(i,j,k) end do end do end do ibox=1-ibcx iboy=1-ibcy iboz=1-ibcz ibcxy=ibcx*ibcy itmx=2-liner iprec=0 if(iflg.eq.21) iprec=1 !qr, qia, qib do k=2,n3m do j=1,mp do i=1,np v3(i,j,k) = u3(i,j,k) enddo end do end do do j=1,mp do i=1,np v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do illim = 1 + leftedge do k=1,n3m do j=1,mp do i=illim,np v1(i,j,k) = u1(i,j,k) end do end do end do if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1( 1,j,k) = ubc(j,k,1) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k) = ubc(j,k,2) end do end do end if jllim = 1 + 1*botedge do k=1,n3m do j=jllim,mp do i=1,np v2(i,j,k) = u2(i,j,k) end do end do end do if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k) = vbc(i,k,1) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k) = vbc(i,k,2) end do end do end if if (nonos.eq.1) then do k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+(1-ibcz)*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+(1-ibcz)*min0(k+1,n3m) do j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - 1 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + 1 end if do i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) end do end do end do endif c1=1. c2=0. do 30 itr=1,itmx if((itr.eq.1).and.(ibcxy.eq.0)) . call mp3bc(x,iflg,bcx,bcy,np,mp,n3m) COLD call update(x,np,mp,l,np,mp,iup) ilft=1+leftedge*1 do j=1,mp ampdx(j)=c1*ampd(j,1) enddo do k=1,n3m do j=1,mp do i=ilft,np f1(i,j,k)=donor(c1*x(i-1,j,k)+c2,c1*x(i,j,k)+c2,v1(i,j,k)) . -ampdx(j)*.5*(h(i,j,k)+h(i-1,j,k))*(x(i,j,k)-x(i-1,j,k)) !mod filters end do end do end do if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,iupx) else call updatelr(f1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp f1(1 ,j,k)=f1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp f1(np+1,j,k)=f1(np+3,j,k) end do end do end if else if (leftedge.eq.1) then do k=1,n3m do j=1,mp c special icylind, tank c f1(1 ,j,k)=-f1(2,j,k) f1(1 ,j,k)=donor(c1*bcx(j,k,1)+c2,c1*x(1,j,k)+c2,v1(1,j,k)) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp c special tank c f1(np+1,j,k)=-f1(np,j,k) f1(np+1,j,k)= . donor(c1*x(np,j,k)+c2,c1*bcx(j,k,2)+c2,v1(np+1,j,k)) end do end do end if if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if endif jbot=1+botedge*1 do j=1,mp ampdy(j)=c1*ampd(j,2) enddo do k=1,n3m do j=jbot,mp do i=1,np f2(i,j,k)=donor(c1*x(i,j-1,k)+c2,c1*x(i,j,k)+c2,v2(i,j,k)) . -ampdy(j)*.5*(h(i,j,k)+h(i,j-1,k))*(x(i,j,k)-x(i,j-1,k)) !mod filters end do end do end do if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,iupy) else call updatebt(f2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=f2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)=f2(i,mp+3,k) end do end do end if else if (botedge.eq.1) then do k=1,n3m do i=1,np f2(i,1,k)=donor(c1*bcy(i,k,1)+c2,c1*x(i,1,k)+c2,v2(i,1,k)) c f2(i,1,k)=-f2(i,2,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np f2(i,mp+1,k)= . donor(c1*x(i,mp,k)+c2,c1*bcy(i,k,2)+c2,v2(i,mp+1,k)) c f2(i,mp+1,k)=-f2(i,mp,k) end do end do end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if endif do j=1,mp ampdz(j)=c1*ampd(j,3) enddo do 333 k=2,n3m do 333 j=1,mp do 333 i=1,np 333 f3(i,j,k)=donor(c1*x(i,j,k-1)+c2,c1*x(i,j,k)+c2,v3(i,j,k)) . -ampdz(j)*.5*(h(i,j,k)+h(i,j,k-1))*(x(i,j,k)-x(i,j,k-1)) !mod filters if(iprec.eq.1) then frain=-0.01*5. do j=1,mp do i=1,np f3(i,j, 1)=donor(c1*x(i,j, 1 )+c2,c1*x(i,j, 1 )+c2,v3(i,j,1 )) f3(i,j,n3)=donor(c1*x(i,j,n3m)+c2,c1*x(i,j,n3m)+c2,v3(i,j,n3)) csp f3(i,j, 1)=-f3(i,j, 2) csp if(zsib(i,j,n3m).lt.0.) then csp f3(i,j,n3)=2.*c1*frain-f3(i,j,n3m) csp else csp f3(i,j,n3)=-f3(i,j,n3m) csp endif end do end do else do j=1,mp do i=1,np f3(i,j, 1)=-f3(i,j, 2)*iboz+f3(i,j,n3m)*ibcz f3(i,j,n3)=-f3(i,j,n3m)*iboz+f3(i,j, 2 )*ibcz enddo enddo end if do k=1,n3m do j=1,mp do i=1,np x(i,j,k)=x(i,j,k)-( f1(i+1,j,k)-f1(i,j,k) . +f2(i,j+1,k)-f2(i,j,k) . +f3(i,j,k+1)-f3(i,j,k) )/h(i,j,k) end do end do end do if(itr.eq.itmx) then do k=1,n3m do j=1,mp do i=1,np div(i,j,k)=x(i,j,k)-div(i,j,k) x(i,j,k)=tempx(i,j,k) end do end do end do go to 6 endif c1=0. c2=1. iulim = np + 1*rightedge julim = mp + 1*topedge do k=1,n3m do j=1,mp do i=1,iulim f1(i,j,k)=v1(i,j,k) v1(i,j,k)=0. end do end do end do do k=1,n3m do j=1,julim do i=1,np f2(i,j,k)=v2(i,j,k) v2(i,j,k)=0. end do end do end do do k=1,n3 do j=1,mp do i=1,np f3(i,j,k)=v3(i,j,k) v3(i,j,k)=0. end do end do end do c------------ compute antidiffusive velocities in x direction c------------ call update(x,np,mp,l,np,mp,iup) if (rightedge.eq.0) then call update(f1,np,mp,l,np+1,mp,1) else call update(f1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.0) then call update(f2,np,mp,l,np,mp+1,1) else call update(f2,np,mp+1,l,np,mp+1,1) end if call update(f3,np,mp,l+1,np,mp,1) illim = 1 + leftedge iulim = np jllim = 1 + botedge julim = mp - topedge do k=2,n3-2 do j=jllim,julim do i=illim,iulim v1(i,j,k)=vdyf(x(i-1,j,k),x(i,j,k),f1(i,j,k), * .5*(h(i-1,j,k)+h(i,j,k)),ampdx(j)) !mod filters * +vcorr(f1(i,j,k), * f2(i-1,j,k)+f2(i-1,j+1,k)+f2(i,j+1,k)+f2(i,j,k), * x(i-1,j-1,k),x(i,j-1,k),x(i-1,j+1,k),x(i,j+1,k), * .5*(h(i-1,j,k)+h(i,j,k))) * +vcorr(f1(i,j,k), * f3(i-1,j,k)+f3(i-1,j,k+1)+f3(i,j,k+1)+f3(i,j,k), * x(i-1,j,k-1),x(i,j,k-1),x(i-1,j,k+1),x(i,j,k+1), * .5*(h(i-1,j,k)+h(i,j,k))) end do end do end do c------------ if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,1,k)=vdyf(x(i-1,1,k),x(i,1,k),f1(i,1,k), * .5*(h(i-1,1,k)+h(i,1,k)),ampdx(1)) !mod filters * +vcorr(f1(i,1,k), * f2(i-1,1,k)+f2(i-1,2,k)+f2(i,2,k)+f2(i,1,k), * x(i-1,-1,k),x(i,-1,k),x(i-1,2,k),x(i,2,k), * .5*(h(i-1,1,k)+h(i,1,k))) * +vcorr(f1(i,1,k), * f3(i-1,1,k)+f3(i-1,1,k+1)+f3(i,1,k+1)+f3(i,1,k), * x(i-1,1,k-1),x(i,1,k-1),x(i-1,1,k+1),x(i,1,k+1), * .5*(h(i-1,1,k)+h(i,1,k))) #if (PARALLEL == 0) v1(i,n2m,k)=v1(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do k=2,n3-2 do i=illim,iulim v1(i,mp,k)=v1(i,mp+1,k) enddo enddo end if #endif end if c------------ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1)),ampdx(j)) !mod filters * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * x(i-1,j-1,1),x(i,j-1,1),x(i-1,j+1,1),x(i,j+1,1), * .5*(h(i-1,j,1)+h(i,j,1))) * +vcorr(f1(i,j,1), * f3(i-1,j,1)+f3(i-1,j,2)+f3(i,j,2)+f3(i,j,1), * x(i-1,j,n3-2),x(i,j,n3-2),x(i-1,j,2),x(i,j,2), * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=v1(i,j,1) enddo enddo if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1)),ampdx(1)) !mod filters * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * x(i-1,-1,1),x(i,-1,1),x(i-1,2,1),x(i,2,1), * .5*(h(i-1,1,1)+h(i,1,1))) * +vcorr(f1(i,1,1), * f3(i-1,1,1)+f3(i-1,1,2)+f3(i,1,2)+f3(i,1,1), * x(i-1,1,n3-2),x(i,1,n3-2),x(i-1,1,2),x(i,1,2), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n3m)=v1(i,1,1) #if (PARALLEL == 0) v1(i,n2m, 1)=v1(i,1 ,1) v1(i,n2m,n3m)=v1(i,n2m,1) #endif enddo end if #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp ,1) enddo end if #endif endif !ibcy=1 else !ibcz test do j=jllim,julim do i=illim,iulim v1(i,j,1)=vdyf(x(i-1,j,1),x(i,j,1),f1(i,j,1), * .5*(h(i-1,j,1)+h(i,j,1)),ampdx(j)) !mod filters * +vcorr(f1(i,j,1), * f2(i-1,j,1)+f2(i-1,j+1,1)+f2(i,j+1,1)+f2(i,j,1), * x(i-1,j-1,1),x(i,j-1,1),x(i-1,j+1,1),x(i,j+1,1), * .5*(h(i-1,j,1)+h(i,j,1))) v1(i,j,n3m)=vdyf(x(i-1,j,n3m),x(i,j,n3m),f1(i,j,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m)),ampdx(j)) !mod filters * +vcorr(f1(i,j,n3m), * f2(i-1,j,n3m)+f2(i-1,j+1,n3m)+f2(i,j+1,n3m)+f2(i,j,n3m), * x(i-1,j-1,n3m),x(i,j-1,n3m),x(i-1,j+1,n3m),x(i,j+1,n3m), * .5*(h(i-1,j,n3m)+h(i,j,n3m))) enddo enddo if(ibcy.eq.1) then if (botedge.eq.1) then do i=illim,iulim v1(i,1,1)=vdyf(x(i-1,1,1),x(i,1,1),f1(i,1,1), * .5*(h(i-1,1,1)+h(i,1,1)),ampdx(1)) !mod filters * +vcorr(f1(i,1,1), * f2(i-1,1,1)+f2(i-1,2,1)+f2(i,2,1)+f2(i,1,1), * x(i-1,-1,1),x(i,-1,1),x(i-1,2,1),x(i,2,1), * .5*(h(i-1,1,1)+h(i,1,1))) v1(i,1,n3m)=vdyf(x(i-1,1,n3m),x(i,1,n3m),f1(i,1,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m)),ampdx(1)) !mod filters * +vcorr(f1(i,1,n3m), * f2(i-1,1,n3m)+f2(i-1,2,n3m)+f2(i,2,n3m)+f2(i,1,n3m), * x(i-1,-1,n3m),x(i,-1,n3m),x(i-1,2,n3m),x(i,2,n3m), * .5*(h(i-1,1,n3m)+h(i,1,n3m))) #if (PARALLEL == 0) v1(i,n2m, 1)=v1(i,1 ,1) v1(i,n2m,n3m)=v1(i,1,n3m) #endif enddo end if ! botedge=1 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp,1) else call updatebt(v1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.1) then do i=illim,iulim v1(i,mp, 1 )=v1(i,mp+1,1) v1(i,mp,n3m)=v1(i,mp+1,n3m) enddo end if #endif endif !ibcy=1 endif !ibcz=1 c------------ if(idiv.eq.1) then illim = 1 + leftedge iulim = np jllim = 1 + iboy*botedge julim = mp - iboy*topedge do 511 k=2-ibcz,n3-2+ibcz do 511 j=jllim,julim do 511 i=illim,iulim v1d=-vdiv1(f1(i-1,j,k),f1(i,j,k),f1(i+1,j,k), * .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f2(i-1,j+1,k),f2(i,j+1,k),f2(i-1,j,k), * f2(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) * -vdiv2(f1(i,j,k),f3(i-1,j,k+1),f3(i,j,k+1),f3(i-1,j,k), * f3(i,j,k), .5*(h(i-1,j,k)+h(i,j,k))) 511 v1(i,j,k)=v1(i,j,k)+(pp(v1d)*x(i-1,j,k)-pn(v1d)*x(i,j,k)) endif c------------ compute antidiffusive velocities in y direction c------------ illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp do k=2,n3-2 do j=jllim,julim do i=illim,iulim v2(i,j,k)=vdyf(x(i,j-1,k),x(i,j,k),f2(i,j,k), * .5*(h(i,j-1,k)+h(i,j,k)),ampdy(j)) !mod filters * +vcorr(f2(i,j,k), * f1(i,j-1,k)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j-1,k), * x(i-1,j-1,k),x(i-1,j,k),x(i+1,j-1,k),x(i+1,j,k), * .5*(h(i,j-1,k)+h(i,j,k))) * +vcorr(f2(i,j,k), * f3(i,j-1,k)+f3(i,j,k)+f3(i,j,k+1)+f3(i,j-1,k+1), * x(i,j-1,k-1),x(i,j,k-1),x(i,j-1,k+1),x(i,j,k+1), * .5*(h(i,j-1,k)+h(i,j,k))) end do end do end do c------------ if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k)),ampdy(j)) !mod filters * +vcorr(f2(1,j,k), * f1(1,j-1,k)+f1(1,j,k)+f1(2,j,k)+f1(2,j-1,k), * x(-1,j-1,k),x(-1,j,k),x(2,j-1,k),x(2,j,k), * .5*(h(1,j-1,k)+h(1,j,k))) * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * x(1,j-1,k-1),x(1,j,k-1),x(1,j-1,k+1),x(1,j,k+1), * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) #endif end do end do end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif else !ibcx=0 if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(1,j,k)=vdyf(x(1,j-1,k),x(1,j,k),f2(1,j,k), * .5*(h(1,j-1,k)+h(1,j,k)),ampdy(j)) !mod filters * +vcorr(f2(1,j,k), * f3(1,j-1,k)+f3(1,j,k)+f3(1,j,k+1)+f3(1,j-1,k+1), * x(1,j-1,k-1),x(1,j,k-1),x(1,j-1,k+1),x(1,j,k+1), * .5*(h(1,j-1,k)+h(1,j,k))) #if (PARALLEL == 0) v2(n1m,j,k)=v2(1,j,k) v2(n1m,j,k)=vdyf(x(n1m,j-1,k),x(n1m,j,k),f2(n1m,j,k), * .5*(h(n1m,j-1,k)+h(n1m,j,k)),ampdy(j)) !mod filters * +vcorr(f2(n1m,j,k), * f3(n1m,j-1,k)+f3(n1m,j,k)+f3(n1m,j,k+1)+f3(n1m,j-1,k+1), * x(n1m,j-1,k-1),x(n1m,j,k-1),x(n1m,j-1,k+1),x(n1m,j,k+1), * .5*(h(n1m,j-1,k)+h(n1m,j,k))) #endif end do end do end if #if (PARALLEL > 0) if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,julim v2(np,j,k)=vdyf(x(np,j-1,k),x(np,j,k),f2(np,j,k), * .5*(h(np,j-1,k)+h(np,j,k)),ampdy(j)) !mod filters * +vcorr(f2(np,j,k), * f3(np,j-1,k)+f3(np,j,k)+f3(np,j,k+1)+f3(np,j-1,k+1), * x(np,j-1,k-1),x(np,j,k-1),x(np,j-1,k+1),x(np,j,k+1), * .5*(h(np,j-1,k)+h(np,j,k))) end do end do end if #endif end if !ibcx test c------------ if(ibcz.eq.1) then do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1)),ampdy(j)) !mod filters * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * x(i-1,j-1,1),x(i-1,j,1),x(i+1,j-1,1),x(i+1,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) * +vcorr(f2(i,j,1), * f3(i,j-1,1)+f3(i,j,1)+f3(i,j,2)+f3(i,j-1,2), * x(i,j-1,n3-2),x(i,j,n3-2),x(i,j-1,2),x(i,j,2), * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=v2(i,j,1) enddo enddo if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1)),ampdy(j)) !mod filters * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * x(-1,j-1,1),x(-1,j,1),x(2,j-1,1),x(2,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) * +vcorr(f2(1,j,1), * f3(1,j-1,1)+f3(1,j,1)+f3(1,j,2)+f3(1,j-1,2), * x(1,j-1,n3-2),x(1,j,n3-2),x(1,j-1,2),x(1,j,2), * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=v2(1,j,1) #if (PARALLEL == 0) v2(n1-1,j,1)=v2(1,j,1) v2(n1-1,j,n3m)=v2(n1-1,j,1) #endif enddo end if #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np ,j,1) end do end if #endif endif !ibcx=1 else !ibcz test do j=jllim,julim do i=illim,iulim v2(i,j,1)=vdyf(x(i,j-1,1),x(i,j,1),f2(i,j,1), * .5*(h(i,j-1,1)+h(i,j,1)),ampdy(j)) !mod filters * +vcorr(f2(i,j,1), * f1(i,j-1,1)+f1(i,j,1)+f1(i+1,j,1)+f1(i+1,j-1,1), * x(i-1,j-1,1),x(i-1,j,1),x(i+1,j-1,1),x(i+1,j,1), * .5*(h(i,j-1,1)+h(i,j,1))) v2(i,j,n3m)=vdyf(x(i,j-1,n3m),x(i,j,n3m),f2(i,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m)),ampdy(j)) !mod filters * +vcorr(f2(i,j,n3m), * f1(i,j-1,n3m)+f1(i,j,n3m)+f1(i+1,j,n3m)+f1(i+1,j-1,n3m), * x(i-1,j-1,n3m),x(i-1,j,n3m),x(i+1,j-1,n3m),x(i+1,j,n3m), * .5*(h(i,j-1,n3m)+h(i,j,n3m))) enddo enddo if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,julim v2(1,j,1)=vdyf(x(1,j-1,1),x(1,j,1),f2(1,j,1), * .5*(h(1,j-1,1)+h(1,j,1)),ampdy(j)) !mod filters * +vcorr(f2(1,j,1), * f1(1,j-1,1)+f1(1,j,1)+f1(2,j,1)+f1(2,j-1,1), * x(-1,j-1,1),x(-1,j,1),x(2,j-1,1),x(2,j,1), * .5*(h(1,j-1,1)+h(1,j,1))) v2(1,j,n3m)=vdyf(x(1,j-1,n3m),x(1,j,n3m),f2(1,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m)),ampdy(j)) !mod filters * +vcorr(f2(1,j,n3m), * f1(1,j-1,n3m)+f1(1,j,n3m)+f1(2,j,n3m)+f1(2,j-1,n3m), * x(-1,j-1,n3m),x(-1,j,n3m),x(2,j-1,n3m),x(2,j,n3m), * .5*(h(1,j-1,n3m)+h(1,j,n3m))) #if (PARALLEL == 0) v2(n1-1,j,1)=v2(1,j,1) v2(n1-1,j,n3m)=v2(1,j,n3m) #endif enddo end if ! leftedge=1 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1,1) else call updatelr(v2,np,mp+1,l,np,mp+1,1) end if if (rightedge.eq.1) then do j=jllim,julim v2(np,j, 1 )=v2(np+1,j,1) v2(np,j,n3m)=v2(np+1,j,n3m) end do end if #endif endif !ibcx=1 endif !ibcz=1 c------------ if(idiv.eq.1) then illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge jllim = 1 + 1*botedge julim = mp do 521 k=2-ibcz,n3-2+ibcz do 521 j=jllim,julim do 521 i=illim,iulim v2d=-vdiv1(f2(i,j-1,k),f2(i,j,k),f2(i,j+1,k), * .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f1(i+1,j-1,k),f1(i+1,j,k),f1(i,j-1,k), * f1(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) * -vdiv2(f2(i,j,k),f3(i,j-1,k+1),f3(i,j,k+1),f3(i,j-1,k), * f3(i,j,k), .5*(h(i,j-1,k)+h(i,j,k))) 521 v2(i,j,k)=v2(i,j,k)+(pp(v2d)*x(i,j-1,k)-pn(v2d)*x(i,j,k)) endif c------------ compute antidiffusive velocities in z direction c------------ illim = 1 + leftedge iulim = np - rightedge jllim = 1 + botedge julim = mp - topedge do 53 k=2,n3m do 53 j=jllim,julim do 53 i=illim,iulim 53 v3(i,j,k)=vdyf(x(i,j,k-1),x(i,j,k),f3(i,j,k), * .5*(h(i,j,k-1)+h(i,j,k)),ampdz(j)) !mod filters * +vcorr(f3(i,j,k), * f1(i,j,k-1)+f1(i,j,k)+f1(i+1,j,k)+f1(i+1,j,k-1), * x(i-1,j,k-1),x(i-1,j,k),x(i+1,j,k-1),x(i+1,j,k), * .5*(h(i,j,k-1)+h(i,j,k))) * +vcorr(f3(i,j,k), * f2(i,j,k-1)+f2(i,j+1,k-1)+f2(i,j+1,k)+f2(i,j,k), * x(i,j-1,k-1),x(i,j-1,k),x(i,j+1,k-1),x(i,j+1,k), * .5*(h(i,j,k-1)+h(i,j,k))) if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3m do j=jllim,julim v3(1,j,k)=vdyf(x(1,j,k-1),x(1,j,k),f3(1,j,k), * .5*(h(1,j,k-1)+h(1,j,k)),ampdz(j)) !mod filters * +vcorr(f3(1,j,k), * f1(1,j,k-1)+f1(1,j,k)+f1(2,j,k)+f1(2,j,k-1), * x(-1,j,k-1),x(-1,j,k),x(2,j,k-1),x(2,j,k), * .5*(h(1,j,k-1)+h(1,j,k))) * +vcorr(f3(1,j,k), * f2(1,j,k-1)+f2(1,j+1,k-1)+f2(1,j+1,k)+f2(1,j,k), * x(1,j-1,k-1),x(1,j-1,k),x(1,j+1,k-1),x(1,j+1,k), * .5*(h(1,j,k-1)+h(1,j,k))) #if (PARALLEL == 0) v3(n1m,j,k)=v3(1,j,k) #endif enddo enddo endif #if (PARALLEL > 0) call updatelr(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1) then do k=2,n3m do j=jllim,julim v3(np,j,k)=v3(np+1,j,k) enddo enddo endif #endif end if !ibcx=1 if(ibcy.eq.1) then if (botedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,1,k)=vdyf(x(i,1,k-1),x(i,1,k),f3(i,1,k), * .5*(h(i,1,k-1)+h(i,1,k)),ampdz(1)) !mod filters * +vcorr(f3(i,1,k), * f1(i,1,k-1)+f1(i,1,k)+f1(i+1,1,k)+f1(i+1,1,k-1), * x(i-1,1,k-1),x(i-1,1,k),x(i+1,1,k-1),x(i+1,1,k), * .5*(h(i,1,k-1)+h(i,1,k))) * +vcorr(f3(i,1,k), * f2(i,1,k-1)+f2(i,2,k-1)+f2(i,2,k)+f2(i,1,k), * x(i,-1,k-1),x(i,-1,k),x(i,2,k-1),x(i,2,k), * .5*(h(i,1,k-1)+h(i,1,k))) #if (PARALLEL == 0) v3(i,n2m,k)=v3(i,1,k) #endif enddo enddo end if #if (PARALLEL > 0) call updatebt(v3,np,mp,l+1,np,mp,1) if (topedge.eq.1) then do k=2,n3m do i=illim,iulim v3(i,mp,k)=v3(i,mp+1,k) enddo enddo end if #endif if(ibcx.eq.1) then if (leftedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(1,1,k)=vdyf(x(1,1,k-1),x(1,1,k),f3(1,1,k), * .5*(h(1,1,k-1)+h(1,1,k)),ampdz(1)) !mod filters * +vcorr(f3(1,1,k), * f1(1,1,k-1)+f1(1,1,k)+f1(2,1,k)+f1(2,1,k-1), * x(-1,1,k-1),x(-1,1,k),x(2,1,k-1),x(2,1,k), * .5*(h(1,1,k-1)+h(1,1,k))) * +vcorr(f3(1,1,k), * f2(1,1,k-1)+f2(1,2,k-1)+f2(1,2,k)+f2(1,1,k), * x(1,-1,k-1),x(1,-1,k),x(1,2,k-1),x(1,2,k), * .5*(h(1,1,k-1)+h(1,1,k))) #if (PARALLEL == 0) v3(n1m,n2m,k)=v3(1,1,k) v3(n1m, 1,k)=v3(1,1,k) v3( 1,n2m,k)=v3(1,1,k) #endif end do end if #if (PARALLEL > 0) call update(v3,np,mp,l+1,np,mp,1) if (rightedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(np,mp,k)=v3(np+1,mp+1,k) enddo endif if (rightedge.eq.1 .and. botedge.eq.1) then do k=2,n3m v3(np,1,k)=v3(np+1,1,k) enddo endif if (leftedge.eq.1 .and. topedge.eq.1) then do k=2,n3m v3(1,mp,k)=v3(1,mp+1,k) enddo endif #endif end if !ibcx=1 end if !ibcy=1 if(idiv.eq.1) then illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp + (-1+ibcy)*topedge do 531 k=2,n3m do 531 j=jllim,julim do 531 i=illim,iulim v2d=-vdiv1(f3(i,j,k-1),f3(i,j,k),f3(i,j,k+1), * .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f1(i+1,j,k-1),f1(i+1,j,k),f1(i,j,k-1), * f1(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) * -vdiv2(f3(i,j,k),f2(i,j+1,k-1),f2(i,j+1,k),f2(i,j,k-1), * f2(i,j,k), .5*(h(i,j,k-1)+h(i,j,k))) 531 v3(i,j,k)=v3(i,j,k)+(pp(v2d)*x(i,j,k-1)-pn(v2d)*x(i,j,k)) endif if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) enddo enddo end if end if if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i,1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3,k) enddo enddo end if end if if (iprec.eq.0) then do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2)*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz end do end do end if if(nonos.eq.1) then c non-osscilatory option do 401 k=1,n3m km=ibcz*(k-1+(n3-k)/n3m*(n3-2))+iboz*max0(k-1,1 ) kp=ibcz*(k+1 -k /n3m*(n3-2))+iboz*min0(k+1,n3m) do 401 j=1,mp if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + iboy*1 else jm = j - 1 end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + iboy*mp else jp = j + 1 end if do 401 i=1,np if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + ibox*1 else im = i - 1 end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + ibox*np else ip = i + 1 end if mx(i,j,k)=amax1(x(im,j,k),x(i,j,k),x(ip,j,k),mx(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) 401 mn(i,j,k)=amin1(x(im,j,k),x(i,j,k),x(ip,j,k),mn(i,j,k), . x(i,jm,k),x(i,jp,k),x(i,j,kp),x(i,j,km)) iulim = np + 1*rightedge julim = mp + 1*topedge do 402 k=1,n3m do 402 j=1,mp do 402 i=1,iulim 402 f1(i,j,k)=donor(c2,c2,v1(i,j,k)) do 403 k=1,n3m do 403 j=1,julim do 403 i=1,np 403 f2(i,j,k)=donor(c2,c2,v2(i,j,k)) do 4033 k=1,n3 do 4033 j=1,mp do 4033 i=1,np 4033 f3(i,j,k)=donor(c2,c2,v3(i,j,k)) if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp,1) else call updatelr(f1,np+1,mp,l,np+1,mp,1) end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1,1) else call updatebt(f2,np,mp+1,l,np,mp+1,1) end if do 444 k=1,n3m do 444 j=1,mp do 444 i=1,np cp(i,j,k)=(mx(i,j,k)-x(i,j,k))*h(i,j,k)/ 1( pn(f1(i+1,j,k))+pp(f1(i,j,k)) 2 +pn(f2(i,j+1,k))+pp(f2(i,j,k)) 3 +pn(f3(i,j,k+1))+pp(f3(i,j,k))+ep) cn(i,j,k)=(x(i,j,k)-mn(i,j,k))*h(i,j,k)/ 1( pp(f1(i+1,j,k))+pn(f1(i,j,k)) 2 +pp(f2(i,j+1,k))+pn(f2(i,j,k)) 3 +pp(f3(i,j,k+1))+pn(f3(i,j,k))+ep) 444 continue call update2(cp,np,mp,l,np,mp,1) call update2(cn,np,mp,l,np,mp,1) illim = 1 + leftedge jllim = 1 + 1*botedge do k=1,n3m do j=1,mp do i=illim,np v1(i,j,k)= pp(v1(i,j,k))*amin1(1.,cp(i,j,k),cn(i-1,j,k)) * -pn(v1(i,j,k))*amin1(1.,cp(i-1,j,k),cn(i,j,k)) end do end do end do CAUTION: the following loop is coded to get around an apparent compiler problem on the T3D. do k=1,n3m do j=jllim,mp do i=1,np ct3d if (v2(i,j,k).ge.0.) then ct3d v2(i,j,k)= pp(v2(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j-1,k)) ct3d else ct3d v2(i,j,k)=-pn(v2(i,j,k))*amin1(1.,cp(i,j-1,k),cn(i,j,k)) ct3d end if v2(i,j,k)= pp(v2(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j-1,k)) . -pn(v2(i,j,k))*amin1(1.,cp(i,j-1,k),cn(i,j,k)) end do end do end do do k=2,n3m do j=1,mp do i=1,np v3(i,j,k)= pp(v3(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j,k-1)) * -pn(v3(i,j,k))*amin1(1.,cp(i,j,k-1),cn(i,j,k)) end do end do end do if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp,iupx) else call updatelr(v1,np+1,mp,l,np+1,mp,iupx) end if if (leftedge.eq.1) then do k=1,n3m do j=1,mp v1(1 ,j,k)=v1(-1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,n3m do j=1,mp v1(np+1,j,k)=v1(np+3,j,k) end do end do end if end if if (ibcy.eq.1) then if (topedge.eq.0) then call updatebt(v2,np,mp,l,np,mp+1,iupy) else call updatebt(v2,np,mp+1,l,np,mp+1,iupy) end if if (botedge.eq.1) then do k=1,n3m do i=1,np v2(i, 1,k)=v2(i,-1,k) end do end do end if if (topedge.eq.1) then do k=1,n3m do i=1,np v2(i,mp+1,k)=v2(i,mp+3,k) end do end do end if end if if (iprec.eq.0) then do j=1,mp do i=1,np v3(i,j, 1)=-v3(i,j, 2)*iboz+v3(i,j,n3m)*ibcz v3(i,j,n3)=-v3(i,j,n3m)*iboz+v3(i,j, 2 )*ibcz enddo enddo end if endif 30 continue 6 continue c optional removal of roundoff error negatives in positive fileds c if(iflg.lt.2.or.iflg.gt.5) then c do k=1,l c do j=1,m c do i=1,n c x(i,j,k)=amax1(0.,x(i,j,k)) c enddo c enddo c enddo c endif c goto 999 c optional enforcing of perodicity cccccccccccccccccccccccc cyclic boundary forcing cccccccccccccccccccccccc if (ibcx.eq.1) then call updatelr(x,np,mp,L,np,mp,1) if (rightedge.eq.1) then do k=1,l do j=1,mp x(np,j,k)=x(np+1,j,k) end do end do end if end if if (ibcy.eq.1) then call updatebt(x,np,mp,L,np,mp,1) if (topedge.eq.1) then do k=1,l do i=1,np x(i,mp,k)=x(i,mp+1,k) end do end do end if end if if (ibcz.eq.1) then do j=1,mp do i=1,np x(i,j,l)=x(i,j,1) end do end do end if ccccccccccccccccccccccccccccc cyclic boundary forcing done ccccccccccccccccccccccccccccc 999 continue call update(x,np,mp,l,np,mp,1) #if (TIMEPLT == 1) call ttend(35) #endif return end subroutine mp3bc(x,iflg,bcx,bcy,n1,n2,n3) include 'param.nml' include 'msg.inc' common/profB/ prfb(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd,3) dimension x(1-ih:np+ih,1-ih:mp+ih,l), . bcx(1-ih:mp+ih,n3,2), . bcy(1-ih:np+ih,n3,2) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . prf(1-ih:np+ih,1-ih:mp+ih,l,3), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/znave/ uza(mp,l,3),thza(mp,l),qvza(mmsp,lms), . bza(mmhdp,lmhd,3) #if (TIMEPLT == 1) call ttbeg(36) #endif #if (POLES == 0) if(iflg.eq.1) then ! ---> th if(implgw.eq.1) then if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. C +thza(1,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. C +thza(mp,k) enddo enddo end if else if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,1) bcx(j,k,2)=prf( 0,j,k,1) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,1) bcx(j,k,2)=prf(np,j,k,1) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,1) bcy(i,k,2)=prf(i, 0,k,1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,1) bcy(i,k,2)=prf(i,mp,k,1) enddo enddo end if endif goto 999 endif if(mhd.eq.1) then if(iflg.ge.31.and.iflg.le.33) then if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prfb( 1,j,k,iflg-30) bcx(j,k,2)=prfb( 0,j,k,iflg-30) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prfb(np+1,j,k,iflg-30) bcx(j,k,2)=prfb(np,j,k,iflg-30) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prfb(i, 1,k,iflg-30) bcy(i,k,2)=prfb(i, 0,k,iflg-30) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prfb(i,mp+1,k,iflg-30) bcy(i,k,2)=prfb(i,mp,k,iflg-30) enddo enddo end if return endif endif #if (MOISTMOD > 0) if(iflg.eq.11) then ! ---> thf if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,1) bcx(j,k,2)=prf( 0,j,k,1) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,1) bcx(j,k,2)=prf(np,j,k,1) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,1) bcy(i,k,2)=prf(i, 0,k,1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,1) bcy(i,k,2)=prf(i,mp,k,1) enddo enddo end if goto 999 endif #endif if(iflg.eq.2.or.iflg.eq.3) then ! ---> u0.v0 if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf( 1,j,k,iflg) bcx(j,k,2)=prf( 0,j,k,iflg) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=prf(np+1,j,k,iflg) bcx(j,k,2)=prf(np,j,k,iflg) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i, 1,k,iflg) C +uza(1,k,iflg-1) bcy(i,k,2)=prf(i, 0,k,iflg) C +uza(0,k,iflg-1) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=prf(i,mp+1,k,iflg) C +uza(mp+1,k,iflg-1) bcy(i,k,2)=prf(i,mp,k,iflg) C +uza(mp,k,iflg-1) enddo enddo end if goto 999 endif if(iflg.eq.51) then ! ---> fox if (leftedge.eq.1) then do k=1,n3 do j=1,n2 g110w=1./((1-icylind)*gmm(1,j,k)*cosa(1,j)+icylind*1.) g220w=1./gmm(1,j,k) g11w=strxx(1,j)*g110w g21w=strxy(1,j)*g220w bcx(j,k,1)=g11w*prf(1,j,k,2)+g21w*prf(1,j,k,3)+strxd(1,j) g110w=1./((1-icylind)*gmm(0,j,k)*cosa(0,j)+icylind*1.) g220w=1./gmm(0,j,k) g11w=strxx(0,j)*g110w g21w=strxy(0,j)*g220w bcx(j,k,2)=g11w*prf(0,j,k,2)+g21w*prf(0,j,k,3)+strxd(0,j) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 g110e=1./((1-icylind)*gmm(np+1,j,k)*cosa(np+1,j)+icylind*1.) g220e=1./gmm(np+1,j,k) g11e=strxx(np+1,j)*g110e g21e=strxy(np+1,j)*g220e bcx(j,k,1)=g11e*prf(np+1,j,k,2)+g21e*prf(np+1,j,k,3)+strxd(np+1,j) g110e=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g220e=1./gmm(np,j,k) g11e=strxx(np,j)*g110e g21e=strxy(np,j)*g220e bcx(j,k,2)=g11e*prf(np,j,k,2)+g21e*prf(np,j,k,3)+strxd(np,j) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 g110s=1./((1-icylind)*gmm(i,1,k)*cosa(i,1)+icylind*1.) g220s=1./gmm(i,1,k) g11s=strxx(i,1)*g110s g21s=strxy(i,1)*g220s bcy(i,k,1)=g11w*prf(i,1,k,2)+g21s*prf(i,1,k,3)+strxd(i,1) g110s=1./((1-icylind)*gmm(i,0,k)*cosa(i,0)+icylind*1.) g220s=1./gmm(i,0,k) g11s=strxx(i,0)*g110s g21s=strxy(i,0)*g220s bcy(i,k,2)=g11w*prf(i,0,k,2)+g21s*prf(i,0,k,3)+strxd(i,0) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 g110n=1./((1-icylind)*gmm(i,mp+1,k)*cosa(i,mp+1)+icylind*1.) g220n=1./gmm(i,mp+1,k) g11n=strxx(i,mp+1)*g110n g21n=strxy(i,mp+1)*g220n bcy(i,k,1)=g11n*prf(i,mp+1,k,2)+g21n*prf(i,mp+1,k,3)+strxd(i,mp+1) g110n=1./((1-icylind)*gmm(i,mp,k)*cosa(i,mp)+icylind*1.) g220n=1./gmm(i,mp,k) g11n=strxx(i,mp)*g110n g21n=strxy(i,mp)*g220n bcy(i,k,2)=g11n*prf(i,mp,k,2)+g21n*prf(i,mp,k,3)+strxd(i,mp) enddo enddo end if goto 999 endif if(iflg.eq.52) then ! ---> foy if (leftedge.eq.1) then do k=1,n3 do j=1,n2 g110w=1./((1-icylind)*gmm(1,j,k)*cosa(1,j)+icylind*1.) g220w=1./gmm(1,j,k) g12w=stryx(1,j)*g110w g22w=stryy(1,j)*g220w bcx(j,k,1)=g12w*prf(1,j,k,2)+g22w*prf(1,j,k,3)+stryd(1,j) g110w=1./((1-icylind)*gmm(0,j,k)*cosa(0,j)+icylind*1.) g220w=1./gmm(0,j,k) g12w=stryx(0,j)*g110w g22w=stryy(0,j)*g220w bcx(j,k,2)=g12w*prf(0,j,k,2)+g22w*prf(0,j,k,3)+stryd(0,j) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 g110e=1./((1-icylind)*gmm(np+1,j,k)*cosa(np+1,j)+icylind*1.) g220e=1./gmm(np+1,j,k) g12e=stryx(np+1,j)*g110e g22e=stryy(np+1,j)*g220e bcx(j,k,1)=g12e*prf(np+1,j,k,2)+g22e*prf(np+1,j,k,3)+stryd(np+1,j) g110e=1./((1-icylind)*gmm(np,j,k)*cosa(np,j)+icylind*1.) g220e=1./gmm(np,j,k) g12e=stryx(np,j)*g110e g22e=stryy(np,j)*g220e bcx(j,k,2)=g12e*prf(np,j,k,2)+g22e*prf(np,j,k,3)+stryd(np,j) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 g110s=1./((1-icylind)*gmm(i,1,k)*cosa(i,1)+icylind*1.) g220s=1./gmm(i,1,k) g12s=stryx(i,1)*g110s g22s=stryy(i,1)*g220s bcy(i,k,1)=g12s*prf(i,1,k,2)+g22s*prf(i,1,k,3)+stryd(i,1) g110s=1./((1-icylind)*gmm(i,0,k)*cosa(i,0)+icylind*1.) g220s=1./gmm(i,0,k) g12s=stryx(i,0)*g110s g22s=stryy(i,0)*g220s bcy(i,k,2)=g12s*prf(i,0,k,2)+g22s*prf(i,0,k,3)+stryd(i,0) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 g110n=1./((1-icylind)*gmm(i,mp+1,k)*cosa(i,mp+1)+icylind*1.) g220n=1./gmm(i,mp+1,k) g12n=stryx(i,mp+1)*g110n g22n=stryy(i,mp+1)*g220n bcy(i,k,1)=g12n*prf(i,mp+1,k,2)+g22n*prf(i,mp+1,k,3)+stryd(i,mp+1) g110n=1./((1-icylind)*gmm(i,mp,k)*cosa(i,mp)+icylind*1.) g220n=1./gmm(i,mp,k) g12n=stryx(i,mp)*g110n g22n=stryy(i,mp)*g220n bcy(i,k,2)=g12n*prf(i,mp,k,2)+g22n*prf(i,mp,k,3)+stryd(i,mp) enddo enddo end if goto 999 endif if(iflg.eq.4.or.iflg.eq.53.or.iflg.eq.12) then ! w0| foz |ftf,fqv,fqc,fqr if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. C +uza(1,k,3) bcy(i,k,2)=0. C +uza(0,k,3) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. C +uza(mp+1,k,3) bcy(i,k,2)=0. C +uza(mp,k,3) enddo enddo end if goto 999 endif #if (MOISTMOD > 0) if(iflg.eq.6) then ! ---> qv if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=qve( 1,j,k) bcx(j,k,2)=qve( 0,j,k) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=qve(np+1,j,k) bcx(j,k,2)=qve(np,j,k) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=qve(i, 1,k) bcy(i,k,2)=qve(i, 0,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=qve(i,mp+1,k) bcy(i,k,2)=qve(i,mp,k) enddo enddo end if goto 999 endif if(iflg.ge.7) then ! ---> qc if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. enddo enddo end if goto 999 endif #endif #endif 999 continue #if (TIMEPLT == 1) call ttend(36) #endif return end #endif /* J3DIM == 1 */ #endif /* SEMILAG == 0 */ #if (SEMILAG == 1) subroutine interp(xf,xd1,xd2,xd3,ifirst) include 'param.nml' include 'msg.inc' dimension xf(1-ih:np+ih,1-ih:mp+ih,l), . xd1(1-ih:np+ih,1-ih:mp+ih,l), . xd2(1-ih:np+ih,1-ih:mp+ih,l), . xd3(1-ih:np+ih,1-ih:mp+ih,l) C return #if (TIMEPLT == 1) call ttbeg(37) #endif #if (J3DIM == 1) call inter3(xf,xd1,xd2,xd3,ifirst) #else call inter2(xf,xd1,xd3,ifirst) #endif #if (TIMEPLT == 1) call ttend(37) #endif return end #if (J3DIM == 0) subroutine inter2(xf,xd1,xd2,ifirst) c ior=order of accuracy/2; only even order trmback schemes are considered include 'param.ior' include 'param.nml' include 'msg.inc' parameter(nonos=1) c NOTE: ihlag must be >= (ior + 1) dimension xf(1-ih:np+ih,1-ih:mp+ih,l), . xd1(1-ih:np+ih,1-ih:mp+ih,l), . xd2(1-ih:np+ih,1-ih:mp+ih,l) parameter(n1=n,n2=l,nn=n1*n2) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(ixa=(np+2*ihlag+2*ior)*(mp+2*ihlag+2*ior)*(n2+2*ior)) parameter(ifree=14*iarray-(2*ior+1)*iarray-ixa) common/blank/ x(1-ior-ihlag:np+ior+ihlag, . 1-ior-ihlag:mp+ior+ihlag, . 1-ior:n2+ior), . z(1-ih:np+ih,1-ih:mp+ih,l, -ior:ior), . ig0(1-ih:np+ih,1-ih:mp+ih,l), . jg0(1-ih:np+ih,1-ih:mp+ih,l), . scr(ifree) #if (PARALLEL>0) common /slag/ iloc(np,mp,l,-ior:ior),jloc(np,mp,l,-ior:ior) #endif real mx,mn data ep/ 1.e-10/ common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc c donor(y1,y2,a)=amax1(0.,a)*y1+amin1(0.,a)*y2 tr2(y1,y2,a)=a*.5*(y1+y2)-a**2*.5*(y2-y1) tr4(ym1,y0,yp1,yp2,a)=a/12.*(7.*(yp1+y0)-(yp2+ym1)) 1 -a**2/24.*(15.*(yp1-y0)-(yp2-ym1))-a**3/12.*((yp1+y0) 2 -(yp2+ym1))+a**4/24.*(3.*(yp1-y0)-(yp2-ym1)) tr6(ym2,ym1,y0,yp1,yp2,yp3,a)=-a/60.*(-ym2+8.*ym1-37.*y0 1 -37.*yp1+8.*yp2-yp3) 2-a**2/360.*(-2.*ym2+25.*ym1-245.*y0+245.*yp1-25.*yp2+2.*yp3) 3-a**3/48.*(ym2-7.*ym1+6.*y0+6.*yp1-7.*yp2+yp3) 4-a**4/144.*(ym2-11.*ym1+28.*y0-28.*yp1+11.*yp2-yp3) 5-a**5/240.*(-ym2+3.*ym1-2.*y0-2.*yp1+3.*yp2-yp3) 6-a**6/720.*(-ym2+5.*ym1-10.*y0+10.*yp1-5.*yp2+yp3) pp(xi)=amax1(0.,xi) pn(xi)=amin1(0.,xi) c do 1 j=1,n2 do 1 i=1,np ig0(i,1,j)=nint(xd1(i,1,j)) 1 jg0(i,1,j)=nint(xd2(i,1,j)) c grid extension for bc removal do 509 j=1,n2 do 509 i=1,np 509 x(i,1,j)=xf(i,1,j) do 5091 is=1,ior do 5092 i=1,np x(i,1, 1-is)=(1-ibcz)*xf(i,1, 1)+ibcz*x(i,1,n2-is) 5092 x(i,1,n2+is)=(1-ibcz)*xf(i,1,n2)+ibcz*x(i,1, 1+is) 5091 continue #if (PARALLEL > 0) #if (POLES == 0) if(ibcx.eq.1) call updatelagr(x,np,mp,(n2+2*ior),np,mp,ior+1) if (leftedge.eq.1) then do 5071 j=-ior+1,n2+ior do is=-ior+1,1 x(is,1,j)=x(1,1,j)*(1-ibcx)+ibcx*x(is-ior-1,1,j) end do 5071 continue end if if(ibcx.eq.1) call updatelagr(x,np,mp,(n2+2*ior),np,mp,ior+1) if (rightedge.eq.1) then do 5072 j=-ior+1,n2+ior do is=0,ior x(np+is,1,j)=x(np,1,j)*(1-ibcx)+ibcx*x(np+ior+1+is,1,j) end do 5072 continue end if #endif call updatelagr(x,np,mp,(n2+2*ior),np,mp,ihlag) #else #if (POLES == 0) do 507 is=0,ior do 5071 j=-ior+1,n2+ior x( 1-is,1,j)=x( 1,1,j)*(1-ibcx)+ibcx*x(np-is,1,j) 5071 x(np+is,1,j)=x(np,1,j)*(1-ibcx)+ibcx*x( 1+is,1,j) 507 continue #else do 507 is=0,ior do 5071 j=-ior+1,n2+ior x( 1-is,1,j)=x(np-is,1,j) 5071 x(np+is,1,j)=x( 1+is,1,j) 507 continue #endif #endif c end of grid extension c c c here starts rezidual advection c do 50 j=-ior,ior c if(liner.eq.1) then do 211 jj=1,n2 do 211 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-1 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ym1=x(iloc(ii,1,jj,-1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, 1),1,jg0(ii,1,jj)+j) #else ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) #endif fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) 211 z(ii,1,jj,j)=y0-(fl1-fl0) go to 50 endif c if(ior.eq.1) then if(nonos.eq.1) then do 311 jj=1,n2 do 311 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,1,jj)-1 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il if (jj.eq.n2 .and. ii.eq.np . .and. j.eq.ior) ifirst=0 end if ym1=x(iloc(ii,1,jj,-1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, 1),1,jg0(ii,1,jj)+j) #else ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) #endif f0=tr2(ym1, y0,u) f1=tr2(y0 ,yp1,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 311 z(ii,1,jj,j)=w-(f1-f0) else do 321 jj=1,n2 do 321 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-1 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ym1=x(iloc(ii,1,jj,-1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, 1),1,jg0(ii,1,jj)+j) #else ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) #endif f0=tr2(ym1, y0,u) f1=tr2(y0 ,yp1,u) 321 z(ii,1,jj,j)=y0-(f1-f0) endif endif c if(ior.eq.2) then il2=-ior ir2= ior if(nonos.eq.1) then do 312 jj=1,n2 do 312 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-2 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il2)=il ia=ig0(ii,1,jj)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ia=ig0(ii,1,jj)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir2)=il ym2=x(iloc(ii,1,jj,il2),1,jg0(ii,1,jj)+j) ym1=x(iloc(ii,1,jj, -1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, +1),1,jg0(ii,1,jj)+j) yp2=x(iloc(ii,1,jj,ir2),1,jg0(ii,1,jj)+j) #else ym2=x(ig0(ii,1,jj)-2,1,jg0(ii,1,jj)+j) ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) yp2=x(ig0(ii,1,jj)+2,1,jg0(ii,1,jj)+j) #endif f0=tr4(ym2,ym1,y0 ,yp1,u) f1=tr4(ym1,y0 ,yp1,yp2,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 312 z(ii,1,jj,j)=w-(f1-f0) else do 322 jj=1,n2 do 322 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-2 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il2)=il ia=ig0(ii,1,jj)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ia=ig0(ii,1,jj)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir2)=il ym2=x(iloc(ii,1,jj,il2),1,jg0(ii,1,jj)+j) ym1=x(iloc(ii,1,jj, -1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, +1),1,jg0(ii,1,jj)+j) yp2=x(iloc(ii,1,jj,ir2),1,jg0(ii,1,jj)+j) #else ym2=x(ig0(ii,1,jj)-2,1,jg0(ii,1,jj)+j) ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) yp2=x(ig0(ii,1,jj)+2,1,jg0(ii,1,jj)+j) #endif f0=tr4(ym2,ym1,y0 ,yp1,u) f1=tr4(ym1,y0 ,yp1,yp2,u) 322 z(ii,1,jj,j)=y0-(f1-f0) endif endif c if(ior.eq.3) then il3=-ior il2=-ior+1 il2= ior-1 il3= ior if(nonos.eq.1) then do 313 jj=1,n2 do 313 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-3 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il3)=il ia=ig0(ii,1,jj)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il2)=il ia=ig0(ii,1,jj)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ia=ig0(ii,1,jj)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir2)=il ia=ig0(ii,1,jj)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir3)=il ym3=x(iloc(ii,1,jj,il3),1,jg0(ii,1,jj)+j) ym2=x(iloc(ii,1,jj,il2),1,jg0(ii,1,jj)+j) ym1=x(iloc(ii,1,jj, -1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, +1),1,jg0(ii,1,jj)+j) yp2=x(iloc(ii,1,jj,ir2),1,jg0(ii,1,jj)+j) yp3=x(iloc(ii,1,jj,ir3),1,jg0(ii,1,jj)+j) #else ym3=x(ig0(ii,1,jj)-3,1,jg0(ii,1,jj)+j) ym2=x(ig0(ii,1,jj)-2,1,jg0(ii,1,jj)+j) ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) yp2=x(ig0(ii,1,jj)+2,1,jg0(ii,1,jj)+j) yp3=x(ig0(ii,1,jj)+3,1,jg0(ii,1,jj)+j) #endif f0=tr6(ym3,ym2,ym1,y0 ,yp1,yp2,u) f1=tr6(ym2,ym1,y0 ,yp1,yp2,yp3,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 313 z(ii,1,jj,j)=w-(f1-f0) else do 323 jj=1,n2 do 323 ii=1,np u=ig0(ii,1,jj)-xd1(ii,1,jj) #if (PARALLEL>0) ia=ig0(ii,1,jj)-3 ja=1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il3)=il ia=ig0(ii,1,jj)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,il2)=il ia=ig0(ii,1,jj)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-1)=il ia=ig0(ii,1,jj) call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,0)=il ia=ig0(ii,1,jj)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,1)=il ia=ig0(ii,1,jj)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir2)=il ia=ig0(ii,1,jj)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,ir3)=il ym3=x(iloc(ii,1,jj,il3),1,jg0(ii,1,jj)+j) ym2=x(iloc(ii,1,jj,il2),1,jg0(ii,1,jj)+j) ym1=x(iloc(ii,1,jj, -1),1,jg0(ii,1,jj)+j) y0 =x(iloc(ii,1,jj, 0),1,jg0(ii,1,jj)+j) yp1=x(iloc(ii,1,jj, +1),1,jg0(ii,1,jj)+j) yp2=x(iloc(ii,1,jj,ir2),1,jg0(ii,1,jj)+j) yp3=x(iloc(ii,1,jj,ir3),1,jg0(ii,1,jj)+j) #else ym3=x(ig0(ii,1,jj)-3,1,jg0(ii,1,jj)+j) ym2=x(ig0(ii,1,jj)-2,1,jg0(ii,1,jj)+j) ym1=x(ig0(ii,1,jj)-1,1,jg0(ii,1,jj)+j) y0 =x(ig0(ii,1,jj) ,1,jg0(ii,1,jj)+j) yp1=x(ig0(ii,1,jj)+1,1,jg0(ii,1,jj)+j) yp2=x(ig0(ii,1,jj)+2,1,jg0(ii,1,jj)+j) yp3=x(ig0(ii,1,jj)+3,1,jg0(ii,1,jj)+j) #endif f0=tr6(ym3,ym2,ym1,y0 ,yp1,yp2,u) f1=tr6(ym2,ym1,y0 ,yp1,yp2,yp3,u) 323 z(ii,1,jj,j)=y0-(f1-f0) endif endif c c 50 continue c if(liner.eq.1) then do 212 jj=1,n2 do 212 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) fl0=donor(z(ii,1,jj,-1),z(ii,1,jj,0),u) fl1=donor(z(ii,1,jj, 0),z(ii,1,jj,1),u) 212 xf(ii,1,jj)=z(ii,1,jj,0)-(fl1-fl0) call update(xf,np,mp,n2,np,mp,1) goto 500 endif c if(ior.eq.1) then if(nonos.eq.1) then do 411 jj=1,n2 do 411 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr2(z(ii,1,jj,-1),z(ii,1,jj,0),u) f1=tr2(z(ii,1,jj, 0),z(ii,1,jj,1),u) fl0=donor(z(ii,1,jj,-1),z(ii,1,jj,0),u) fl1=donor(z(ii,1,jj, 0),z(ii,1,jj,1),u) w=z(ii,1,jj,0)-(fl1-fl0) mx=amax1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) mn=amin1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,1,jj)=w-(f1-f0) 411 continue else do 421 jj=1,n2 do 421 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr2(z(ii,1,jj,-1),z(ii,1,jj,0),u) f1=tr2(z(ii,1,jj, 0),z(ii,1,jj,1),u) 421 xf(ii,1,jj)=z(ii,1,jj,0)-(f1-f0) endif endif if(ior.eq.2) then if(nonos.eq.1) then do 412 jj=1,n2 do 412 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr4(z(ii,1,jj,il2),z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),u) f1=tr4(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),z(ii,1,jj,ir2),u) fl0=donor(z(ii,1,jj,-1),z(ii,1,jj,0),u) fl1=donor(z(ii,1,jj, 0),z(ii,1,jj,1),u) w=z(ii,1,jj,0)-(fl1-fl0) mx=amax1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) mn=amin1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,1,jj)=w-(f1-f0) 412 continue else do 422 jj=1,n2 do 422 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr4(z(ii,1,jj,il2),z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),u) f1=tr4(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),z(ii,1,jj,ir2),u) 422 xf(ii,1,jj)=z(ii,1,jj,0)-(f1-f0) endif endif if(ior.eq.3) then if(nonos.eq.1) then do 413 jj=1,n2 do 413 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr6(z(ii,1,jj,il3),z(ii,1,jj,il2),z(ii,1,jj,-1),z(ii,1,jj,0), 1 z(ii,1,jj, 1),z(ii,1,jj,ir2),u) f1=tr6(z(ii,1,jj,il2),z(ii,1,jj, -1),z(ii,1,jj, 0),z(ii,1,jj,1), 1 z(ii,1,jj,ir2),z(ii,1,jj,ir3),u) fl0=donor(z(ii,1,jj,-1),z(ii,1,jj,0),u) fl1=donor(z(ii,1,jj, 0),z(ii,1,jj,1),u) w=z(ii,1,jj,0)-(fl1-fl0) mx=amax1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) mn=amin1(z(ii,1,jj,-1),z(ii,1,jj,0),z(ii,1,jj,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,1,jj)=w-(f1-f0) 413 continue else do 423 jj=1,n2 do 423 ii=1,np u=jg0(ii,1,jj)-xd2(ii,1,jj) f0=tr6(z(ii,1,jj,il3),z(ii,1,jj,il2),z(ii,1,jj,-1),z(ii,1,jj,0), 1 z(ii,1,jj, 1),z(ii,1,jj,ir2),u) f1=tr6(z(ii,1,jj,il2),z(ii,1,jj, -1),z(ii,1,jj, 0),z(ii,1,jj,1), 1 z(ii,1,jj,ir2),z(ii,1,jj,ir3),u) 423 xf(ii,1,jj)=z(ii,1,jj,0)-(f1-f0) endif endif 500 continue #if (POLES == 0) goto 999 cccccccccccccccccccccccc cyclic boundary forcing cccccccccccccccccccccccc if (ibcx.eq.1) then call updatelr(xf,np,mp,n2,np,mp,1) if (rightedge.eq.1) then do k=1,l do j=1,mp xf(np,j,k)=xf(np+1,j,k) end do end do end if end if if (ibcz.eq.1) then do j=1,mp do i=1,np xf(i,j,l)=xf(i,j,1) end do end do end if ccccccccccccccccccccccccccccc cyclic boundary forcing done ccccccccccccccccccccccccccccc 999 continue #endif call update(xf,np,mp,n2,np,mp,1) return end #else subroutine inter3(xf,xd1,xd2,xd3,ifirst) c ior=order of accuracy/2; only even order trmback schemes are considered include 'param.ior' include 'param.nml' include 'msg.inc' parameter(nonos=1) parameter(n1=n,n2=m,n3=l,nn=n1*n2*n3) c NOTE: ihlag must be >= (ior + 1) dimension xf(1-ih:np+ih,1-ih:mp+ih,l), . xd1(1-ih:np+ih,1-ih:mp+ih,l), . xd2(1-ih:np+ih,1-ih:mp+ih,l), . xd3(1-ih:np+ih,1-ih:mp+ih,l) dimension ig0(1-ih:np+ih,1-ih:mp+ih,l), . jg0(1-ih:np+ih,1-ih:mp+ih,l), . kg0(1-ih:np+ih,1-ih:mp+ih,l) dimension x(1-ior-ihlag:np+ior+ihlag, . 1-ior-ihlag:mp+ior+ihlag,1-ior:n3+ior) parameter(iarray=(np+2*ih)*(mp+2*ih)*l) parameter(ixa=(np+2*ihlag+2*ior)*(mp+2*ihlag+2*ior)*(n3+2*ior)) parameter(ifree=16*iarray-2*(2*ior+1)*iarray) c parameter(ifree=16*iarray-2*(2*ior+1)*iarray-ixa) common/blank/ y(1-ih:np+ih, 1-ih:mp+ih, l, -ior:ior), . z(1-ih:np+ih, 1-ih:mp+ih, l, -ior:ior), . scr(ifree) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (PARALLEL>0) common /slag/ iloc(np,mp,n3,-ior:ior),jloc(np,mp,n3,-ior:ior) #endif common/mpfil/ liner,mpfl,ampd(1-ih:1+ih,1-ih:mp+ih,3),kampd(3) data ep/1.e-10/ real mx,mn donor(y1,y2,a)=amax1(0.,a)*y1+amin1(0.,a)*y2 tr2(y1,y2,a)=a*.5*(y1+y2)-a**2*.5*(y2-y1) tr4(ym1,y0,yp1,yp2,a)=a/12.*(7.*(yp1+y0)-(yp2+ym1)) 1 -a**2/24.*(15.*(yp1-y0)-(yp2-ym1))-a**3/12.*((yp1+y0) 2 -(yp2+ym1))+a**4/24.*(3.*(yp1-y0)-(yp2-ym1)) tr6(ym2,ym1,y0,yp1,yp2,yp3,a)=-a/60.*(-ym2+8.*ym1-37.*y0 1 -37.*yp1+8.*yp2-yp3) 2-a**2/360.*(-2.*ym2+25.*ym1-245.*y0+245.*yp1-25.*yp2+2.*yp3) 3-a**3/48.*(ym2-7.*ym1+6.*y0+6.*yp1-7.*yp2+yp3) 4-a**4/144.*(ym2-11.*ym1+28.*y0-28.*yp1+11.*yp2-yp3) 5-a**5/240.*(-ym2+3.*ym1-2.*y0-2.*yp1+3.*yp2-yp3) 6-a**6/720.*(-ym2+5.*ym1-10.*y0+10.*yp1-5.*yp2+yp3) pp(xi)=amax1(0.,xi) pn(xi)=amin1(0.,xi) c do kk=1,l do jj=1,mp do ii=1,np ig0(ii,jj,kk)=nint(xd1(ii,jj,kk)) jg0(ii,jj,kk)=nint(xd2(ii,jj,kk)) kg0(ii,jj,kk)=nint(xd3(ii,jj,kk)) end do end do end do c c grid extension for bc removal do 507 k=1,n3 do 507 j=1,mp do 507 i=1,np 507 x(i,j,k)=xf(i,j,k) do 5071 is=1,ior do 5072 j=1,mp do 5072 i=1,np x(i,j, 1-is)=(1-ibcz)*xf(i,j, 1)+ibcz*x(i,j,n3-is) 5072 x(i,j,n3+is)=(1-ibcz)*xf(i,j,n3)+ibcz*x(i,j, 1+is) 5071 continue #if (PARALLEL > 0) #if (POLES == 0) if(ibcy.eq.1) call updatelagr(x,np,mp,(n3+2*ior),np,mp,ior+1) if (botedge.eq.1) then do is=1,ior do k=-ior+1,n3+ior do i=1,np x(i,1 -is,k)=x(i, 1,k)*(1-ibcy)+ibcy*x(i,(1-ior-is-1),k) end do end do end do end if if(ibcy.eq.1) call updatelagr(x,np,mp,(n3+2*ior),np,mp,ior+1) if (topedge.eq.1) then do is=1,ior do k=-ior+1,n3+ior do i=1,np x(i,mp+is,k)=x(i,mp,k)*(1-ibcy)+ibcy*x(i,mp+ior+1+is,k) end do end do end do end if if(ibcx.eq.1) call updatelagr(x,np,mp,(n3+2*ior),np,mp,ior+1) if (leftedge.eq.1) then jllim = 1 - ior*botedge julim = mp + ior*topedge do is=1,ior do k=-ior+1,n3+ior do j=jllim,julim x( 1-is,j,k)=x( 1,j,k)*(1-ibcx)+ibcx*x(1-ior-is-1,j,k) end do end do end do end if if(ibcx.eq.1) call updatelagr(x,np,mp,(n3+2*ior),np,mp,ior+1) if (rightedge.eq.1) then jllim = 1 - ior*botedge julim = mp + ior*topedge do is=1,ior do k=-ior+1,n3+ior do j=jllim,julim x(np+is,j,k)=x(np,j,k)*(1-ibcx)+ibcx*x(np+ior+1+is,j,k) end do end do end do end if #endif call updatelagr(x,np,mp,(n3+2*ior),np,mp,ihlag) #else #if (POLES == 0) do 508 is=1,ior do 5081 k=-ior+1,n3+ior do 5081 i=1,np x(i,1 -is,k)=x(i, 1,k)*(1-ibcy)+ibcy*x(i,mp-is,k) 5081 x(i,mp+is,k)=x(i,mp,k)*(1-ibcy)+ibcy*x(i, 1+is,k) 508 continue do 509 is=1,ior do 5091 k=-ior+1,n3+ior do 5091 j=-ior+1,mp+ior x( 1-is,j,k)=x( 1,j,k)*(1-ibcx)+ibcx*x(np-is,j,k) 5091 x(np+is,j,k)=x(np,j,k)*(1-ibcx)+ibcx*x( 1+is,j,k) 509 continue #else do 508 is=1,ior do 5081 k=-ior+1,n3+ior do 5081 i=1,np x(i,1 -is,k)=x(i,mp-is,k) 5081 x(i,mp+is,k)=x(i, 1+is,k) 508 continue do 509 is=1,ior do 5091 k=-ior+1,n3+ior do 5091 j=-ior+1,mp+ior x( 1-is,j,k)=x(np-is,j,k) 5091 x(np+is,j,k)=x( 1+is,j,k) 509 continue #endif #endif c c here starts rezidual advection c do 60 k=-ior,ior do 50 j=-ior,ior c if(liner.eq.1) then do 211 kk=1,n3 do 211 jj=1,mp do 211 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-1 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il end if ym1=x(iloc(ii,jj,kk,-1),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) #else ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) 211 z(ii,jj,kk,j)=y0-(fl1-fl0) go to 50 endif c if(ior.eq.1) then if(nonos.eq.1) then do 3110 kk=1,n3 do 3110 jj=1,mp do 3110 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-1 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il jloc(ii,jj,kk,j) =jl end if ym1=x(iloc(ii,jj,kk,-1),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) if (ifirst.eq.1) then ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il end if y0 =x(iloc(ii,jj,kk,0),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il if (kk.eq.n3 .and. jj.eq.mp .and. ii.eq.np . .and. j.eq.ior) ifirst=0 end if yp1=x(iloc(ii,jj,kk,1),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) #else ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr2(ym1, y0,u) f1=tr2(y0 ,yp1,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 3110 z(ii,jj,kk,j)=w-(f1-f0) else do 321 kk=1,n3 do 321 jj=1,mp do 321 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-1 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il end if ym1=x(iloc(ii,jj,kk,-1),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,+1),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) #else ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr2(ym1, y0,u) f1=tr2(y0 ,yp1,u) 321 z(ii,jj,kk,j)=y0-(f1-f0) endif endif c if(ior.eq.2) then il2=-ior ir2= ior if(nonos.eq.1) then do 312 kk=1,n3 do 312 jj=1,mp do 312 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-2 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il2)=il ! iloc(ii,jj,kk,-2) jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il ia=ig0(ii,jj,kk)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir2)=il ! iloc(ii,jj,kk,2) end if ym2=x(iloc(ii,jj,kk,il2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-2) ym1=x(iloc(ii,jj,kk,-1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,+1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp2=x(iloc(ii,jj,kk,ir2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,2) #else ym2=x(ig0(ii,jj,kk)-2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp2=x(ig0(ii,jj,kk)+2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr4(ym2,ym1,y0 ,yp1,u) f1=tr4(ym1,y0 ,yp1,yp2,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 312 z(ii,jj,kk,j)=w-(f1-f0) else do 322 kk=1,n3 do 322 jj=1,mp do 322 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-2 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il2)=il ! iloc(ii,jj,kk,-2) jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il ia=ig0(ii,jj,kk)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir2)=il ! iloc(ii,jj,kk,2) end if ym2=x(iloc(ii,jj,kk,il2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-2) ym1=x(iloc(ii,jj,kk,-1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,+1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp2=x(iloc(ii,jj,kk,ir2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,2) #else ym2=x(ig0(ii,jj,kk)-2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp2=x(ig0(ii,jj,kk)+2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr4(ym2,ym1,y0 ,yp1,u) f1=tr4(ym1,y0 ,yp1,yp2,u) 322 z(ii,jj,kk,j)=y0-(f1-f0) endif endif c if(ior.eq.3) then il3=-ior il2=-ior+1 ir2= ior-1 ir3= ior if(nonos.eq.1) then do 313 kk=1,n3 do 313 jj=1,mp do 313 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-3 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il3)=il ! iloc(ii,jj,kk,-3) jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il2)=il ! iloc(ii,jj,kk,-2) ia=ig0(ii,jj,kk)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il ia=ig0(ii,jj,kk)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir2)=il ! iloc(ii,jj,kk,2) ia=ig0(ii,jj,kk)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir3)=il ! iloc(ii,jj,kk,3) end if ym3=x(iloc(ii,jj,kk,il3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-3) ym2=x(iloc(ii,jj,kk,il2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-2) ym1=x(iloc(ii,jj,kk,-1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,+1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp2=x(iloc(ii,jj,kk,ir2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,2) yp3=x(iloc(ii,jj,kk,ir3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,3) #else ym3=x(ig0(ii,jj,kk)-3,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym2=x(ig0(ii,jj,kk)-2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp2=x(ig0(ii,jj,kk)+2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp3=x(ig0(ii,jj,kk)+3,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr6(ym3,ym2,ym1,y0 ,yp1,yp2,u) f1=tr6(ym2,ym1,y0 ,yp1,yp2,yp3,u) fl0=donor(ym1, y0,u) fl1=donor(y0 ,yp1,u) w=y0-(fl1-fl0) mx=amax1(ym1,y0,yp1,w) mn=amin1(ym1,y0,yp1,w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov 313 z(ii,jj,kk,j)=w-(f1-f0) else do 323 kk=1,n3 do 323 jj=1,mp do 323 ii=1,np u=ig0(ii,jj,kk)-xd1(ii,jj,kk) #if (PARALLEL>0) if (ifirst.eq.1) then ia=ig0(ii,jj,kk)-3 ja=jg0(ii,jj,kk)+j call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il3)=il ! iloc(ii,jj,kk,-3) jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,il2)=il ! iloc(ii,jj,kk,-2) ia=ig0(ii,jj,kk)-1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-1)=il ia=ig0(ii,jj,kk) call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,0)=il ia=ig0(ii,jj,kk)+1 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,1)=il ia=ig0(ii,jj,kk)+2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir2)=il ! iloc(ii,jj,kk,2) ia=ig0(ii,jj,kk)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,ir3)=il ! iloc(ii,jj,kk,3) end if ym3=x(iloc(ii,jj,kk,il3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-3) ym2=x(iloc(ii,jj,kk,il2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,-2) ym1=x(iloc(ii,jj,kk,-1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) y0 =x(iloc(ii,jj,kk,0) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp1=x(iloc(ii,jj,kk,+1) ,jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp2=x(iloc(ii,jj,kk,ir2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,2) yp3=x(iloc(ii,jj,kk,ir3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ! iloc(ii,jj,kk,3) #else ym3=x(ig0(ii,jj,kk)-3,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym2=x(ig0(ii,jj,kk)-2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) ym1=x(ig0(ii,jj,kk)-1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) y0 =x(ig0(ii,jj,kk) ,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp1=x(ig0(ii,jj,kk)+1,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp2=x(ig0(ii,jj,kk)+2,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) yp3=x(ig0(ii,jj,kk)+3,jg0(ii,jj,kk)+j,kg0(ii,jj,kk)+k) #endif f0=tr6(ym3,ym2,ym1,y0 ,yp1,yp2,u) f1=tr6(ym2,ym1,y0 ,yp1,yp2,yp3,u) 323 z(ii,jj,kk,j)=y0-(f1-f0) endif endif c c 50 continue c if(liner.eq.1) then do 212 kk=1,n3 do 212 jj=1,mp do 212 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) fl0=donor(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) fl1=donor(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) 212 y(ii,jj,kk,k)=z(ii,jj,kk,0)-(fl1-fl0) go to 60 endif c if(ior.eq.1) then if(nonos.eq.1) then do 411 kk=1,n3 do 411 jj=1,mp do 411 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr2(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) f1=tr2(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) fl0=donor(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) fl1=donor(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) w=z(ii,jj,kk,0)-(fl1-fl0) mx=amax1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) mn=amin1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov y(ii,jj,kk,k)=w-(f1-f0) 411 continue else do 421 kk=1,n3 do 421 jj=1,mp do 421 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr2(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) f1=tr2(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) 421 y(ii,jj,kk,k)=z(ii,jj,kk,0)-(f1-f0) endif endif if(ior.eq.2) then if(nonos.eq.1) then do 412 kk=1,n3 do 412 jj=1,mp do 412 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr4(z(ii,jj,kk,il2),z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1), . u) f1=tr4(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),z(ii,jj,kk,ir2), . u) fl0=donor(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) fl1=donor(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) w=z(ii,jj,kk,0)-(fl1-fl0) mx=amax1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) mn=amin1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov y(ii,jj,kk,k)=w-(f1-f0) 412 continue else do 422 kk=1,n3 do 422 jj=1,mp do 422 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr4(z(ii,jj,kk,il2),z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1), . u) f1=tr4(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),z(ii,jj,kk,ir2), . u) 422 y(ii,jj,kk,k)=z(ii,jj,kk,0)-(f1-f0) endif endif if(ior.eq.3) then if(nonos.eq.1) then do 413 kk=1,n3 do 413 jj=1,mp do 413 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr6(z(ii,jj,kk,il3),z(ii,jj,kk,il2),z(ii,jj,kk, -1), . z(ii,jj,kk, 0),z(ii,jj,kk, 1),z(ii,jj,kk,ir2),u) f1=tr6(z(ii,jj,kk,il2),z(ii,jj,kk, -1),z(ii,jj,kk, 0), . z(ii,jj,kk, 1),z(ii,jj,kk,ir2),z(ii,jj,kk,ir3),u) fl0=donor(z(ii,jj,kk,-1),z(ii,jj,kk,0),u) fl1=donor(z(ii,jj,kk, 0),z(ii,jj,kk,1),u) w=z(ii,jj,kk,0)-(fl1-fl0) mx=amax1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) mn=amin1(z(ii,jj,kk,-1),z(ii,jj,kk,0),z(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov y(ii,jj,kk,k)=w-(f1-f0) 413 continue else do 423 kk=1,n3 do 423 jj=1,mp do 423 ii=1,np u=jg0(ii,jj,kk)-xd2(ii,jj,kk) f0=tr6(z(ii,jj,kk,il3),z(ii,jj,kk,il2),z(ii,jj,kk, -1), . z(ii,jj,kk, 0),z(ii,jj,kk, 1),z(ii,jj,kk,ir2),u) f1=tr6(z(ii,jj,kk,il2),z(ii,jj,kk, -1),z(ii,jj,kk, 0), . z(ii,jj,kk, 1),z(ii,jj,kk,ir2),z(ii,jj,kk,ir3),u) 423 y(ii,jj,kk,k)=z(ii,jj,kk,0)-(f1-f0) endif endif 60 continue c c c if(liner.eq.1) then do 612 kk=1,n3 do 612 jj=1,mp do 612 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) fl0=donor(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) fl1=donor(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) 612 xf(ii,jj,kk)=y(ii,jj,kk,0)-(fl1-fl0) goto 500 endif c if(ior.eq.1) then if(nonos.eq.1) then do 711 kk=1,n3 do 711 jj=1,mp do 711 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr2(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) f1=tr2(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) fl0=donor(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) fl1=donor(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) w=y(ii,jj,kk,0)-(fl1-fl0) mx=amax1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) mn=amin1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,jj,kk)=w-(f1-f0) 711 continue else do 721 kk=1,n3 do 721 jj=1,mp do 721 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr2(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) f1=tr2(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) 721 xf(ii,jj,kk)=y(ii,jj,kk,0)-(f1-f0) endif endif if(ior.eq.2) then if(nonos.eq.1) then do 712 kk=1,n3 do 712 jj=1,mp do 712 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr4(y(ii,jj,kk,il2),y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1), . u) f1=tr4(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),y(ii,jj,kk,ir2), . u) fl0=donor(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) fl1=donor(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) w=y(ii,jj,kk,0)-(fl1-fl0) mx=amax1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) mn=amin1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,jj,kk)=w-(f1-f0) 712 continue else do 722 kk=1,n3 do 722 jj=1,mp do 722 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr4(y(ii,jj,kk,il2),y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1), . u) f1=tr4(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),y(ii,jj,kk,ir2), . u) 722 xf(ii,jj,kk)=y(ii,jj,kk,0)-(f1-f0) endif endif if(ior.eq.3) then if(nonos.eq.1) then do 713 kk=1,n3 do 713 jj=1,mp do 713 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr6(y(ii,jj,kk,il3),y(ii,jj,kk,il2),y(ii,jj,kk, -1), . y(ii,jj,kk, 0),y(ii,jj,kk, 1),y(ii,jj,kk,ir2),u) f1=tr6(y(ii,jj,kk,il2),y(ii,jj,kk, -1),y(ii,jj,kk, 0), . y(ii,jj,kk, 1),y(ii,jj,kk,ir2),y(ii,jj,kk,ir3),u) fl0=donor(y(ii,jj,kk,-1),y(ii,jj,kk,0),u) fl1=donor(y(ii,jj,kk, 0),y(ii,jj,kk,1),u) w=y(ii,jj,kk,0)-(fl1-fl0) mx=amax1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) mn=amin1(y(ii,jj,kk,-1),y(ii,jj,kk,0),y(ii,jj,kk,1),w) f0=f0-fl0 f1=f1-fl1 ov=(mx-w)/(-pn(f1)+pp(f0)+ep) un=(w-mn)/( pp(f1)-pn(f0)+ep) ov=amin1(1.,ov) un=amin1(1.,un) f0=pp(f0)*ov+pn(f0)*un f1=pp(f1)*un+pn(f1)*ov xf(ii,jj,kk)=w-(f1-f0) 713 continue else do 723 kk=1,n3 do 723 jj=1,mp do 723 ii=1,np u=kg0(ii,jj,kk)-xd3(ii,jj,kk) f0=tr6(y(ii,jj,kk,il3),y(ii,jj,kk,il2),y(ii,jj,kk, -1), . y(ii,jj,kk, 0),y(ii,jj,kk, 1),y(ii,jj,kk,ir2),u) f1=tr6(y(ii,jj,kk,il2),y(ii,jj,kk, -1),y(ii,jj,kk, 0), . y(ii,jj,kk, 1),y(ii,jj,kk,ir2),y(ii,jj,kk,ir3),u) 723 xf(ii,jj,kk)=y(ii,jj,kk,0)-(f1-f0) endif endif c 500 continue #if (POLES == 0) cc goto 999 cccccccccccccccccccccccc cyclic boundary forcing cccccccccccccccccccccccc if (ibcx.eq.1) then call updatelr(xf,np,mp,n3,np,mp,1) if (rightedge.eq.1) then do k=1,l do j=1,mp xf(np,j,k)=xf(np+1,j,k) end do end do end if end if if (ibcy.eq.1) then call updatebt(xf,np,mp,n3,np,mp,1) if (topedge.eq.1) then do k=1,l do i=1,np xf(i,mp,k)=xf(i,mp+1,k) end do end do end if end if if (ibcz.eq.1) then do j=1,mp do i=1,np xf(i,j,l)=xf(i,j,1) end do end do end if ccccccccccccccccccccccccccccc cyclic boundary forcing done ccccccccccccccccccccccccccccc 999 continue #endif call update(xf,np,mp,n3,np,mp,1) return end #endif subroutine traject(u,v,w,n1,m1,l1,gc1,gc2,gc3,itrt) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l,0:2), . v(1-ih:np+ih,1-ih:mp+ih,l,0:2), . w(1-ih:np+ih,1-ih:mp+ih,l,0:2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/slt/ x0(1-ih:np+ih,1-ih:mp+ih,l), 1 y0(1-ih:np+ih,1-ih:mp+ih,l), 1 z0(1-ih:np+ih,1-ih:mp+ih,l), 1 upr(1-ih:np+ih,1-ih:mp+ih,l), 1 vpr(1-ih:np+ih,1-ih:mp+ih,l), 1 wpr(1-ih:np+ih,1-ih:mp+ih,l), 1 fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) C return #if (TIMEPLT == 1) call ttbeg(37) #endif compute euler backward predictor xo=x-v(x,t1)*dt do 12 k=1,l do 12 j=1,mp do 12 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp x0(i,j,k)= ia-gc1*u(i,j,k,1) y0(i,j,k)= ja-gc2*v(i,j,k,1) 12 z0(i,j,k)= k-gc3*w(i,j,k,1) call trajbc(x0,y0,z0) if(itraj.eq.0) then corrector xo=x-.5dt*(v(xo,to)+v(x1,t1)) for itraj=0 do 11 iter=1,itrt do 13 k=1,l do 13 j=1,mp do 13 i=1,np upr(i,j,k)=u(i,j,k,0) vpr(i,j,k)=v(i,j,k,0) 13 wpr(i,j,k)=w(i,j,k,0) call interp(upr,x0,y0,z0,1) if(j3.eq.1) call interp(vpr,x0,y0,z0,0) call interp(wpr,x0,y0,z0,0) do 14 k=1,l do 14 j=1,mp do 14 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp x0(i,j,k)= ia-.5*gc1*(upr(i,j,k)+u(i,j,k,1)) y0(i,j,k)= ja-.5*gc2*(vpr(i,j,k)+v(i,j,k,1)) 14 z0(i,j,k)= k-.5*gc3*(wpr(i,j,k)+w(i,j,k,1)) call trajbc(x0,y0,z0) 11 continue else corrector xo=x-v(xo,to)*dt-dv/dt(xo,to)*.5*dt**2 for itraj=1 do 22 iter=1,itrt do 23 k=1,l do 23 j=1,mp do 23 i=1,np upr(i,j,k)=u(i,j,k,1) vpr(i,j,k)=v(i,j,k,1) 23 wpr(i,j,k)=w(i,j,k,1) call interp(upr,x0,y0,z0,1) if(j3.eq.1) call interp(vpr,x0,y0,z0,0) call interp(wpr,x0,y0,z0,0) do 24 k=1,l do 24 j=1,mp do 24 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp x0(i,j,k)= ia-gc1*upr(i,j,k) y0(i,j,k)= ja-gc2*vpr(i,j,k) 24 z0(i,j,k)= k-gc3*wpr(i,j,k) call trajbc(x0,y0,z0) 22 continue endif #if (TIMEPLT == 1) call ttend(37) #endif return end subroutine trajbc(x0,y0,z0) include 'param.nml' include 'msg.inc' dimension x0(1-ih:np+ih,1-ih:mp+ih,l), . y0(1-ih:np+ih,1-ih:mp+ih,l), . z0(1-ih:np+ih,1-ih:mp+ih,l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (TIMEPLT == 1) call ttbeg(38) #endif #if (POLES == 0) chose maximum displacement at the lateral (dl) and vertical (dv) boundaries clear case is box where dl=dv=0 dl=0.4999 dv=ibcz*dl if(ibcx.eq.0) then do k=1,l do j=1,mp do i=1,np x0(i,j,k)=amax1(1.-dl,amin1( float(n)+dl, x0(i,j,k) )) enddo enddo enddo else do k=1,l do j=1,mp do i=1,np if(x0(i,j,k).lt.float(1)-dl) x0(i,j,k)=x0(i,j,k)+float(n-1) if(x0(i,j,k).gt.float(n)+dl) x0(i,j,k)=x0(i,j,k)-float(n-1) enddo enddo enddo endif if(ibcy.eq.0) then do k=1,l do j=1,mp do i=1,np y0(i,j,k)=amax1(1.-dl,amin1( float(m)+dl, y0(i,j,k) )) enddo enddo enddo else do k=1,l do j=1,mp do i=1,np if(y0(i,j,k).lt.float(1)-dl) y0(i,j,k)=y0(i,j,k)+float(m-j3) if(y0(i,j,k).gt.float(m)+dl) y0(i,j,k)=y0(i,j,k)-float(m-j3) enddo enddo enddo endif if(ibcz.eq.0) then do k=1,l do j=1,mp do i=1,np z0(i,j,k)=amax1(1.-dv,amin1( float(l)+dv, z0(i,j,k) )) enddo enddo enddo else do k=1,l do j=1,mp do i=1,np if(z0(i,j,k).lt.float(1)-dv) z0(i,j,k)=z0(i,j,k)+float(l-1) if(z0(i,j,k).gt.float(l)+dv) z0(i,j,k)=z0(i,j,k)-float(l-1) enddo enddo enddo endif #else cori xmap(xin, xlen) = amod(xin+xlen*20.-1., xlen)+1. c xmap(xx,t) = amod(xx+t*40.-1.,t)+1. nml=n*m*l ym=float(m)+.5 y1=0.5 ym2=2.*ym y12=2.*y1 xpr=float(n) xprh=float(n)*.5 dl=0.4999 do k=1,l do j=1,mp do i=1,np z0(i,j,k)=amax1(1.,amin1( float(l), z0(i,j,k) )) if(y0(i,j,k).gt.ym) then C---> Y = YM-(Y-YM) = 2*YM-Y y0(i,j,k)=ym2-y0(i,j,k) x0(i,j,k)=x0(i,j,k)+xprh endif if(y0(i,j,k).lt.y1) then C---> Y = Y1-(Y-Y1) = 2*Y1-Y y0(i,j,k)=y12-y0(i,j,k) x0(i,j,k)=x0(i,j,k)+xprh endif if(x0(i,j,k).lt.float(1)-dl) x0(i,j,k)=x0(i,j,k)+float(n) if(x0(i,j,k).gt.float(n)+dl) x0(i,j,k)=x0(i,j,k)-float(n) c x0(i,j,k)=xmap(x0(i,j,k),xpr) enddo enddo #endif #if (TIMEPLT == 1) call ttend(38) #endif return end #if (PARALLEL>0) subroutine lagrmsg(ia,ja,i,j) include 'param.nml' include 'param.ior' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc c print *,'lagrmsg',mype #if (POLES == 0) if (leftedge.eq.0 .and. rightedge.eq.0) then i=ia-(npos-1)*np if (i.lt.(1-ihlag) .or. i.gt.(np+ihlag)) then write(*,*)'***ia,i,npos,np,ihlag=',ia,i,npos,np,ihlag stop 211 end if else if (leftedge.eq.1 .and. rightedge.eq.0) then if (ia.le.np+ihlag) then i=ia if (i.lt.(1-ihlag) .or. i.gt.(np+ihlag)) stop 211 else if (ia.gt.(n-ihlag) .and. ia.le.n) then i=-ior-n+ia else if (ia.gt.n .and. ia.le.(n+ior)) then if (ibcx.eq.0) then i=-ior else i=(ia-n)+1 end if else write(*,*)'***about to stop' stop 211 end if else if (rightedge.eq.1 .and. leftedge.eq.0) then if (ia.ge.(1+(npos-1)*np)-ihlag) then i=ia-(npos-1)*np else if (ia.ge.1 .and. ia.lt.(1+ihlag)) then i=np+ior+ia else if (ia.lt.1 .and. ia.ge.(1-ior)) then if (ibcx.eq.0) then i=np+ior+1 else i=np+ia-1 end if else stop 211 end if else if (rightedge.eq.1 .and. leftedge.eq.1) then i=ia end if if (topedge.eq.0 .and. botedge.eq.0) then j=ja-(mpos-1)*mp if (j.lt.(1-ihlag) .or. j.gt.(mp+ihlag)) stop 211 else if (botedge.eq.1 .and. topedge.eq.0) then if (ja.le.mp+ihlag) then j=ja if (j.lt.(1-ihlag) .or. j.gt.(mp+ihlag)) stop 211 else if (ja.gt.(m-ihlag) .and. ja.le.m) then j=-ior-m+ia else if (ja.gt.m .and. ja.le.(m+ior)) then if (ibcy.eq.0) then j=-ior else j=(ja-m)+1 end if else stop 211 end if else if (topedge.eq.1 .and. botedge.eq.0) then if (ja.ge.(1+(mpos-1)*mp)-ihlag) then j=ja-(mpos-1)*mp else if (ja.ge.1 .and. ja.lt.(1+ihlag)) then j=mp+ior+ja else if (ja.lt.1 .and. ja.gt.(1-ior)) then if (ibcy.eq.0) then j=mp+ior+1 else j=mp+ia-1 end if else stop 211 end if else if (topedge.eq.1 .and. botedge.eq.1) then j=ja end if #else if (leftedge.eq.0 .and. rightedge.eq.0) then i=ia-(npos-1)*np if (i.lt.(1-ihlag) .or. i.gt.(np+ihlag)) then write(*,*)'***ia,i,npos,np,ihlag=',ia,i,npos,np,ihlag stop 211 end if else if (leftedge.eq.1 .and. rightedge.eq.0) then if (ia.le.np+ihlag) then i=ia if (i.lt.(1-ihlag) .or. i.gt.(np+ihlag)) stop 211 else if (ia.gt.(n-ihlag) .and. ia.le.n) then i=-ior-n+ia else if (ia.gt.n .and. ia.le.(n+ior)) then i=(ia-n)+1 else write(*,*)'***about to stop' stop 211 end if else if (rightedge.eq.1 .and. leftedge.eq.0) then if (ia.ge.(1+(npos-1)*np)-ihlag) then i=ia-(npos-1)*np else if (ia.ge.1 .and. ia.lt.(1+ihlag)) then i=np+ior+ia else if (ia.lt.1 .and. ia.ge.(1-ior)) then i=np+ia-1 else stop 211 end if else if (rightedge.eq.1 .and. leftedge.eq.1) then i=ia end if if (topedge.eq.0 .and. botedge.eq.0) then j=ja-(mpos-1)*mp if (j.lt.(1-ihlag) .or. j.gt.(mp+ihlag)) stop 211 else if (botedge.eq.1 .and. topedge.eq.0) then if (ja.le.mp+ihlag) then j=ja if (j.lt.(1-ihlag) .or. j.gt.(mp+ihlag)) stop 211 else if (ja.gt.(m-ihlag) .and. ja.le.m) then j=-ior-m+ia else if (ja.gt.m .and. ja.le.(m+ior)) then j=(ja-m)+1 else stop 211 end if else if (topedge.eq.1 .and. botedge.eq.0) then if (ja.ge.(1+(mpos-1)*mp)-ihlag) then j=ja-(mpos-1)*mp else if (ja.ge.1 .and. ja.lt.(1+ihlag)) then j=mp+ior+ja else if (ja.lt.1 .and. ja.gt.(1-ior)) then j=mp+ia-1 else stop 211 end if else if (topedge.eq.1 .and. botedge.eq.1) then j=ja end if #endif c print *,'lagrmsg done',mype return end #endif /* J3DIM */ #endif /* SEMILAG == 1 */ #endif /* ANALIZE == 0 */ subroutine cndinst include 'param.nml' include 'msg.inc' common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) #if (TIMEPLT == 1) call ttbeg(52) #endif c=hlat/cp x0=-1.e15 do 1 k=1,l thetme=the(1,1,k)/tme(1,1,k) x=the(1,1,k)+c*thetme*qve(1,1,k) index=1 if(x.le.x0) index=-1 x0=x if (mype.eq.0) then if(index.eq.-1) print 100, x,k,index 100 format(2x,'thetae, k, index:', e11.4, 2i4) end if 1 continue #if (TIMEPLT == 1) call ttend(52) #endif return end #if (MOISTMOD > 0) subroutine cond(th,qv,qc,qr,fth,fqv,fqc,fqr,tau) include 'param.nml' include 'msg.inc' dimension th(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fth(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) dimension tau(l,1-ih:np+ih,1-ih:mp+ih) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/temp_p/ tup,tdn common/latent/hlatv,hlats common/znave/ uza(mp,l),vza(mp,l),wza(mp,l),thza(mp,l), . qvza(mmsp,lms),bxza(mmhdp,lmhd),byza(mmhdp,lmhd), . byza(mmhdp,lmhd) 1 dxabL,dxabR,dyab,iab,iabth,iabqw alim01(fi)=amax1(0.,amin1(1.,fi)) comb(tm,td,tu,ad,au)= 1 alim01((tm-td)/(tu-td))*au + alim01((tu-tm)/(tu-td))*ad #if (TIMEPLT == 1) call ttbeg(53) #endif condensation/evaporation IF(ICE.EQ.1) THEN a=rg/rv b=hlats/rv d=hlatv/rv c=hlatv/cp e=-cp/rg do k=1,l do j=1,mp do i=1,np thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**e tt=th(i,j,k)/thetme c coe_l=comb(tme(i,j,k),tdn,tup,0.,1.) ! liquid contribution coe_l=comb( tt ,tdn,tup,0.,1.) ! liquid contribution delt=(tt-t00)/(tt*t00) esw=ee0*exp(d * delt) esi=ee0*exp(b * delt) qvsw=a * esw /(pre-esw) qvsi=a * esi /(pre-esi) qvs=coe_l*qvsw + (1.-coe_l)*qvsi ccc linearized condensation rate is next: cf1=thetme/th(i,j,k) cf1=cf1*cf1 cf1=c*cf1*pre/(pre-esw)*d delta=(qv(i,j,k)-qvs)/(1.+qvs*cf1) ccc one Newton-Raphson iteration is next: thn=th(i,j,k)+c*thetme*delta tt=thn/thetme delt=(tt-t00)/(tt*t00) esw=ee0*exp(d * delt) esi=ee0*exp(b * delt) qvsw=a * esw /(pre-esw) qvsi=a * esi /(pre-esi) qvs=coe_l*qvsw + (1.-coe_l)*qvsi fff=qv(i,j,k)-delta-qvs cf1=1./tt cf1=cf1*cf1 cf1=c*cf1*pre/(pre-esw)*d fffp=-1.-qvs*cf1 delta=delta-fff/fffp ccc end of the iteration; if required, it can be repeated by copying ccc the piece of code above (no inner loop for vectorization reason) c---> delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) qv(i,j,k)=qv(i,j,k)-delta qc(i,j,k)=qc(i,j,k)+delta th(i,j,k)=th(i,j,k)+c*thetme*delta delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) fqv(i,j,k)=-delta*2.*dti fqc(i,j,k)=-fqv(i,j,k) fth(i,j,k)=c*thetme*fqc(i,j,k) enddo enddo enddo ELSE a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg do k=1,l do j=1,mp do i=1,np thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**e thi=1./th(i,j,k) y=b*thetme*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) ccc linearized condensation rate: cf1=thetme*thetme*thi*thi cf1=c*cf1*pre/(pre-ees)*d delta=(qv(i,j,k)-qvs)/(1.+qvs*cf1) ccc one Newton-Raphson iteration is next: thi=1./(th(i,j,k)+c*thetme*delta) y=b*thetme*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) fff=qv(i,j,k)-delta-qvs cf1=thetme*thetme*thi*thi cf1=c*cf1*pre/(pre-ees)*d fffp=-1.-qvs*cf1 delta=delta-fff/fffp ccc end of the iteration; if required, it can be repeated by copying ccc the piece of code above (no inner loop for vectorization reason) c---> delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) qv(i,j,k)=qv(i,j,k)-delta qc(i,j,k)=qc(i,j,k)+delta th(i,j,k)=th(i,j,k)+c*thetme*delta delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) fqv(i,j,k)=-delta*2.*dti fqc(i,j,k)=-fqv(i,j,k) fth(i,j,k)=c*thetme*fqc(i,j,k) enddo enddo enddo ENDIF compute gravity wave absorber (implicit) dth=0.5*dt do 20 k=1,l do 20 j=1,mp do 20 i=1,np c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) tth=tau(k,i,j)*(1.-relt)+relt tqv=tth*iabqw th(i,j,k)=(th(i,j,k)+tth*the(i,j,k)*dth)/(1.+tth*dth) qv(i,j,k)=(qv(i,j,k)+tqv*qve(i,j,k)*dth)/(1.+tqv*dth) qc(i,j,k)=(qc(i,j,k)+ 0. )/(1.+tqv*dth) qr(i,j,k)=(qr(i,j,k)+ 0. )/(1.+tqv*dth) fqv(i,j,k)=fqv(i,j,k)-tqv*( qv(i,j,k)-qve(i,j,k)) c---------> special, absorbing to zonal averages c th(i,j,k)=th(i,j,k)-tth*(the(i,j,k)-thza(j,k))*dth/(1.+tth*dth) c qv(i,j,k)=qv(i,j,k)-tqv*(qve(i,j,k)-qvza(j,k))*dth/(1.+tqv*dth) c fqv(i,j,k)=fqv(i,j,k)-tqv*(qve(i,j,k)-qvza(j,k)) c---------> end of special fqc(i,j,k)=fqc(i,j,k)-tqv*(qc(i,j,k)-0.) fqr(i,j,k)= -tqv*(qr(i,j,k)-0.) 20 continue #if (TIMEPLT == 1) call ttend(53) #endif return end subroutine adj_prec(thf,qv,qc,qr,ftf,fqv,fqc,fqr, . ftfa,fqva,fqca,fqra,n1,m1,l1) include 'param.nml' include 'msg.inc' dimension thf(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . ftf(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . ftfa(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqva(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqca(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqra(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/latent/hlatv,hlats #if (TIMEPLT == 1) call ttbeg(54) #endif dth=.5*dt do k=1,l do j=1,mp do i=1,np cc field + .5 condensation at the departure point: thf(i,j,k)=thf(i,j,k) + ftf(i,j,k)*dth qv(i,j,k) = qv(i,j,k) + fqv(i,j,k)*dth qc(i,j,k) = qc(i,j,k) + fqc(i,j,k)*dth qr(i,j,k) = qr(i,j,k) + fqr(i,j,k)*dth cc ccc final adjustment and application of forces due to rain: fqc2 = amax1(fqca(i,j,k), -qc(i,j,k)*dti ) fqr2 = amax1(fqra(i,j,k), -qr(i,j,k)*dti ) delql=fqc2-fqca(i,j,k)+fqr2-fqra(i,j,k) cc adjust force for qv to conserve water: fqv2=fqva(i,j,k)-delql cc adjust force for th to conserve energy: ftf2=ftfa(i,j,k) + the(i,j,k)/tme(i,j,k)*hlatv/cp*delql thf(i,j,k)=thf(i,j,k) + ftf2*dt qv(i,j,k)= amax1(0., qv(i,j,k) + fqv2*dt) qc(i,j,k)= amax1(0., qc(i,j,k) + fqc2*dt) qr(i,j,k)= amax1(0., qr(i,j,k) + fqr2*dt) ftfa(i,j,k) = ftf2 enddo enddo enddo #if (TIMEPLT == 1) call ttend(54) #endif return end subroutine micro_init common/rain_p1/ dconc,ddisp if(dconc.gt.2000. .or. dconc.lt.50.) stop 'MICRO' cc relative dispersion for Berry's autoconversion: ddisp=0.146-5.964e-2*alog(dconc/2000.) return end subroutine precip(th,qv,qc,qr,fth,fqv,fqc,fqr, 1 n1,m1,l1,ndtm,dtm,itst) include 'param.nml' include 'msg.inc' dimension th(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fth(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/rain/ rac,qctr,rc common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common /water_bgdt/ totw0,totw(nth),prec(nth),sflux(nth), 1 prec_dis(np,mp) common/rain_p0/ ar,br,cr,dr,er,alphr,betr,gamb1r,gambd1r,anor common/rain_p1/ dconc,ddisp common/snow_p0/ as,bs,cs,ds,es,alphs,bets,gamb1s,gambd1s,anos common/temp_p/ tup,tdn common/latent/hlatv,hlats real lambdr,lambds,massr,masss real globsum common/blank/ rhl(1-ih:np+ih, 1-ih:mp+ih, l), . thetme(1-ih:np+ih, 1-ih:mp+ih, l), . scr14(1-ih:np+ih, 1-ih:mp+ih, l, 14) dimension ss(l),gac(l),den(l),th1(l),qv1(l),qc1(l),qr1(l), 1 fth1(l),fqv1(l),fqc1(l),fqr1(l),qr2(l),tt1(l),vterm(l+1) alim01(fi)=amax1(0.,amin1(1.,fi)) comb(tm,td,tu,ad,au)= 1 alim01((tm-td)/(tu-td))*au + alim01((tu-tm)/(tu-td))*ad #if (TIMEPLT == 1) call ttbeg(55) #endif dtmi=1./dtm iulim=rightedge*(np-1)+(1-rightedge)*np pi=3.14159 IF(ICE.EQ.1) THEN a=rg/rv b=hlats/rv c=hlatv/cp d=hlatv/rv e=-cp/rg ELSE a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg ENDIF do 10 k=1,l do 10 j=1,mp do 10 i=1,np dnm=stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j) rhl(i,j,k)=rho(i,j,k)*(gi(i,j)*gmus(k)) + /((1-icylind)*gmm(i,j,k)**2*cosa(i,j) + +icylind*gmm(i,j,k))*dnm thetme(i,j,k)=the(i,j,k)/tme(i,j,k) 10 continue tot_prec=0. do 77 j=1,mp do 77 i=1,np prec_ij=0. cc check if there is/will be a trace of condensate in a column: qmx=0. do k=1,l qtot=qc(i,j,k)+qr(i,j,k) qmx=amax1(qmx,qtot) qmx=amax1(qmx,qtot+dt*(fqc(i,j,k)+fqr(i,j,k))) enddo if(qmx.lt.1.e-8) then cc NO ADJUSTEMENT REQUIRED, just convert the trace into vapor: do k=1,l fqc(i,j,k)=-qc(i,j,k)*dti fqr(i,j,k)=-qr(i,j,k)*dti fqv(i,j,k)=(qc(i,j,k)+qr(i,j,k))*dti fth(i,j,k)=-c*thetme(i,j,k)*(qc(i,j,k)+qr(i,j,k))*dti enddo else cc ADJUSTEMENT REQUIRED cc initial conditions: do k=1,l gac(k)=rho(i,j,k) den(k)=rhl(i,j,k) th1(k)=th(i,j,k) qv1(k)=qv(i,j,k) qc1(k)=qc(i,j,k) qr1(k)=qr(i,j,k) fth1(k)=0. fqv1(k)=0. fqc1(k)=0. fqr1(k)=0. enddo cc forward in time with a small time step: do iter=1,ndtm cc sources of precipitation: IF(ICE.EQ.1) THEN do k=1,l tti=th1(k)/thetme(i,j,k) pre=1.e5*thetme(i,j,k)**e c coe_l=comb(tme(i,j,k),tdn,tup,0.,1.) ! liquid contribution coe_l=comb( tti ,tdn,tup,0.,1.) ! liquid contribution delt=(tti-t00)/(tti*t00) esw=ee0*exp(d * delt) esi=ee0*exp(b * delt) qvsw=a * esw /(pre-esw) qvsi=a * esi /(pre-esi) ssw=qv1(k) / qvsw ! saturation ratio ssi=qv1(k) / qvsi ! saturation ratio qpr=qr1(k)*coe_l ! divide between rain and snow qps=qr1(k)-qpr ! divide between rain and snow qcc=qc1(k)*coe_l ! divide between ice and water qci=qc1(k)-qcc ! divide between ice and water lambdr=(ar*anor*gamb1r/rhl(i,j,k) / 1 amax1(qpr,1.e-6))**(1./(1.+br)) ! lambda lambds=(as*anos*gamb1s/rhl(i,j,k) / 1 amax1(qps,1.e-6))**(1./(1.+bs)) ! lambda CC AUTOCONVERSION: cc rain - Berry: del2=1.e3*rhl(i,j,k)*qcc autc=1./rhl(i,j,k)*1.67e-5*del2*del2 / 1 (5. + .0366*dconc/(ddisp*(del2+1.E-6))) cc snow: tc=tti-273.16 times=amin1(1.e3,(3.56*tc+106.7)*tc+1.e3) ! time scale for auti=qci/times AUT = autc + auti CC GROWTH: conr=anor/lambdr ! concentration cons=anos/lambds ! concentration massr=rhl(i,j,k)*amax1(qpr,1.e-7) / conr ! mass masss=rhl(i,j,k)*amax1(qps,1.e-7) / cons ! mass diamr=(massr/ar)**(1./br) ! diameter diams=(masss/as)**(1./bs) ! diameter rer=cr*diamr**(dr+1.)/2.e-5 ! Reynolds number res=cs*diams**(ds+1.)/2.e-5 ! Reynolds number ventr=amax1(1.,.78+.27*sqrt(rer)) ! ventilation factor vents=amax1(1.,.65+.39*sqrt(res)) ! ventilation factor thfun=1.e-7/(2.2*tme(i,j,k)/esw+2.2e2/tme(i,j,k)) ! thermodynamic fun. g_acc_r=pi/4.*cr*diamr**(2.+dr)*er*alphr*rhl(i,j,k)*qc(i,j,k) ! growth g_acc_s=pi/4.*cs*diams**(2.+ds)*es*alphs*rhl(i,j,k)*qc(i,j,k) ! growth g_dep_r=4.*pi*diamr/betr*(ssw-1.)*ventr*thfun ! growth/evap g_dep_s=4.*pi*diams/bets*(ssi-1.)*vents*thfun ! growth/evap acc_r=conr * g_acc_r * qpr / (qpr + 1.e-9) acc_s=cons * g_acc_s * qps / (qps + 1.e-9) ACC= acc_r + acc_s ! growth by accretion dep_r=conr * g_dep_r * qpr / (qpr + 1.e-9) dep_s=cons * g_dep_s * qps / (qps + 1.e-9) DEP= dep_r + dep_s ! growth by deposition ccc with precip... dcol=amin1(AUT + ACC, dtmi*qc1(k)+fqc(i,j,k)) devp=amax1(DEP, -dtmi*qr1(k)-fqr(i,j,k)-dcol) ccc without precip... c dcol=0. c devp=0. c qv1(k)=qv1(k) + dtm*fqv(i,j,k) - dtm*devp qc1(k)=qc1(k) + dtm*fqc(i,j,k) - dtm*dcol qr1(k)=qr1(k) + dtm*fqr(i,j,k) + dtm*(devp+dcol) th1(k)=th1(k) + dtm*fth(i,j,k) + dtm*c*devp*thetme(i,j,k) fqv1(k)=fqv1(k)-devp fqc1(k)=fqc1(k)-dcol fqr1(k)=fqr1(k)+devp+dcol fth1(k)=fth1(k)+c*devp*thetme(i,j,k) c tt1(k)=tme(i,j,k) tt1(k)=tti qr2(k)=qr1(k) enddo ELSE do k=1,l pre=1.e5*thetme(i,j,k)**e thi=1./th1(k) y=b*thetme(i,j,k)*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) ss(k)=amin1(qv1(k)/qvs-1., 0.) dcol= rac*amax1(qc1(k)-qctr, 0.) . + rc*qc1(k)*amax1(0.,qr1(k))**.875 dcol=amin1(dcol, dtmi*qc1(k)+fqc(i,j,k)) presmb=rhl(i,j,k)*rg*tme(i,j,k)/100. rhqr=rhl(i,j,k)*1.e-3*amax1(0.,qr1(k)) rhqr=amax1(rhqr,1.e-20) qvs=qv1(k)/(1.+ss(k)) bottom=1.e-3*rhl(i,j,k)*(5.4e5 + 2.55e6/(presmb*qvs)) ventc=1.6+124.9*rhqr**.2046 devp=ss(k)*ventc*rhqr**.525 / bottom devp=amax1(devp, -dtmi*qr1(k)-fqr(i,j,k)-dcol) c qv1(k)=qv1(k) + dtm*fqv(i,j,k) - dtm*devp qc1(k)=qc1(k) + dtm*fqc(i,j,k) - dtm*dcol qr1(k)=qr1(k) + dtm*fqr(i,j,k) + dtm*(devp+dcol) th1(k)=th1(k) + dtm*fth(i,j,k) + dtm*c*devp*thetme(i,j,k) fqv1(k)=fqv1(k)-devp fqc1(k)=fqc1(k)-dcol fqr1(k)=fqr1(k)+devp+dcol fth1(k)=fth1(k)+c*devp*thetme(i,j,k) c tt1(k)=tme(i,j,k) tt1(k)=th1(k)/thetme(i,j,k) qr2(k)=qr1(k) enddo ENDIF cc sedimentation: call rain_fall_clmn(qr2,tt1,den,vterm,l) call advec1d(l,dtm,dz,qr2,vterm,gac) if(i.lt.iulim) then cc precipitation deduced from change of rain water: prec_ij=prec_ij + .5*(qr1(1)-qr2(1))*rho(i,j,1) + 1 .5*(qr1(l)-qr2(l))*rho(i,j,l) do k=2,l-1 prec_ij=prec_ij+(qr1(k)-qr2(k))*rho(i,j,k) enddo endif do k=1,l fqr1(k)=fqr1(k)+(qr2(k)-qr1(k))*dtmi qr1(k)=qr2(k) enddo enddo cc prec_ij is the total qr change in a column prec_ij=prec_ij*dx*dy*dz cc prec_dis is converted in precipitation rate in kg/m**2/s prec_dis(i,j)=prec_dis(i,j) + prec_ij*dti/(dx*dy) cc get final force due to precip processes: do k=1,l fqv(i,j,k)=fqv1(k)/float(ndtm) fqc(i,j,k)=fqc1(k)/float(ndtm) fqr(i,j,k)=fqr1(k)/float(ndtm) fth(i,j,k)=fth1(k)/float(ndtm) enddo endif if(i.lt.iulim) tot_prec=tot_prec+prec_ij*dti 77 continue #if (PARALLEL > 0) temp=tot_prec tot_prec=globsum(temp,1,1,1,1,1,1,1,1,1,1,1,1) #endif prec(itst)=tot_prec c if (mype.eq.0) print*,' === it,precip: ',itst,prec(itst)/dti #if (TIMEPLT == 1) call ttend(55) #endif return end subroutine rain_fall_clmn(qr,temp,rho,uza,nz) include 'param.nml' include 'msg.inc' dimension qr(nz),temp(nz),uza(nz+1),rho(nz) common/rain_p0/ ar,br,cr,dr,er,alphr,betr,gamb1r,gambd1r,anor common/snow_p0/ as,bs,cs,ds,es,alphs,bets,gamb1s,gambd1s,anos common/temp_p/ tup,tdn real lambdr,lambds alim01(fi)=amax1(0.,amin1(1.,fi)) comb(tm,td,tu,ad,au)= 1 alim01((tm-td)/(tu-td))*au + alim01((tu-tm)/(tu-td))*ad vtrmv(qq,rro)=36.34*sqrt(1./rro)*(rro*1.e-3*qq)**.1346 #if (TIMEPLT == 1) call ttbeg(56) #endif IF(ICE.EQ.1) THEN do k=2,nz dens= 0.5*(rho(k)+rho(k-1)) qrv = 0.5*( qr(k)+ qr(k-1)+1.e-10) coe_l=comb(temp(k),tdn,tup,0.,1.) ! liquid part qpr=qrv*coe_l ! divide between rain and snow qps=qrv-qpr ! divide between rain and snow lambdr=(ar*anor*gamb1r/dens/(qpr+1.e-6))**(1./(1.+br)) ! lambda lambds=(as*anos*gamb1s/dens/(qps+1.e-6))**(1./(1.+bs)) ! lambda vtr=cr*gambd1r/gamb1r / lambdr**dr ! terminal velocity vts=cs*gambd1s/gamb1s / lambds**ds ! terminal velocity vtf=coe_l*vtr+(1.-coe_l)*vts ! TERMINAL VELOCITY uza(k)=-vtf*dens end do uza(1)=uza(2) uza(nz+1)=0. ELSE do k=2,nz dens= 0.5*(rho(k)+rho(k-1)) qrv = 0.5*( qr(k)+ qr(k-1)+1.e-10) vtr=vtrmv(qrv,dens) uza(k)=-vtr*dens end do uza(1)=uza(2) uza(nz+1)=0. ENDIF #if (TIMEPLT == 1) call ttend(56) #endif return end subroutine advec1d(nn,dt,dz,xs,om,rh) cc 1D advection modified for rain sedimentation in model column dimension xs(nn),om(nn+1),rh(nn) include 'param.nml' include 'msg.inc' parameter(n1=l+1) dimension fh(n1),vdz(n1),xmx(n1),xmn(n1),fpl(n1),fng(n1) donor(y1,y2,w,d)=0.5*dt/d*((w-abs(w))*y2+(w+abs(w))*y1) vdyf(x1,x2,w,d)=(-w**2*dt+abs(w)*d)/d*(x2-x1)/(x2+x1+eps) pp(x)=amax1(0.,x) pn(x)=amin1(0.,x) C #if (TIMEPLT == 1) call ttbeg(57) #endif impli=1 iord=1 nonos=0 eps=1.E-15 IF(IMPLI.EQ.1) THEN do iz=1,nn+1 vdz(iz)=om(iz)*dt/dz enddo xs(nn)=xs(nn)/(1.-vdz(nn)/rh(nn)) do iz=nn-1,1,-1 xs(iz)=(xs(iz)-vdz(iz+1)*xs(iz+1)/rh(iz))/(1.-vdz(iz)/rh(iz)) enddo ELSE do 1 iz=1,nn+1 vdz(iz)=om(iz) 1 continue if(nonos.eq.1) then do 400 iz=2,nn-1 xmx(iz)=amax1(xs(iz-1),xs(iz),xs(iz+1)) 400 xmn(iz)=amin1(xs(iz-1),xs(iz),xs(iz+1)) endif do 3 k=1,iord do 331 iz=2,nn fh(iz)=donor(xs(iz-1),xs(iz),vdz(iz),dz) 331 continue fh(1)=donor(0.,xs(1),vdz(1),dz) fh(nn+1)=0. do 333 iz=1,nn xs(iz)=xs(iz)-(fh(iz+1)-fh(iz))/rh(iz) 333 continue if(k.eq.iord) go to 6 do 51 iz=2,nn vdz(iz)=vdyf(xs(iz-1),xs(iz),vdz(iz),dz) 51 continue vdz(1)=0. vdz(nn+1)=0. if(nonos.eq.0) go to 3 do 401 iz=2,nn-1 xmx(iz)=amax1(xmx(iz),xs(iz-1),xs(iz),xs(iz+1)) 401 xmn(iz)=amin1(xmn(iz),xs(iz-1),xs(iz),xs(iz+1)) do 52 iz=2,nn fh(iz)=donor(xs(iz-1),xs(iz),vdz(iz),dz) 52 continue do 53 iz=2,nn-1 fpl(iz)=(xmx(iz)-xs(iz))/(-pn(fh(iz+1))+pp(fh(iz))+eps) fng(iz)=(xs(iz)-xmn(iz))/( pp(fh(iz+1))-pn(fh(iz))+eps) fpl(iz)=amax1(0.,amin1(1.,fpl(iz))) fng(iz)=amax1(0.,amin1(1.,fng(iz))) 53 continue fpl(1)=1. fpl(nn)=1. fng(1)=1. fng(nn)=1. do 54 iz=2,nn vdz(iz)=pp(vdz(iz))*amin1(fpl(iz),fng(iz-1)) 1 +pn(vdz(iz))*amin1(fpl(iz-1),fng(iz)) 54 continue vdz(1)=0. vdz(nn+1)=0. 3 continue 6 continue ENDIF #if (TIMEPLT == 1) call ttend(57) #endif return end #endif /* MOISTMOD > 0 */ subroutine rhfld(th,qv,rhf,n1,m1,l1,ipr) include 'param.nml' include 'msg.inc' dimension rhf(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat real globmax,globmin #if (TIMEPLT == 1) call ttbeg(58) #endif rhmx=-1.e15 rhmn= 1.e15 a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg do 1 k=1,l do 1 j=1,mp do 1 i=1,np thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**e thi=1./(th(i,j,k)+the(i,j,k)) y=b*thetme*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) 1 rhf(i,j,k)=qv(i,j,k)/qvs rhmx=globmax(rhf,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) rhmn=globmin(rhf,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) if (mype.eq.0) then if(ipr.eq.1) print 301,rhmx,rhmn 301 format(1x,'rhmx, rhmn:',2e11.4) endif #if (TIMEPLT == 1) call ttend(58) #endif return end subroutine header(lipps) include 'param.nml' include 'msg.inc' include 'param.ior' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/gora/ xml,yml,amp,xml0,yml0,angle common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/davies/ relx(np,mp),rely(np,mp),zab,towxL,towxR,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxabL,dxabR,dyab,iab,iabth,iabqw common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/stresd/ diagstr(8),ivis,irid,itstr character*80 title c ---- computational parameters write (6,999) write (6,8992) if(isphere.eq.1) then write (6,9000) (-90.+(m-0.5)*180./float(m)),rds/1000. end if write (6,901) n,m,L,lagr,ior write (6,914) nprocx,nprocy write (6,902) dx,dy,dz,dt write (6,903) nt,nplot,nstore write (6,904) ibcx,ibcy,ibcz,irlx,irly,irdbc write (6,905) iab,iabth,iabqw write (6,906) zab,towz if(isphere.eq.1) then write (6,908) towxL,towxR,towy,dxabL/(rds*3.1416)*180. . ,dxabR/(rds*3.1416)*180. . ,dyab /(rds*3.1416)*180. else write (6,9080) towxL,towxR,towy,dxabL/1000. . ,dxabR/1000. . ,dyab/1000. end if c ---- basic state write (6,999) write (6,8994) eps=1.e-15 if((abs(u0z).lt.eps).and.(abs(v0z).le.eps)) then write (6,929) u00,v00 else write (6,909) u00,u0z endif bv=sqrt(st*g) write (6,910) bv,lipps if((abs(u0z).lt.eps).and.(abs(v0z).le.eps)) then ri00=0. write (6,899) write (title,899) else ri00 = g*st/(u0z**2 + v0z**2) write (6,900) ri00 endif c ---- physical parameters write (6,999) write (6,8996) write (6,912) icorio,ivis,itkes write (6,913) moist,ice c ---- transformation parameters write (6,999) write (6,8998) write (6,911) xml,yml,amp c write (6,9031) time,tt,tend 899 format(1x,'Ri0 = infinity') 8992 format(11x,'COMPUTATIONAL PARAMETERS') 8994 format(11x,'BASIC STATE') 8996 format(11x,'PHYSICAL PARAMETERS') 8998 format(11x,'TRANSFORMATION PARAMETERS') 900 format(1x,'Ri0 =',e11.4) 9000 format(1x,'SPHERE: meridional grid = +/-',f8.3,' degrees'/ . 11x,'radius = ',f8.1,' kms') 901 format(1x,'n,m,l =',3i5,5x,'lagr,ior =',2i5) 902 format(1x,'dx,dy,dz,dt =',4e11.4) 903 format(1x,'nt,nplot,nstore =',3i5) 9031 format(1x,'time,tt,tend =',3e11.4) 904 format(1x,'ibcx,ibcy,ibcz =',3i5/ . 1x,'irlx,irly,irdbc =',3i5) 905 format(1x,'iab,iabth,iabqw =',3i5) 906 format(1x,'zab,towz =',2e11.4) 908 format(1x,'towxL,towxR,towy =',3e11.4/ . 1x,'dxabL,dxabR,dyab =',3f5.2,' deg') 9080 format(1x,'towxL,towxR,towy =',3e11.4/ . 1x,'dxabL,dxabR,dyab =',3e11.4,' kms') 909 format(1x,'Const shear profile:'/ . 1x,' U00,U00Z =',2e11.4) 929 format(1x,'Const wind profile:'/ . 1x,' U00,V00 =',2e11.4) 910 format(1x,'Const stability profile:'/ . 1x,' N =',1x,e11.4,' lipps =',i3) 911 format(1x,'mountain scales:'/ . 1x,' Lx,Ly,h0 =',3e11.4) 912 format(1x,'icorio,ivis,itke =',3i5) 913 format(1x,'moist,ice =',2i5) 914 format(1x,'npr_x,npr_y =',2i5) 999 format(1x,' ****************** ') write (6,999) return end subroutine drag(p,fx,fy,n1,m1,l1) include 'param.nml' include 'msg.inc' dimension p(1-ih:np+ih,1-ih:mp+ih,l),fx(nth),fy(nth) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/dragc/ dragx(nth),dragy(nth),drgnorm, itd, idrag common/indx/ e1,e2,e3 #if (ANALIZE == 0) common/blank/ scr14(1-ih:np+ih, 1-ih:mp+ih, l, 14), . pe(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 7), . pe(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #endif real globsum #if (TIMEPLT == 1) call ttbeg(62) #endif dxil=.5*dxi dyil=.5*dyi do k=1,l do j=1,mp do i=1,np pe(i,j,k)=p(i,j,k) enddo enddo enddo fx(itd)=0. fy(itd)=0. illim=1 + leftedge iulim=np - rightedge jllim=1 + j3*botedge julim=mp - j3*topedge if (igrid.eq.0) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc calculate perturbation pressure do j=1,mp do i=1,np pe(i,j,1)=pe(i,j,1)*rho(i,j,1)*gi(i,j)*2.*dti enddo enddo do j=jllim,julim do i=illim,iulim temp(i,j,1)=(zs(i+1,j)-zs(i-1,j))*pe(i,j,1)*dxil end do end do fx(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,iulim,jllim,julim,1,1) if (j3.eq.1) then do j=jllim,julim do i=illim,iulim temp(i,j,1)=(zs(i,j+j3)-zs(i,j-j3))*pe(i,j,1)*dyil end do end do fy(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,iulim,jllim,julim,1,1) end if cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid A ---> grid A ---> grid A <--- grid A <--- grid A <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc else cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc calculate perturbation pressure construct perturbation pressure along the lower boundary for igrid=1 do j=jllim,mp do i=illim,np plex =e1*pe(i,j,2)+e2*pe(i,j,3)+e3*pe(i,j,4) rhoav=( rho(i-1,j-j3,1)*gi(i-1,j-j3) 1 + rho(i,j-j3,1)*gi(i,j-j3) 1 + rho(i-1,j,1)*gi(i-1,j) 1 + rho(i,j,1)*gi(i,j) )*0.25 pe(i,j,1)=plex*rhoav*2.*dti enddo enddo do j=jllim,mp do i=illim,np temp(i,j,1)=(pe(i,j,1)*dxil* * (zs(i,j)-zs(i-1,j)+zs(i,j-j3)-zs(i-1,j-j3))) end do end do fx(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1,1) if (j3.eq.1) then do j=jllim,mp do i=illim,np temp(i,j,1)=(pe(i,j,1)*dyil* * (zs(i,j)-zs(i,j-j3)+zs(i-1,j)-zs(i-1,j-j3))) end do end do fy(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1,1) end if cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ----> grid B ---> grid B ---> grid B <--- grid B <--- grid B <---- c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc endif fx(itd)=fx(itd)*dx*dy/drgnorm fy(itd)=fy(itd)*dx*dy/drgnorm #if (TIMEPLT == 1) call ttend(62) #endif return end subroutine sumcns(a,b,d,sum,iflg) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l), . b(1-ih:np+ih, 1-ih:mp+ih, l), . d(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (ANALIZE == 0) common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . tmp(1-ih:np+ih, 1-ih:mp+ih, l) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 8), . tmp(1-ih:np+ih, 1-ih:mp+ih, l) #endif C#if (PARALLEL > 0) #if (SUMR16 == 1) real*16 sum #else real sum #endif real globsum #if (TIMEPLT == 1) call ttbeg(63) #endif #if (POLES == 0) illim=1+ibcx*leftedge jllim=1+ibcy*botedge #else illim=1 jllim=1 #endif kllim=1+ibcz iflag=1-iflg do k=1,l do j=1,mp do i=1,np tmp(i,j,k)=0. enddo enddo enddo do k=kllim,l do j=jllim,mp do i=illim,np tmp(i,j,k)=(a(i,j,k)+iflag*b(i,j,k))*d(i,j,k) enddo enddo enddo #if (POLES == 0) if(ibcx.eq.0 .and. leftedge.eq.1) then do k=kllim,l do j=jllim,mp tmp(1,j,k)=tmp(1,j,k)-0.5*(a(1,j,k)+iflag*b(1,j,k))*d(1,j,k) enddo enddo endif if(ibcx.eq.0 .and. rightedge.eq.1) then do k=kllim,l do j=jllim,mp tmp(np,j,k)=tmp(np,j,k)-0.5*(a(np,j,k)+iflag*b(np,j,k))*d(np,j,k) enddo enddo endif if(ibcy.eq.0 .and. botedge.eq.1) then do k=kllim,l do i=illim,np tmp(i,1,k)=tmp(i,1,k)-0.5*(a(i,1,k)+iflag*b(i,1,k))*d(i,1,k) enddo enddo endif if(ibcy.eq.0 .and. topedge.eq.1) then do k=kllim,l do i=illim,np tmp(i,mp,k)=tmp(i,mp,k)-0.5*(a(i,mp,k)+iflag*b(i,mp,k))*d(i,mp,k) enddo enddo endif #endif if(ibcz.eq.0) then do j=jllim,mp do i=illim,np tmp(i,j,1)=tmp(i,j,1)-0.5*(a(i,j,1)+iflag*b(i,j,1))*d(i,j,1) tmp(i,j,l)=tmp(i,j,l)-0.5*(a(i,j,l)+iflag*b(i,j,l))*d(i,j,l) enddo enddo endif sum=globsum(tmp,1-ih,np+ih,1-ih,mp+ih, . 1,l,illim,np,jllim,mp,kllim,l) #if (TIMEPLT == 1) call ttend(63) #endif return end subroutine sumcnsB(a,sum) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (ANALIZE == 0) common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . tmp(1-ih:np+ih, 1-ih:mp+ih, l) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 8), . tmp(1-ih:np+ih, 1-ih:mp+ih, l) #endif C#if (PARALLEL > 0) #if (SUMR16 == 1) real*16 sum #else real sum !modgs c real*8 sum #endif real globsum !modgs c real*8 globsum illim=1+ibcx*leftedge jllim=1+ibcy*botedge kllim=1+ibcz do k=1,l do j=1,mp do i=1,np tmp(i,j,k)=0. enddo enddo enddo do k=kllim,l do j=jllim,mp do i=illim,np tmp(i,j,k)=a(i,j,k) enddo enddo enddo if(ibcx.eq.0 .and. leftedge.eq.1) then do k=kllim,l do j=jllim,mp tmp(1,j,k)=tmp(1,j,k)-0.5*a(1,j,k) enddo enddo endif if(ibcx.eq.0 .and. rightedge.eq.1) then do k=kllim,l do j=jllim,mp tmp(np,j,k)=tmp(np,j,k)-0.5*a(np,j,k) enddo enddo endif if(ibcy.eq.0 .and. botedge.eq.1) then do k=kllim,l do i=illim,np tmp(i,1,k)=tmp(i,1,k)-0.5*a(i,1,k) enddo enddo endif if(ibcy.eq.0 .and. topedge.eq.1) then do k=kllim,l do i=illim,np tmp(i,mp,k)=tmp(i,mp,k)-0.5*a(i,mp,k) enddo enddo endif if(ibcz.eq.0) then do j=jllim,mp do i=illim,np tmp(i,j,1)=tmp(i,j,1)-0.5*a(i,j,1) tmp(i,j,l)=tmp(i,j,l)-0.5*a(i,j,l) enddo enddo endif sum=globsum(tmp,1-ih,np+ih,1-ih,mp+ih, . 1,l,illim,np,jllim,mp,kllim,l) return end #if (MOISTMOD > 0) subroutine totwtr(qv,qc,qr,d,qws) include 'param.nml' include 'msg.inc' dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . d(1-ih:np+ih, 1-ih:mp+ih, l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #if (SUMR16 == 1) real*16 totws #else c real totws real*8 totws #endif #if (TIMEPLT == 1) call ttbeg(59) #endif totws=0. #if (PARALLEL > 0) #if (POLES == 0) iulim=np-ibcx*rightedge julim=mp-ibcy*j3*topedge #else iulim=np julim=mp #endif kulim=l-ibcz do j=1,julim do i=1,iulim do k=1,kulim temp(i,j,k)=(qv(i,j,k)+qc(i,j,k)+qr(i,j,k))*d(i,j,k) enddo enddo enddo #if (POLES == 0) c if(ibcx.eq.0 .and. leftedge.eq.1) then c do k=1,kulim c do j=1,julim c temp(1,j,k)= c . temp(1,j,k)-0.5*(qv(1,j,k)+qc(1,j,k)+qr(1,j,k))*d(1,j,k) c enddo c enddo c endif c if(ibcx.eq.0 .and. rightedge.eq.1) then c do k=1,kulim c do j=1,julim c temp(np,j,k)= c . temp(np,j,k)-0.5*(qv(np,j,k)+qc(np,j,k)+qr(np,j,k))*d(np,j,k) c enddo c enddo c endif c if(ibcy.eq.0 .and. botedge.eq.1) then c do k=1,kulim c do i=1,iulim c temp(i,1,k)= c . temp(i,1,k)-0.5*(qv(i,1,k)+qc(i,1,k)+qr(i,1,k))*d(i,1,k) c enddo c enddo c endif c if(ibcy.eq.0 .and. topedge.eq.1) then c do k=1,kulim c do i=1,iulim c temp(i,mp,k)= c . temp(i,mp,k)-0.5*(qv(i,mp,k)+qc(i,mp,k)+qr(i,mp,k))*d(i,mp,k) c enddo c enddo c endif #endif c if(ibcz.eq.0) then do j=1,julim do i=1,iulim temp(i,j,1)= . temp(i,j,1)-0.5*(qv(i,j,1)+qc(i,j,1)+qr(i,j,1))*d(i,j,1) temp(i,j,l)= . temp(i,j,l)-0.5*(qv(i,j,l)+qc(i,j,l)+qr(i,j,l))*d(i,j,l) enddo enddo c endif totws=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l, . 1,iulim,1,julim,1,kulim) #else totws=0. do k=1,l-ibcz do j=1,mp-ibcy*j3 do i=1,np-ibcx totws=totws+(qv(i,j,k)+qc(i,j,k)+qr(i,j,k))*d(i,j,k) enddo enddo enddo #if (POLES == 0) do j=1,mp-ibcy*j3 do i=1,np-ibcx #else do j=1,mp do i=1,np #endif totws=totws - .5*(qv(i,j,1)+qc(i,j,1)+qr(i,j,1))*d(i,j,1) 1 - .5*(qv(i,j,l)+qc(i,j,l)+qr(i,j,l))*d(i,j,l) enddo enddo #endif qws=totws #if (TIMEPLT == 1) call ttend(59) #endif return end #endif subroutine diagnos(u,v,w,ox,oy,oz,th,p,x,y,z,rho,the,rh,div, * thsum0,chm,g1,g2,g3,tt,tend,qv,qc,qr,qia,qib, * qws0,rhm,dtm,drgx,drgy,zs,zh,bx,by,bz,divb) c * qws0,rhm,dtm,drgx,drgy,zs,zh) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . p(1-ih:np+ih, 1-ih:mp+ih, l), . x(1-ih:np+ih, 1-ih:mp+ih, l), . y(1-ih:np+ih, 1-ih:mp+ih, l), . z(1-ih:np+ih, 1-ih:mp+ih, l), . rho(1-ih:np+ih, 1-ih:mp+ih, l), . the(1-ih:np+ih, 1-ih:mp+ih, l), . rh(1-ih:np+ih, 1-ih:mp+ih, l), . div(1-ih:np+ih, 1-ih:mp+ih, l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . divb(1-ih:np+ih, 1-ih:mp+ih, l), . chm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc), . chmx(nspc),chmn(nspc),chav(nspc), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . rhm(1-ih:np+ih, 1-ih:mp+ih, l), . zs(1-ih:np+ih, 1-ih:mp+ih), . zh(1-ih:np+ih, 1-ih:mp+ih) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . stab(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l), . tmp4(1-ih:np+ih, 1-ih:mp+ih, l), . scr10(1-ih:np+ih, 1-ih:mp+ih, l, 9) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . stab(1-ih:np+ih, 1-ih:mp+ih, l), . defsq(1-ih:np+ih, 1-ih:mp+ih, l), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l), . tmp4(1-ih:np+ih, 1-ih:mp+ih, l), . scr3(1-ih:np+ih, 1-ih:mp+ih, l, 2) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/itero/ niter,nitsm,icount,miter,mitsm,jcount,eer,eem common/iterb/ niteb,nitsb,icounb,miteb,mitsb,jcounb,erb,emb common/vbcdg/ uinf,vinf,oinf,uout,vout,oout,tflx,epsim,epsia common/stresd/ primx,primn,priav,prisd, * kmmx,kmmn,kmav,kmsd, * ivis,irid,itstr real kmmx,kmmn,kmav,kmsd common/strese/ rimx,rimn,riav,risd, * stmx,stmn,stav,stsd, * dfmx,dfmn,dfav,dfsd data ifirst/0/ common/dragc/ dragx(nth),dragy(nth),drgnorm, itd, idrag common/dftemp/dftmx,dftmn,dftav,dftsd common/dissbc/ cstab,c00,c0h,dlstb,dtah,dtau,ntah,ntau common /water_bgdt/ totw0,totw(nth),prec(nth),sflux(nth), 1 prec_dis(np,mp) real globmax,globmin,globsum #if (TIMEPLT == 1) call ttbeg(60) #endif xnorm=(1-igrid)/float(l*m*n)+igrid/float((l-1)*(m-j3)*(n-1)) xnormj=1./float((l-2)*(m-2*j3)*(n-2)) nml=n*m*l check lipshitz and courant numbers call lipsch(ox,oy,oz,rho,g1,g2,g3,cr1,cr2,1,1) check variables bounds umx=-1.e15 umn= 1.e15 vmx=-1.e15 vmn= 1.e15 wmx=-1.e15 wmn= 1.e15 pmx=-1.e15 pmn= 1.e15 tmx=-1.e15 tmn= 1.e15 zsmx=-1.e15 zsmn= 1.e15 zhmx=-1.e15 zhmn= 1.e15 do 1 k=1,l do 1 j=1,mp do 1 i=1,np 1 tmp1(i,j,k)=th(i,j,k)+the(i,j,k) umx=max(umx,globmax(u,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) umn=min(umn,globmin(u,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) vmx=max(vmx,globmax(v,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) vmn=min(vmn,globmin(v,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) wmx=max(wmx,globmax(w,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) wmn=min(wmn,globmin(w,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) pmx=max(pmx,globmax(p,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) pmn=min(pmn,globmin(p,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) pmx=pmx*2.*dti pmn=pmn*2.*dti tmx=max(tmx,globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) tmn=min(tmn,globmin(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) zsmx=max(zsmx,globmax(zs,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1)) zsmn=min(zsmn,globmin(zs,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1)) zhmx=max(zhmx,globmax(zh,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1)) zhmn=min(zhmn,globmin(zh,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1)) call sumcns(th,p,rho,tsm0,0) if (thsum0.ne.0) then tsm=(tsm0-thsum0)/thsum0 else tsm=tsm0 endif if (mype.eq.0) then print 201,umx,umn,vmx,vmn,wmx,wmn,pmx,pmn,tmx,tmn,tsm, 1 zsmx,zsmn,zhmx,zhmn 201 format(1x,'umax, umin:',2e24.16/ 2 1x,'vmax, vmin:',2e24.16/ 3 1x,'wmax, wmin:',2e24.16/ 4 1x,'pmax, pmin:',2e24.16/ 5 1x,'thmx, thmn:',2e24.16,2x,'thsum:',e24.16/ 6 1x,'zsmx, zsmn:',2e24.16/ 7 1x,'zhmx, zhmn:',2e24.16) end if if(ichm.eq.1) then do ispc=1,nspc chmx(ispc)=-1.e15 chmn(ispc)= 1.e15 chav(ispc)=0. chmx(ispc)=max(chmx(ispc), globmax(chm(1-ih,1-ih,1,ispc) . ,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) chmn(ispc)=min(chmn(ispc), globmin(chm(1-ih,1-ih,1,ispc) . ,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) chav(ispc)=globsum(chm(1-ih,1-ih,1,ispc),1-ih,np+ih,1-ih, . mp+ih,1,l,illim,np,jllim,mp,1+igrid,l) chav(ispc)=chav(ispc)*xnorm if (mype.eq.0) print 202,ispc,chmx(ispc),chmn(ispc),chav(ispc) 202 format(1x,'ispc,chmx,chmn,chav:',i2,3e11.4) enddo endif #if (SEMILAG == 1) check lagrangian jacobian call update(x,np,mp,l,np,mp,1) call update(y,np,mp,l,np,mp,1) call update(z,np,mp,l,np,mp,1) gacmx=-1.e15 gacmn= 1.e15 gacav=0. gacsd=0. gacmxt=-1.e15 gacmnt= 1.e15 gacavt=0. gacsdt=0. #if (J3DIM == 1) #if (POLES == 0) jllim=1 +j3*botedge julim=mp-j3*topedge illim=1 +leftedge iulim=np-rightedge #else jllim=1 julim=mp illim=1 iulim=np #endif do 3 k=2,l-1 do 3 j=jllim,julim do 3 i=illim,iulim dxx= x(i+1,j,k)-x(i-1,j,k) dxy= x(i,j+j3,k)-x(i,j-j3,k) dxz= x(i,j,k+1)-x(i,j,k-1) dyx= y(i+1,j,k)-y(i-1,j,k) dyy= y(i,j+j3,k)-y(i,j-j3,k) dyz= y(i,j,k+1)-y(i,j,k-1) dzx= z(i+1,j,k)-z(i-1,j,k) dzy= z(i,j+j3,k)-z(i,j-j3,k) dzz= z(i,j,k+1)-z(i,j,k-1) #if (POLES == 0) if(ibcx.eq.1.and.dxx.gt. .25*n) dxx=dxx-float(n-1) if(ibcx.eq.1.and.dxx.lt.-.25*n) dxx=dxx+float(n-1) if(ibcy.eq.1.and.dyy.gt. .25*m) dyy=dyy-float(m-1) if(ibcy.eq.1.and.dyy.lt.-.25*m) dyy=dyy+float(m-1) #else c if(dxx.gt. .25*n) dxx=dxx-float(n-2) c if(dxx.lt.-.25*n) dxx=dxx+float(n-2) if(dxx.gt. .25*n) dxx=dxx-float(n) if(dxx.lt.-.25*n) dxx=dxx+float(n) if(dyy.gt. .25*m) dyy=dyy-float(m) if(dyy.lt.-.25*m) dyy=dyy+float(m) #endif gac=.125*( dxx*dyy*dzz+dxy*dyz*dzx+dxz*dyx*dzy 1 -dzx*dyy*dxz-dzy*dyz*dxx-dzz*dyx*dxy )*rh(i,j,k)/rho(i,j,k) gacmxt=amax1(gacmxt,gac) gacmnt=amin1(gacmnt,gac) gacavt=gacavt+gac gacsdt=gacsdt+(gac-1.)**2 3 continue #else #if (POLES == 0) if (leftedge.eq.1) then illim=2 else illim=1 end if if (rightedge.eq.1) then iulim=np-1 else iulim=np end if #else illim=1 iulim=np #endif do 31 k=2,l-1 do 31 i=illim,iulim dxx= x(i+1,1,k)-x(i-1,1,k) dxz= x(i,1,k+1)-x(i,1,k-1) dzx= z(i+1,1,k)-z(i-1,1,k) dzz= z(i,1,k+1)-z(i,1,k-1) #if (POLES == 0) if(ibcx.eq.1.and.dxx.gt. .25*n) dxx=dxx-float(n-1) if(ibcx.eq.1.and.dxx.lt.-.25*n) dxx=dxx+float(n-1) #else if(dxx.gt. .25*n) dxx=dxx-float(n) if(dxx.lt.-.25*n) dxx=dxx+float(n) #endif gac=.25*(dxx*dzz-dzx*dxz)*rh(i,1,k)/rho(i,1,k) gacmxt=amax1(gacmxt,gac) gacmnt=amin1(gacmnt,gac) gacavt=gacavt+gac gacsdt=gacsdt+(gac-1.)**2 31 continue #endif gacmx=max(gacmx,globmax(gacmxt,1,1,1,1,1,1,1,1,1,1,1,1)) gacmn=min(gacmn,globmin(gacmnt,1,1,1,1,1,1,1,1,1,1,1,1)) gacav=globsum(gacavt,1,1,1,1,1,1,1,1,1,1,1,1) gacsd=globsum(gacsdt,1,1,1,1,1,1,1,1,1,1,1,1) gacav=gacav*xnormj gacsd=sqrt(gacsd*xnormj) if (mype.eq.0) then print 203, gacmx,gacmn,gacav,gacsd 203 format(1x,'jcmx,jcmn,jcav,jcsd:',4f11.8) end if #endif check eulerian divergence igri3=igrid*j3 divmx=-1.e15 divmn= 1.e15 divav=0. if (leftedge.eq.1) then illim=1+igrid else illim=1 end if if (botedge.eq.1) then jllim=1+igri3 else jllim=1 end if divmx=globmax(div,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divmn=globmin(div,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divav=globsum(div,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divav=divav*xnorm divsd=0. do k=1+igrid,l do j=jllim,mp do i=illim,np tmp1(i,j,k)=(div(i,j,k)-divav)**2 end do end do end do divsd=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divsd=sqrt(divsd*xnorm) divmx=divmx*dt divmn=divmn*dt divav=divav*dt divsd=divsd*dt nitav=nitsm/max0(icount,1) mitav=mitsm/max0(jcount,1) if (mype.eq.0) then print 205, divmx,divmn,divav,divsd,eer,eem, . niter,nitav,miter,mitav 205 format(1x,'dvmx,dvmn,dvav,dvsd:',4e11.4/ . 1x,' eer,eem:',2e11.4/ 1 1x,'niter,nitav,miter,mitav:',4i4) end if check integrability condition for time-dependent bottom imass=1 ! print out global mass flux info if(tt.le.tend .and. tt.ne.0.) then tmass=0. tmass=globsum(rho,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) tmass=tmass*dx*dy*dz flinf=uinf+vinf+oinf+tflx flout=uout+vout+oout dmass=flinf+flout dmass=dmass/tmass ttnorm=tt/tend if (mype.eq.0.and.imass.eq.1) then print 206, tt,tend,ttnorm, * uinf,vinf,oinf, * uout,vout,oout, * tflx,flinf,flout, * dmass,epsim,epsia 206 format(1x,'tt, tend, ttnorm:',3e11.4/ 1 1x,'uinf, vinf, oinf:',3e11.4/ 2 1x,'uout, vout, oout:',3e11.4/ 3 1x,'tflx, finf, fout:',3e11.4/ 4 1x,'dmas, epsm, epsa:',3e11.4) end if endif if(irid.eq.1) then call rical(u,v,w,th,qv,qc,0) rimx=-1.e15 rimn= 1.e15 riav=0. stmx=-1.e15 stmn= 1.e15 stav=0. dfmx=-1.e15 dfmn= 1.e15 dfav=0. rimx=globmax(ri,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) rimn=globmin(ri,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) riav=globsum(ri,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) stmx=globmax(stab,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) stmn=globmin(stab,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) stav=globsum(stab,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dfmx=globmax(defsq,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dfmn=globmin(defsq,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dfav=globsum(defsq,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) riav=riav/float(nml) dfav=dfav/float(nml) stav=stav/float(nml) risd=0. stsd=0. dfsd=0. do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=(ri(i,j,k)-riav)**2 tmp2(i,j,k)=(stab(i,j,k)-stav)**2 tmp3(i,j,k)=(defsq(i,j,k)-dfav)**2 end do end do end do risd = globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) stsd = globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dfsd = globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) risd=sqrt(risd/float(nml-1)) stsd=sqrt(stsd/float(nml-1)) dfsd=sqrt(dfsd/float(nml-1)) if(rimn.le.0. .and. ifirst.eq.0) then ifirst=1 c---locate position of minimum Ri do k=1,L do j=1,mp do i=1,np if(abs(ri(i,j,k)-rimn).lt.1.0e-10) then ia=(npos-1)*np + i ja=(mpos-1)*mp + j irimin = ia jrimin = ja krimin = k endif enddo enddo enddo if (mype.eq.0) print 2059, rimn,irimin,jrimin,krimin 2059 format(' first negative Rimin=', e11.4,' at i,j,k=',3i4) endif if (mype.eq.0) then print 2060, rimx,rimn,riav,risd, 1 stmx,stmn,stav,stsd, 2 dfmx,dfmn,dfav,dfsd 2060 format(1x,'rimx, rimn, riav, risd:',4e11.4/ 1 1x,'stmx, stmn, stav, stsd:',4e11.4/ 2 1x,'dfmx, dfmn, dfav, dfsd:',4e11.4) end if endif if(ivis.eq.1) then if (mype.eq.0) then deldf=dt*(dxi**2+j3*dyi**2+dzi**2) ckmmx=kmmx*deldf ckmmn=kmmn*deldf ckmav=kmav*deldf ckmsd=kmsd*deldf print 2061, primx,primn,priav,prisd, 1 ckmmx,ckmmn,ckmav,ckmsd 2061 format(1x,'primx, primn, priav, prisd:',4e11.4/ 1 1x,' kmmx, kmmn, kmav, kmsd:',4e11.4) end if endif if (mype.eq.0.and.idrag.eq.1) then print 2062,drgx, drgy, drgnorm ! NOTE: drgx,drgy undefined 2062 format(1x,'drgx, drgy, drgnorm:',3e11.4) end if check boundary velocities ibound=1 ! print out boundary velocities do 7 k=1,l,l-1 ommx=-1.e15 ommn= 1.e15 ommx=max(ommx,globmax(oz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,k,k)) ommn=min(ommn,globmin(oz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,k,k)) if (mype.eq.0.and.ibound.eq.1) print 207,k,ommx,ommn 7 continue ummx=-1.e15 ummn= 1.e15 do k=1,l do j=1,mp do i=1,np,np-1 tmp1(i,j,k)=ummx tmp2(i,j,k)=ummn end do end do end do if (leftedge.eq.1) then do k=1,l do j=1,mp tmp1(1,j,k)=ox(1,j,k) tmp2(1,j,k)=ox(1,j,k) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp tmp1(np,j,k)=ox(np,j,k) tmp2(np,j,k)=ox(np,j,k) end do end do end if ummx=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,1,1,mp,1,l) ummn=globmin(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,1,1,mp,1,l) if (mype.eq.0.and.ibound.eq.1) then i=1 print 208,i,ummx,ummn end if #if (PARALLEL == 1) #if (CRAYT3D == 1) call mybarrier() #endif #endif ummx=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,np,np,1,mp,1,l) ummn=globmin(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,np,np,1,mp,1,l) if (mype.eq.0.and.ibound.eq.1) then i=n print 208,i,ummx,ummn end if vmmx=-1.e15 vmmn= 1.e15 do k=1,l do j=1,mp,mp-j3 do i=1,np tmp1(i,j,k)=vmmx tmp2(i,j,k)=vmmn end do end do end do if (botedge.eq.1) then do k=1,l do i=1,np tmp1(i,1,k)=oy(i,1,k) tmp2(i,1,k)=oy(i,1,k) end do end do end if vmmx=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,1,1,l) vmmn=globmin(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,1,1,l) if (mype.eq.0.and.ibound.eq.1) then j=1 print 209,j,vmmx,vmmn end if if (j3.eq.1) then #if (PARALLEL == 1) #if (CRAYT3D == 1) call mybarrier() #endif #endif if (topedge.eq.1) then do k=1,l do i=1,np tmp1(i,mp,k)=oy(i,mp,k) tmp2(i,mp,k)=oy(i,mp,k) end do end do end if vmmx=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,mp,mp,1,l) vmmn=globmin(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,mp,mp,1,l) if (mype.eq.0.and.ibound.eq.1) then j=m print 209,j,vmmx,vmmn end if end if 207 format(1x,'k,ommx,ommn:',i5,2e11.4) 208 format(1x,'i,ummx,ummn:',i5,2e11.4) 209 format(1x,'j,vmmx,vmmn:',i5,2e11.4) cyclicity check if(ibcx+ibcy+ibcz.ne.0) then call ckcyc( u,1,1,l) call ckcyc( v,2,1,l) call ckcyc( w,3,1,l) ccc call ckcyc( p,4,1,l) call ckcyc(th,5,1,l) endif if(mhd.eq. 1) then xmiu=4.e-7*acos(-1.) !magnetic permeability bxmx=-1.e15 bxmn= 1.e15 bymx=-1.e15 bymn= 1.e15 bzmx=-1.e15 bzmn= 1.e15 bxmx=amax1(bxmx, . globmax(bx,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) bxmn=amin1(bxmn, . globmin(bx,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) bymx=amax1(bymx, . globmax(by,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) bymn=amin1(bymn, . globmin(by,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) bzmx=amax1(bzmx, . globmax(bz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) bzmn=amin1(bzmn, . globmin(bz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) if (mype.eq.0) then print 701,bxmx,bxmn,bymx,bymn,bzmx,bzmn 701 format(1x,'bxmx, bxmn:',2e24.16/ 1 1x,'bymx, bymn:',2e24.16/ 2 1x,'bzmx, bzmn:',2e24.16) endif check induction divergence igri3=igrid*j3 divmx=-1.e15 divmn= 1.e15 divav=0. if (leftedge.eq.1) then illim=1+igrid else illim=1 end if if (botedge.eq.1) then jllim=1+igri3 else jllim=1 end if divmx=globmax(divb,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divmn=globmin(divb,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divav=globsum(divb,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divav=divav*xnorm divsd=0. do k=1+igrid,l do j=jllim,mp do i=illim,np tmp1(i,j,k)=(divb(i,j,k)-divav)**2 end do end do end do divsd=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l, . illim,np,jllim,mp,1+igrid,l) divsd=sqrt(divsd*xnorm) divmx=divmx*dt/sqrt(100.*xmiu) divmn=divmn*dt/sqrt(100.*xmiu) divav=divav*dt/sqrt(100.*xmiu) divsd=divsd*dt/sqrt(100.*xmiu) nitab=nitsb/max0(icounb,1) mitab=mitsb/max0(jcounb,1) if (mype.eq.0) then print 705, divmx,divmn,divav,divsd,erb,emb, . niteb,nitab,miteb,mitab 705 format(1x,'dvBmx,dvBmn,dvBav,dvBsd:',4e11.4/ . 1x,' eer,eem:',2e11.4/ 1 1x,'niteb,nitab,miteb,mitab:',4i4) end if cyclicity check if(ibcx+ibcy+ibcz.ne.0) then call ckcyc(bx,31,1,l) call ckcyc(by,32,1,l) call ckcyc(bz,33,1,l) endif endif !mhd #if (MOISTMOD > 0) check moist model if(moist.eq.1) then qvmx=-1.e15 qvmn= 1.e15 qcmx=-1.e15 qcmn= 1.e15 qrmx=-1.e15 qrmn= 1.e15 qtot=0. qvmx=amax1(qvmx, . globmax(qv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qvmn=amin1(qvmn, . globmin(qv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qcmx=amax1(qcmx, . globmax(qc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qcmn=amin1(qcmn, . globmin(qc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qrmx=amax1(qrmx, . globmax(qr,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qrmn=amin1(qrmn, . globmin(qr,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) call totwtr(qv,qc,qr,rho,qws) qtot=(qws-qws0)/qws0 totw0=qws*dz*dy*dz if (mype.eq.0) then print 301,qvmx,qvmn,qcmx,qcmn,qrmx,qrmn,qtot print 302,dftmx,dftmn,dftav,dftsd print*,' total water: ',totw0 301 format(1x,'qvmx, qvmn:',2e11.4/ 1 1x,'qcmx, qcmn:',2e11.4/ 2 1x,'qrmx, qrmn:',2e11.4,2x,'qtot:',e11.4) 302 format(1x,'dftmx, dftmn, dftav, dftsd:',4e11.4) endif #if (POLES == 0) if(ibcx+ibcy+ibcz.ne.0) then call ckcyc(qv,7,1,l) call ckcyc(qc,8,1,l) call ckcyc(qr,9,1,l) endif #endif call rhfld(th,qv,rhm,n,m,l,1) cc surface precip: day=24.*3600. do j=1,mp do i=1,np tmp1(i,j,1)=prec_dis(i,j)/float(noutp)*day prec_dis(i,j)=0. end do end do prmx=globmax(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,1) prmn=globmin(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,1) if (mype.eq.0) print 317,prmx,prmn 317 format(1x,'max, min surf. precip (mm/day):',2e11.4) endif #endif #if (TIMEPLT == 1) call ttend(60) #endif return end subroutine lipsch(u,v,w,d,g1,g2,g3,cr1,cr2,lagr0,iprnt) c ---- computes infinity norms for Courant and Lipshitz numbers include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . d(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (ANALIZE == 0) common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 8), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #endif #if (PARALLEL > 0) dimension tempcr2(1-ih:1+ih, 1-ih:1+ih) #endif real globmax #if (TIMEPLT == 1) call ttbeg(61) #endif call update(u,np,mp,l,np,mp,1) call update(v,np,mp,l,np,mp,1) call update(w,np,mp,l,np,mp,1) nml=n*m*l cr1=0. cr2=0. jllim = 1 + j3*botedge julim = mp - j3*topedge illim = 1 + leftedge iulim = np - rightedge if(lagr0.eq.1) then c --- compute Courant number do k=1,l do j=1,mp do i=1,np temp(i,j,k)=g1*abs(u(i,j,k)) + . g2*abs(v(i,j,k)) + . g3*abs(w(i,j,k)) end do end do end do cr1=globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) c --- compute Lipshitz number do 2 k=2,l-1 do 2 j=jllim,julim do 2 i=illim,iulim 2 cr2=amax1(cr2, .5*g1*abs( u(i+1,j,k)-u(i-1,j,k) ), 1 .5*g2*abs( u(i,j+j3,k)-u(i,j-j3,k) ), 1 .5*g3*abs( u(i,j,k+1)-u(i,j,k-1) ), 2 .5*g1*abs( v(i+1,j,k)-v(i-1,j,k) ), 2 .5*g2*abs( v(i,j+j3,k)-v(i,j-j3,k) ), 2 .5*g3*abs( v(i,j,k+1)-v(i,j,k-1) ), 3 .5*g1*abs( w(i+1,j,k)-w(i-1,j,k) ), 3 .5*g2*abs( w(i,j+j3,k)-w(i,j-j3,k) ), 3 .5*g3*abs( w(i,j,k+1)-w(i,j,k-1) )) else c --- compute Courant number normalized by density do k=1,l do j=1,mp do i=1,np temp(i,j,k)=(abs(u(i,j,k)) + . abs(v(i,j,k)) + . abs(w(i,j,k)))/d(i,j,k) end do end do end do cr1=globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) c --- compute Lipshitz number normalized by density gy=j3*g2+(1-j3)*1. do 20 k=2,l-1 do 20 j=jllim,julim do 20 i=illim,iulim 20 cr2=amax1(cr2,.5*g1/g1*abs( u(i+1,j,k)-u(i-1,j,k) )/d(i,j,k), 1 .5*g2/g1*abs( u(i,j+j3,k)-u(i,j-j3,k) )/d(i,j,k), 1 .5*g3/g1*abs( u(i,j,k+1)-u(i,j,k-1) )/d(i,j,k), 2 .5*g1/gy*abs( v(i+1,j,k)-v(i-1,j,k) )/d(i,j,k), 2 .5*g2/gy*abs( v(i,j+j3,k)-v(i,j-j3,k) )/d(i,j,k), 2 .5*g3/gy*abs( v(i,j,k+1)-v(i,j,k-1) )/d(i,j,k), 3 .5*g1/g3*abs( w(i+1,j,k)-w(i-1,j,k) )/d(i,j,k), 3 .5*g2/g3*abs( w(i,j+j3,k)-w(i,j-j3,k) )/d(i,j,k), 3 .5*g3/g3*abs( w(i,j,k+1)-w(i,j,k-1) )/d(i,j,k)) endif #if (PARALLEL > 0) tempcr2(1,1)=cr2 cr2=globmax(tempcr2,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1,1,1) #endif if(iprnt.eq.1) then if (mype.eq.0) then print 201,cr1,cr2 end if 201 format(1x,'cour,lipsh:',2e11.4) endif #if (TIMEPLT == 1) call ttend(61) #endif return end subroutine courB(bx,by,bz,d,xmiu,cr1,iprnt) c ---- computes infinity norms for Courant and Lipshitz numbers include 'param.nml' include 'msg.inc' dimension bx(1-ih:np+ih, 1-ih:mp+ih, l), . by(1-ih:np+ih, 1-ih:mp+ih, l), . bz(1-ih:np+ih, 1-ih:mp+ih, l), . d(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/rhswp/ rhstr(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . rh0(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/ohm/ pm(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 u(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 v(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 w(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), 1 frcb(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd,3) #if (ANALIZE == 0) common/blank/ scr15(1-ih:np+ih, 1-ih:mp+ih, l, 15), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #else common/blank/ scr8(1-ih:np+ih, 1-ih:mp+ih, l, 8), . temp(1-ih:np+ih, 1-ih:mp+ih, l) #endif #if (PARALLEL > 0) dimension tempcr2(1-ih:1+ih, 1-ih:1+ih) #endif real globmax cr1=0. if(mhd.eq.0) return do k=1,l do j=1,mp do i=1,np G110=1./(gmm(i,j,k)*cosa(i,j)) G220=1./gmm(i,j,k) G11=strxx(i,j)*g110 G12=stryx(i,j)*g110 G13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 G21=strxy(i,j)*g220 G22=stryy(i,j)*g220 G23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 G33=gi(i,j)*gmus(k) u(i,j,k)= G11*bx(i,j,k)+G21*by(i,j,k) v(i,j,k)= G12*bx(i,j,k)+G22*by(i,j,k) w(i,j,k)= G13*bx(i,j,k)+G23*by(i,j,k)+G33*bz(i,j,k) denom=sqrt(xmiu*(d(i,j,k)/rh0(i,j,k))) denomi=1./denom u(i,j,k)=u(i,j,k)*denomi v(i,j,k)=v(i,j,k)*denomi w(i,j,k)=w(i,j,k)*denomi enddo enddo enddo call update(u,np,mp,l,np,mp,iup) call update(v,np,mp,l,np,mp,iup) call update(w,np,mp,l,np,mp,iup) nml=n*m*l jllim = 1 + j3*botedge julim = mp - j3*topedge illim = 1 + leftedge iulim = np - rightedge g1=dt*dxi g2=dt*dyi g3=dt*dzi c --- compute Courant number do k=1,l do j=1,mp do i=1,np temp(i,j,k)=g1*abs(u(i,j,k)) + g2*abs(v(i,j,k)) + . g3*abs(w(i,j,k)) end do end do end do cr1=globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) if(iprnt.eq.1) then if (mype.eq.0) then print 201,cr1 end if 201 format(1x,'Alfven wave cour:',e11.4) endif return end subroutine pminmax(a,n1,n2,n3,strng) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, n3) character (*) strng real globmax,globmin flocmin=1.e10 flocmax=-1.e10 flocsum=0. do k=1,n3 do j=1,n2 do i=1,n1 flocmin=min(flocmin,a(i,j,k)) flocmax=max(flocmax,a(i,j,k)) flocsum=flocsum+a(i,j,k) end do end do end do fglobmax=globmax(flocmax,1,1,1,1,1,1,1,1,1,1,1,1) fglobmin=globmin(flocmin,1,1,1,1,1,1,1,1,1,1,1,1) fglobsum=globsum(flocsum,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) then print *,'min max: ',strng,fglobmin,fglobmax,flocsum endif return end subroutine ckcyc_old(a,iflg) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc real globmax,globmin dimension tmpxmin(1,mp,l),tmpxmax(1,mp,l) dimension tmpymin(np,1,l),tmpymax(np,1,l) dimension tmpzmin(np,mp,1),tmpzmax(np,mp,1) call update2(a,np,mp,l,np,mp,1) if(ibcx.eq.1) then cmx0=-1.e15 cmn0= 1.e15 #if (POLES == 0) do k=1,l do j=1,mp tmpxmax(1,j,k)=cmx0 tmpxmin(1,j,k)=cmn0 end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp tmpxmax(1,j,k)=(a(np,j,k) - a(np+1,j,k)) tmpxmin(1,j,k)=(a(np,j,k) - a(np+1,j,k)) end do end do end if cmx=globmax(tmpxmax,1,1,1,mp,1,l,1,1,1,mp,1,l) cmn=globmin(tmpxmin,1,1,1,mp,1,l,1,1,1,mp,1,l) cmx=amax1(cmx0,cmx) cmn=amin1(cmn0,cmn) #endif if (mype.eq.0) then if(cmx.gt. 1.e-10 .or. cmn.lt.-1.e-10) then if(iflg.eq.1) write (6,*) 'u periodicity check' if(iflg.eq.2) write (6,*) 'v periodicity check' if(iflg.eq.3) write (6,*) 'w periodicity check' if(iflg.eq.4) write (6,*) 'p periodicity check' if(iflg.eq.5) write (6,*) 'th periodicity check' if(iflg.eq.6) write (6,*) 'qv periodicity check' if(iflg.eq.7) write (6,*) 'qc periodicity check' if(iflg.eq.8) write (6,*) 'qr periodicity check' if(iflg.eq.10) write (6,*) 'qia periodicity check' if(iflg.eq.11) write (6,*) 'qib periodicity check' print 100,cmx,cmn 100 format(12x,'ibcx periodicity check; dmx, dmn=',2e11.4) endif endif endif if(ibcy.eq.1) then cmx0=-1.e15 cmn0= 1.e15 #if (POLES == 0) do k=1,l do i=1,np tmpymax(i,1,k)=cmx0 tmpymin(i,1,k)=cmn0 end do end do if (topedge.eq.1) then do k=1,l do i=1,np tmpymax(i,1,k) = (a(i,mp+1,k) - a(i,mp,k)) tmpymin(i,1,k) = (a(i,mp+1,k) - a(i,mp,k)) end do end do end if cmx=globmax(tmpymax,1,np,1,1,1,l,1,np,1,1,1,l) cmn=globmin(tmpymin,1,np,1,1,1,l,1,np,1,1,1,l) cmx=amax1(cmx0,cmx) cmn=amin1(cmn0,cmn) #endif if (mype.eq.0) then if(cmx.gt. 1.e-10 .or. cmn.lt.-1.e-10) then if(iflg.eq.1) write (6,*) 'u periodicity check' if(iflg.eq.2) write (6,*) 'v periodicity check' if(iflg.eq.3) write (6,*) 'w periodicity check' if(iflg.eq.4) write (6,*) 'p periodicity check' if(iflg.eq.5) write (6,*) 'th periodicity check' if(iflg.eq.6) write (6,*) 'qv periodicity check' if(iflg.eq.7) write (6,*) 'qc periodicity check' if(iflg.eq.8) write (6,*) 'qr periodicity check' if(iflg.eq.10) write (6,*) 'qia periodicity check' if(iflg.eq.11) write (6,*) 'qib periodicity check' print 200,cmx,cmn 200 format(12x,'ibcy periodicity check; dmx, dmn=',2e11.4) endif endif endif if(ibcz.eq.1) then cmx0=-1.e15 cmn0= 1.e15 do j=1,mp do i=1,np tmpzmax(i,j,1)=(a(i,j,l) - a(i,j,1)) tmpzmin(i,j,1)=(a(i,j,l) - a(i,j,1)) end do end do cmx=globmax(tmpzmax,1,np,1,mp,1,1,1,np,1,mp,1,1) cmn=globmin(tmpzmin,1,np,1,mp,1,1,1,np,1,mp,1,1) cmx=amax1(cmx0,cmx) cmn=amin1(cmn0,cmn) if (mype.eq.0) then if(cmx.gt. 1.e-10 .or. cmn.lt.-1.e-10) then if(iflg.eq.1) write (6,*) 'u periodicity check' if(iflg.eq.2) write (6,*) 'v periodicity check' if(iflg.eq.3) write (6,*) 'w periodicity check' if(iflg.eq.4) write (6,*) 'p periodicity check' if(iflg.eq.5) write (6,*) 'th periodicity check' if(iflg.eq.6) write (6,*) 'qv periodicity check' if(iflg.eq.7) write (6,*) 'qc periodicity check' if(iflg.eq.8) write (6,*) 'qr periodicity check' if(iflg.eq.10) write (6,*) 'qia periodicity check' if(iflg.eq.11) write (6,*) 'qib periodicity check' print 300,cmx,cmn 300 format(12x,'ibcz periodicity check; dmx, dmn=',2e11.4) endif endif endif return end subroutine ckcyc(a,iflg,iupdate,n3) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, n3) character *7 aflag common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc real globmax,globmin #if (TIMEPLT == 1) call ttbeg(64) #endif if(iupdate.eq.1) call update2(a,np,mp,n3,np,mp,1) if(iflg.eq.1) aflag='u ' if(iflg.eq.2) aflag='v ' if(iflg.eq.3) aflag='w ' if(iflg.eq.4) aflag='p ' if(iflg.eq.5) aflag='th ' if(iflg.eq.6) aflag='qv ' if(iflg.eq.7) aflag='qc ' if(iflg.eq.8) aflag='qr ' if(iflg.eq.10) aflag='qia ' if(iflg.eq.11) aflag='qib ' #if (POLES == 0) if(ibcx.eq.1) then cmx =-1.e15 cmn = 1.e15 cm1 = 0. cm2 = 0. jx=0 kx=0 if (rightedge.eq.1) then do k=1,n3 do j=1,mp ck=a(np,j,k)-a(np+1,j,k) cmx=amax1(cmx,ck) cmn=amin1(cmn,ck) if((cmx.eq.ck).or.((cmn.eq.ck))) then jx=j kx=k cm1=a(np,j,k) cm2=a(np+1,j,k) endif end do end do end if cmxg=globmax(cmx,1,1,1,1,1,1,1,1,1,1,1,1) cmng=globmin(cmn,1,1,1,1,1,1,1,1,1,1,1,1) if(cmxg.gt. 1.e-10 .or. cmng.lt.-1.e-10) then if((cmxg.eq.cmx).or.(cmng.eq.cmn)) then print 100,mype,aflag,jx,kx,cmxg,cmng,cm1,cm2 endif endif endif if(ibcy.eq.1) then cmx=-1.e15 cmn= 1.e15 iy=0 ky=0 cm1 = 0. cm2 = 0. if (topedge.eq.1) then do k=1,n3 do i=1,np ck=a(i,mp+1,k)-a(i,mp,k) cmx=amax1(cmx,ck) cmn=amin1(cmn,ck) if((cmx.eq.ck).or.((cmn.eq.ck))) then iy=i ky=k cm1=a(i,mp,k) cm2=a(i,mp+1,k) endif end do end do end if cmxg=globmax(cmx,1,1,1,1,1,1,1,1,1,1,1,1) cmng=globmin(cmn,1,1,1,1,1,1,1,1,1,1,1,1) if(cmxg.gt. 1.e-10 .or. cmng.lt.-1.e-10) then if((cmxg.eq.cmx).or.(cmng.eq.cmn)) then print 200,mype,aflag,iy,ky,cmxg,cmng,cm1,cm2 endif endif endif #endif if((ibcz.eq.1).and.(n3.gt.1)) then cmx=-1.e15 cmn= 1.e15 iz=0 jz=0 cm1 = 0. cm2 = 0. do j=1,mp do i=1,np ck=a(i,j,l)-a(i,j,1) cmx=amax1(cmx,ck) cmn=amin1(cmn,ck) if((cmx.eq.ck).or.((cmn.eq.ck))) then iz=i jz=j cm1=a(i,j,1) cm2=a(i,j,l) endif end do end do cmxg=globmax(cmx,1,1,1,1,1,1,1,1,1,1,1,1) cmng=globmin(cmn,1,1,1,1,1,1,1,1,1,1,1,1) if(cmxg.gt. 1.e-10 .or. cmng.lt.-1.e-10) then if((cmxg.eq.cmx).or.(cmng.eq.cmn)) then print 300,mype,aflag,iz,jz,cmxg,cmng,cm1,cm2 endif endif endif 100 format(1x,i4,1x,a7,' ibcx j,k:',2i3,' mx,mn,a=',2e11.4,2e11.5) 200 format(1x,i4,1x,a7,' ibcy i,k:',2i3,' mx,mn,a=',2e11.4,2e11.5) 300 format(1x,i4,1x,a7,' ibcz i,j:',2i3,' mx,mn,a=',2e11.4,2e11.5) #if (TIMEPLT == 1) call ttend(64) #endif return end subroutine negck(a,iflg) include 'param.nml' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) real globmin fmn=1.e25 fmn=globmin(a,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) if(fmn.ge.0.) then if(mype.eq.0) then if(iflg.eq.1) write (6,*) 'th nonegative' if(iflg.eq.6) write (6,*) 'qv nonegative' if(iflg.eq.7) write (6,*) 'qc nonegative' if(iflg.eq.8) write (6,*) 'qr nonegative' endif else if(mype.eq.0) then if(iflg.eq.1) write (6,*) 'th negatives' if(iflg.eq.6) write (6,*) 'qv negatives' if(iflg.eq.7) write (6,*) 'qc negatives' if(iflg.eq.8) write (6,*) 'qr negatives' endif do 1 k=1,l do 1 j=1,mp do 1 i=1,np if(a(i,j,k).lt.0.) then print 100, mype,i,j,k,a(i,j,k) endif 1 continue 100 format(2x,'mype:',i4,'i,j,k=',3i4,'value=',e11.4) endif return end subroutine rdtp(jt,u,v,w,ox,oy,oz,t,p,fx,fy,fz,ft, . fox,foy,foz,qv,qc,qr,fqv,fqc,fqr,tke,ftke,hise,epp1) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqib(1-ih:nicp+ih, 1-ih:micp+ih, lic) dimension tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke) dimension fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . hise(nthv,2) real epp1 #if (TIMEPLT == 1) call ttbeg(85) #endif read (jt) u read (jt) v read (jt) w read (jt) ox read (jt) oy read (jt) oz read (jt) t read (jt) p read (jt) fx read (jt) fy read (jt) fz read (jt) ft read (jt) fox read (jt) foy read (jt) foz read (jt) qv read (jt) qc read (jt) qr read (jt) fqv read (jt) fqc read (jt) fqr read (jt) tke read (jt) ftke read (jt) hise read (jt) epp1 #if (TIMEPLT == 1) call ttend(85) #endif return end subroutine wrtp(it,u,v,w,ox,oy,oz,t,p,fx,fy,fz,ft, . fox,foy,foz,qv,qc,qr,fqv,fqc,fqr,tke,ftke,hise,epp1) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . fqib(1-ih:nicp+ih, 1-ih:micp+ih, lic) dimension tke(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv), . ftke(1-ih:nkep+ih, 1-ih:mkep+ih, lke) dimension fox(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foy(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . foz(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . hise(nthv,2) real epp1 #if (TIMEPLT == 1) call ttbeg(86) #endif write (it) u write (it) v write (it) w write (it) ox write (it) oy write (it) oz write (it) t write (it) p write (it) fx write (it) fy write (it) fz write (it) ft write (it) fox write (it) foy write (it) foz write (it) qv write (it) qc write (it) qr write (it) fqv write (it) fqc write (it) fqr write (it) tke write (it) ftke write (it) hise write (it) epp1 #if (TIMEPLT == 1) call ttend(86) #endif return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C S E T P R O C E S S O R S G E O M E T R Y C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine geomset() c c setup geometry information for each processor c include 'param.nml' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (PARALLEL > 0) #include "msg.lnk" integer iranks(nproc), flag C---------------------------------------------------------------------- #if (PARALLEL == 2) integer :: proc_eu, isize, irank, ieupe #if (HP == 2 || FUJI_VPP == 2 || IBM == 2 || PLE == 2 || LNX==2 ) DC_TYPE = MPI_DOUBLE_PRECISION #else DC_TYPE = MPI_REAL #endif call MPI_COMM_GET_ATTR(MPI_COMM_WORLD,MPI_APPNUM,ieupe,flag,ierr) call MPI_Comm_size(MPI_COMM_WORLD, isize, ierr) ! total numbers of PE's call MPI_Comm_rank(MPI_COMM_WORLD, irank, ierr) ! number of current PE C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !Split WORLD_COMM and get EULAG ranks (mype) and size/processors (proceu) call MPI_Comm_split(MPI_COMM_WORLD,ieupe,irank,MPI_COMM_EULAG,ierr +) call MPI_Comm_size(MPI_COMM_EULAG, proc_eu, ierr ) call MPI_Comm_rank(MPI_COMM_EULAG, mype, ierr) ! !Test for insconsistency in processors numbers ! CCC CCC CCC CCC CCC CCC if(proc_eu.ne.nprocx*nprocy) then if(mype.eq.0) then PRINT *,'!!!!!! WRONG PROC NUMBER !!!!!!' print *,'!!!!!! NPE .ne. nprocx*nprocy !!!!!!' print *,'NPE = ',isize,'nprocx*nprocy=',nprocx*nprocy print *,'!!!!!! EXIT !!!!!!' endif call MPI_BARRIER(ierr) call MPI_Finalize(ierr) STOP 'GEOMSET' endif if (tag_frn > 0) call bridge_init() #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) mysize = NUM_PES() #else mysize = N$PES #endif mype = my_pe() #endif C---------------------------------------------------------------------- c print *,'mype:',mype middle = 0 rightedge = 0 leftedge = 0 botedge = 0 topedge = 0 npos = mod((mype+nprocx), nprocx) + 1 mpos = mype/nprocx + 1 c print *,'mype, npos, mpos:',mype,npos,mpos if (mod((mype+1+nprocx), nprocx).eq.0) rightedge = 1 if (mod((mype+1+nprocx), nprocx).eq.1 .or. nprocx.eq.1) . leftedge = 1 if ((mype+1).le.nprocx) botedge = 1 if (((nprocx*nprocy) - (mype+1)) .lt. nprocx) topedge = 1 if (rightedge.eq.0 .and. leftedge.eq.0 .and. botedge.eq.0 . .and. topedge.eq.0) middle = 1 peleft=mype-1 if (peleft.lt.((mpos-1)*nprocx)) peleft=mype + (nprocx-1) peright=mype+1 if (peright.gt.(mpos*nprocx - 1)) peright=mype - (nprocx-1) #if(POLES == 0) peabove=mype+nprocx if (peabove.gt.(nprocx*nprocy-1)) peabove=npos-1 pebelow=mype-nprocx if (pebelow.lt.0) pebelow=mype+((nprocy-1)*nprocx) if (npos.lt.nprocx) then perightabove=peabove+1 perightbelow=pebelow+1 else perightabove=peabove-(nprocx-1) perightbelow=pebelow-(nprocx-1) end if if (npos.ne.1) then peleftabove=peabove-1 peleftbelow=pebelow-1 else peleftabove=peabove+(nprocx-1) peleftbelow=pebelow+(nprocx-1) end if #else peabove=mype+nprocx if (peabove.gt.(nprocx*nprocy-1)) then peabove=mype+nprocx/2 if (peabove.gt.(nprocx*nprocy-1)) peabove=peabove-nprocx endif pebelow=mype-nprocx if (pebelow.lt.0) then pebelow=mype-nprocx/2 if (pebelow.lt.0) pebelow=pebelow+nprocx endif if (npos.lt.nprocx) then perightabove=peabove+1 perightbelow=pebelow+1 else perightabove=peabove-(nprocx-1) perightbelow=pebelow-(nprocx-1) end if if (npos.ne.1) then peleftabove=peabove-1 peleftbelow=pebelow-1 else peleftabove=peabove+(nprocx-1) peleftbelow=pebelow+(nprocx-1) end if change corners position for bottom and top processors if (mpos.eq.1) then perightbelow=pebelow-1 if (perightbelow.lt.0) perightbelow=perightbelow+nprocx peleftbelow=pebelow+1 if (peleftbelow.gt.(nprocx-1)) . peleftbelow=peleftbelow-nprocx endif if (mpos.eq.nprocy) then perightabove=peabove-1 if (perightabove.lt.(nprocx*(nprocy-1))) . perightabove=perightabove+nprocx peleftabove=peabove+1 if (peleftabove.gt.(nprocx*nprocy-1)) . peleftabove=peleftabove-nprocx end if #endif C---------------------------------------------------------------------- ipri=0 if (ipri.eq.1) then if (mype.eq.0) then print 98,nprocx,nprocy print 99,mype,middle,rightedge,leftedge,botedge,topedge,npos,mpos, . peleft,peright,peabove,pebelow,perightabove, . perightbelow,peleftabove,peleftbelow endif call mybarrier() if (mype.ne.0) then print 99,mype,middle,rightedge,leftedge,botedge,topedge,npos,mpos, . peleft,peright,peabove,pebelow,perightabove, . perightbelow,peleftabove,peleftbelow endif call mybarrier() 98 format('nprocx = ',i3,' nprocy = ',i3,/, .' my mid R L B T N M pL pR pT pB pRT pRB pLT pLB') 99 format(i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ', . i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3) endif C---------------------------------------------------------------------- CCCCCCCC PARALLEL ZONAV myx_pe=mype/nprocx call MPI_Comm_split(MPI_COMM_EULAG,myx_pe,mype,my_row,ierr) if (botedge.eq.1) then ! PARALLEL ZONAV for SOUTH POLE myx_pe=mpos call MPI_Comm_split(MPI_COMM_EULAG,myx_pe,mype,m_south_pole,ierr) else myx_pe=0 call MPI_Comm_split(MPI_COMM_EULAG,myx_pe,mype,m_south_pole,ierr) endif if (topedge.eq.1) then ! PARALLEL ZONAV for NORTH POLE myx_pe=mpos call MPI_Comm_split(MPI_COMM_EULAG,myx_pe,mype,m_north_pole,ierr) else myx_pe=0 call MPI_Comm_split(MPI_COMM_EULAG,myx_pe,mype,m_north_pole,ierr) endif C---------------------------------------------------------------------- CCCCCCCC TRANSFER DATA from POLE in LATITUDE DIRECTION myy_pe=npos call MPI_Comm_split(MPI_COMM_EULAG,myy_pe,mype,my_col,ierr) c call MPI_Comm_size(my_row, size, ierr) ! total numbers of PE's c print *,'my_row',mype,size c call MPI_Barrier(MPI_COMM_EULAG, ierr) c call MPI_Comm_size(my_col, size, ierr) ! total numbers of PE's c print *,'my_col',mype,size C---------------------------------------------------------------------- CCCCCCC spectral cyclic reduction C goto 777 nn=(n+1)/2*ibcx+(1-ibcx)*n mm=(m+1)/2*ibcy+(1-ibcy)*m call mpi_comm_group(MPI_COMM_EULAG,iwgroup,ierr) cccccccccccccccccccccc do jpos=1,nprocy icount=0 do ipos=1,nprocx nnp=min(nssp,nn-(ipos-1)*np) ! local value of nn for ipos irank=ipos-1+(jpos-1)*nprocx ! processor rank on position (ipos,jpos) if(nnp.ge.1) then icount=icount+1 iranks(icount)=irank endif enddo c if(mype.eq.0) print *,jpos,'AAA:',icount,'proc:',iranks(1:icount) call mpi_group_incl(iwgroup,icount,iranks,irow_gr,ierr) call mpi_comm_create(MPI_COMM_EULAG,irow_gr,my_row_sp(jpos),ierr) call MPI_group_free(irow_gr,ierr) enddo cccccccccccccccccccccc do ipos=1,nprocx icount=0 do jpos=1,nprocy mmp=min(mssp,mm-(jpos-1)*mp) ! local value of mm for jpos irank=ipos-1+(jpos-1)*nprocx ! processor rank on position (ipos,jpos) if(mmp.ge.1) then icount=icount+1 iranks(icount)=irank endif enddo c if(mype.eq.0) print *,ipos,'BBB:',icount,'proc:',iranks(1:icount) call mpi_group_incl(iwgroup,icount,iranks,icol_gr,ierr) call mpi_comm_create(MPI_COMM_EULAG,icol_gr,my_col_sp(ipos),ierr) call MPI_group_free(icol_gr,ierr) enddo cccccccccccccccccccccc call MPI_Group_free(iwgroup,ierr) 777 continue C call MPI_Finalize(ierr) C stop #else mype = 0 middle = 0 rightedge = 1 leftedge = 1 botedge = 1 topedge = 1 npos = 1 mpos = 1 peleft = 0 peright = 0 peabove = 0 pebelow = 0 perightabove = 0 perightbelow = 0 peleftabove = 0 peleftbelow = 0 #endif iprint=0 if(iprint.eq.1) then print*,'parameters from subroutine geomset:' print *,mype,topedge,botedge,rightedge,leftedge, . my_row,m_south_pole, . m_north_pole,my_col end if return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C T E S T U P D A T E S P R O C E D U R E S C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine testreal include 'param.nml' include 'param.ior' include 'msg.inc' parameter (nml=n*m*l,nm=n*m,ml=m*l,n0=10,l0=l) create model variables dimension u(1-ih:np+ih, 1-ih:mp+ih, l) dimension u2(1-ih:np+ih, 1-ih:mp+ih, l) dimension ulr(1-ih:np+ih, 1-ih:mp+ih, l) dimension ubt(1-ih:np+ih, 1-ih:mp+ih, l) dimension x(1-ior-ihlag:np+ior+ihlag, 1-ior-ihlag:mp+ior+ihlag, . 1-ior:l+ior) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check compute some relevant constants constants for computational grid print *,'Start Test' #if (POLES == 1) do i=1,n ip(i)=mod(i +n/2-1,n)+1 enddo #endif do k=1,l do j=1,mp do i=1,np u(i,j,k)=-k u2(i,j,k)=-k ulr(i,j,k)=-k ubt(i,j,k)=-k x(i,j,k)=-k enddo enddo enddo do j=1,mp do i=1,np u(i,j,1)=(mype*10000+j*100+i)*1. u2(i,j,1)=(mype*10000+j*100+i)*1. ulr(i,j,1)=(mype*10000+j*100+i)*1. ubt(i,j,1)=(mype*10000+j*100+i)*1. enddo enddo do j=1,mp do i=1,np x(i,j,1)=(mype*10000+j*100+i)*1. enddo enddo #if (PARALLEL == 1) call mybarrier() #endif call update(u,np,mp,l,np,mp,ih) call update2(u2,np,mp,l,np,mp,ih) call updatelr(ulr,np,mp,l,np,mp,ih) call updatebt(ubt,np,mp,l,np,mp,ih) #if (SEMILAG == 1) call updatelagr(x,np,mp,l+2*ior,np,mp,ihlag) #endif #if (PARALLEL == 1) call mybarrier() #endif iprintnow=0 77 continue #if (PARALLEL == 1) call mybarrier() #endif if (mype.eq.iprintnow) then print *,'update mype =',mype do j=mp+ih,1-ih,-1 print 99,u(-2,j,1),u(-1,j,1),u(0,j,1), . u(1,j,1),u(2,j,1),u(3,j,1), . u(np-2,j,1),u(np-1,j,1),u(np,j,1), . u(np+1,j,1),u(np+2,j,1),u(np+3,j,1) enddo print * print *,'update2 mype =',mype do j=mp+ih,1-ih,-1 print 99,u2(-2,j,1),u2(-1,j,1),u2(0,j,1), . u2(1 ,j,1),u2( 2,j,1),u2(3 ,j,1), . u2(np-2,j,1),u2(np-1,j,1),u2(np ,j,1), . u2(np+1,j,1),u2(np+2,j,1),u2(np+3,j,1) enddo print * print *,'updatelr mype =',mype do j=mp+ih,1-ih,-1 print 99,ulr(-2,j,1),ulr(-1,j,1),ulr(0,j,1), . ulr(1,j,1),ulr(2,j,1),ulr(3,j,1), . ulr(np-2,j,1),ulr(np-1,j,1),ulr(np,j,1), . ulr(np+1,j,1),ulr(np+2,j,1),ulr(np+3,j,1) enddo print * print *,'updatebt mype =',mype do j=mp+ih,1-ih,-1 print 99,ubt(-2,j,1),ubt(-1,j,1),ubt(0,j,1), . ubt(1,j,1),ubt(2,j,1),ubt(3,j,1), . ubt(np-2,j,1),ubt(np-1,j,1),ubt(np,j,1), . ubt(np+1,j,1),ubt(np+2,j,1),ubt(np+3,j,1) enddo print * #if (SEMILAG == 1) print *,'updatelgr mype =',mype do j=mp+ihlag+ior,1-ihlag-ior,-1 if(ior.eq.1) then print 96,x(-3,j,1),x(-2,j,1),x(-1,j,1),x(0,j,1), . x(1,j,1),x(2,j,1),x(3,j,1), . x(np-2,j,1),x(np-1,j,1),x(np,j,1), . x(np+1,j,1),x(np+2,j,1),x(np+3,j,1),x(np+4,j,1) elseif(ior.eq.2) then print 97,x(-4,j,1),x(-3,j,1),x(-2,j,1),x(-1,j,1),x(0,j,1), . x(1,j,1),x(2,j,1),x(3,j,1), . x(np-2,j,1),x(np-1,j,1),x(np,j,1), . x(np+1,j,1),x(np+2,j,1),x(np+3,j,1),x(np+4,j,1), . x(np+5,j,1) else print 98,x(-6,j,1),x(-5,j,1), . x(-4,j,1),x(-3,j,1),x(-2,j,1),x(-1,j,1),x(0,j,1), . x(1,j,1),x(2,j,1),x(3,j,1), . x(np-2,j,1),x(np-1,j,1),x(np,j,1), . x(np+1,j,1),x(np+2,j,1),x(np+3,j,1),x(np+4,j,1), . x(np+5,j,1),x(np+6,j,1),x(np+7,j,1) endif enddo print * #endif 99 format(12f7.0) 98 format(20f7.0) 97 format(16f7.0) 96 format(14f7.0) endif iprintnow=iprintnow+1 if (iprintnow.gt.(np*mp-1)) goto 103 goto 77 103 continue stop return end C++++++++++++++++++++++++++++++++++++++= subroutine test include 'param.nml' include 'param.ior' include 'msg.inc' parameter (nml=n*m*l,nm=n*m,ml=m*l,n0=10,l0=l) parameter (n1=nprocx*n0,m1=nprocy*n0) create model variables dimension u(1-ih:n0+ih, 1-ih:n0+ih, l0) dimension u2(1-ih:n0+ih, 1-ih:n0+ih, l0) dimension ulr(1-ih:n0+ih, 1-ih:n0+ih, l0) dimension ubt(1-ih:n0+ih, 1-ih:n0+ih, l0) dimension x(1-ior-ihlag:n0+ior+ihlag, 1-ior-ihlag:n0+ior+ihlag, . 1-ior:l0+ior) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check compute some relevant constants constants for computational grid print *,'Start Test' #if (POLES == 1) do i=1,n1 C ia=i+(npos-1)*np C ip(i)=mod(ia+n1/2-1,n1)+1 COLD ip(i)=mod(i+(n-2)/2-1,n-2)+1 ip(i)=mod(i +n1/2-1,n1)+1 enddo #endif do k=1,l0 do j=1,10 do i=1,10 u(i,j,k)=-k u2(i,j,k)=-k ulr(i,j,k)=-k ubt(i,j,k)=-k x(i,j,k)=-k enddo enddo enddo do j=1,10 do i=1,10 u(i,j,1)=(mype*100+(j-1)*10+i)*1. u2(i,j,1)=(mype*100+(j-1)*10+i)*1. ulr(i,j,1)=(mype*100+(j-1)*10+i)*1. ubt(i,j,1)=(mype*100+(j-1)*10+i)*1. x(i,j,1)=(mype*100+(j-1)*10+i)*1. enddo enddo #if (PARALLEL == 1) call mybarrier() #endif call update(u,n0,n0,l0,n0,n0,ih) call update2(u2,n0,n0,l0,n0,n0,ih) call updatelr(ulr,n0,n0,l0,n0,n0,ih) call updatebt(ubt,n0,n0,l0,n0,n0,ih) #if (SEMILAG == 1) call updatelagr(x,n0,n0,l0,n0,n0,ihlag) #endif #if (PARALLEL == 1) call mybarrier() #endif iprintnow=0 77 continue #if (PARALLEL == 1) call mybarrier() #endif if (mype.eq.iprintnow) then print *,'update mype =',mype do j=n0+ih,1-ih,-1 print 99,u(-2,j,1),u(-1,j,1),u(0,j,1),u(1,j,1),u(2,j,1), . u(3,j,1),u(4,j,1),u(5,j,1),u(6,j,1),u(7,j,1), . u(8,j,1),u(9,j,1),u(10,j,1),u(11,j,1),u(12,j,1), . u(13,j,1) enddo print * print *,'update2 mype =',mype do j=n0+ih,1-ih,-1 print 99,u2(-2,j,1),u2(-1,j,1),u2(0,j,1),u2(1,j,1),u2(2,j,1), . u2(3,j,1),u2(4,j,1),u2(5,j,1),u2(6,j,1),u2(7,j,1), . u2(8,j,1),u2(9,j,1),u2(10,j,1),u2(11,j,1),u2(12,j,1), . u2(13,j,1) enddo print * print *,'updatelr mype =',mype do j=n0+ih,1-ih,-1 print 99,ulr(-2,j,1),ulr(-1,j,1),ulr(0,j,1),ulr(1,j,1),ulr(2,j,1), . ulr(3,j,1),ulr(4,j,1),ulr(5,j,1),ulr(6,j,1),ulr(7,j,1), . ulr(8,j,1),ulr(9,j,1),ulr(10,j,1),ulr(11,j,1),ulr(12,j,1), . ulr(13,j,1) enddo print * print *,'updatebt mype =',mype do j=n0+ih,1-ih,-1 print 99,ubt(-2,j,1),ubt(-1,j,1),ubt(0,j,1),ubt(1,j,1),ubt(2,j,1), . ubt(3,j,1),ubt(4,j,1),ubt(5,j,1),ubt(6,j,1),ubt(7,j,1), . ubt(8,j,1),ubt(9,j,1),ubt(10,j,1),ubt(11,j,1),ubt(12,j,1), . ubt(13,j,1) enddo print * #if (SEMILAG == 1) print *,'updatelgr mype =',mype do j=n0+ihlag+ior,1-ihlag-ior,-1 print 98,x(-3,j,1),x(-2,j,1),x(-1,j,1),x(0,j,1),x(1,j,1),x(2,j,1), . x(3,j,1),x(4,j,1),x(5,j,1),x(6,j,1),x(7,j,1), . x(8,j,1),x(9,j,1),x(10,j,1),x(11,j,1),x(12,j,1), . x(13,j,1),x(14,j,1) enddo print * #endif 99 format(16f5.0) 98 format(18f5.0) endif iprintnow=iprintnow+1 if (iprintnow.gt.0) goto 103 goto 77 103 continue #if (PARALLEL == 1) call mybarrier() #endif us=globsum(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) um=globmax(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) un=globmin(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) c print *,'my_pe:',mype,' max:',um,' min:',un,' sum:',us do i=1,10 do j=1,10 u(i,j,1)=u(i,j,1)-um u(i,j,1)=u(i,j,1)*10e-2 u(i,j,1)=u(i,j,1)**8 enddo enddo #if (PARALLEL == 1) call mybarrier() #endif us1=globsum(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) um1=globmax(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) un1=globmin(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) do i=1,10 do j=1,10 u(i,j,1)=u(i,j,1)*(-1.) enddo enddo #if (PARALLEL == 1) call mybarrier() #endif us2=globsum(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) um2=globmax(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) un2=globmin(u,1-ih,n0+ih,1-ih,n0+ih,1,l,1,n0,1,n0,1,1) print *,'my_pe:',mype,' M:',um1,' N:',un1,' S:',us1 print *,'my_pe:',mype,' M:',um2,' N:',un2,' S:',us2 stop return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C I / O S U B R O U T I N E S C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C I / O XAVERAGES (ZONAL AVERAGES) C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c---------------------------------------------------------- c parameters used to define different fields for xaverage c---------------------------------------------------------- blockdata blio c---------------------------------------------------------- c parameters used to define different slices c---------------------------------------------------------- common /isflagxz/ iuvsxz,ivvsxz,iwvsxz,ioxsxz,ioysxz,iozsxz, . irhsxz,ithsxz,iprsxz,idvsxz,ikmsxz,ichsxz, . iqvsxz,iqcsxz,iqrsxz,iqasxz,iqbsxz common /isflagyz/ iuvsyz,ivvsyz,iwvsyz,ioxsyz,ioysyz,iozsyz, . irhsyz,ithsyz,iprsyz,idvsyz,ikmsyz,ichsyz, . iqvsyz,iqcsyz,iqrsyz,iqasyz,iqbsyz common /isflagxy/ iuvsxy,ivvsxy,iwvsxy,ioxsxy,ioysxy,iozsxy, . irhsxy,ithsxy,iprsxy,idvsxy,ikmsxy,ichsxy, . iqvsxy,iqcsxy,iqrsxy,iqasxy,iqbsxy c---------------------------------------------------------- data iuvsxz,iuvsyz,iuvsxy / 1, 1, 1 / ! data ivvsxz,ivvsyz,ivvsxy / 1, 1, 1 / ! data iwvsxz,iwvsyz,iwvsxy / 1, 1, 1 / ! data ioxsxz,ioxsyz,ioxsxy / 1, 1, 1 / ! data ioysxz,ioysyz,ioysxy / 1, 1, 1 / ! data iozsxz,iozsyz,iozsxy / 1, 1, 1 / ! data ithsxz,ithsyz,ithsxy / 1, 1, 1 / ! data iprsxz,iprsyz,iprsxy / 1, 1, 1 / ! data idvsxz,idvsyz,idvsxy / 0, 0, 0 / ! data irhsxz,irhsyz,irhsxy / 0, 0, 0 / ! data ikmsxz,ikmsyz,ikmsxy / 0, 0, 0 / ! data iqvsxz,iqvsyz,iqvsxy / 0, 0, 0 / ! data iqcsxz,iqcsyz,iqcsxy / 0, 0, 0 / ! data iqrsxz,iqrsyz,iqrsxy / 0, 0, 0 / ! data iqasxz,iqasyz,iqasxy / 0, 0, 0 / ! data iqbsxz,iqbsyz,iqbsxy / 0, 0, 0 / ! data ichsxz,ichsyz,ichsxy / 0, 0, 0 / ! common /xavflag/ iuxav,ivxav,iwxav,itxav,ipxav, . iu2xav,iv2xav,iw2xav,irwvxav, . irwuxav,irvuxav,irhoxav,itwxav, . ioxxav,ioyxav,iozxav, . iox2xav,ioy2xav,ioz2xav, . ibxxav,ibyxav,ibzxav, . ibx2xav,iby2xav,ibz2xav, . ibzbyxav,ibzbxxav,ibxbyxav data iuxav,ivxav,iwxav,itxav,ipxav / 1, 1, 1, 1, 1/ ! data iu2xav,iv2xav,iw2xav,itwxav / 1, 1, 1, 1/ ! data irwvxav,irwuxav,irvuxav,irhoxav /1, 1, 1, 1/ ! data ioxxav,ioyxav,iozxav / 1, 1, 1/ ! data iox2xav,ioy2xav,ioz2xav / 1, 1, 1/ ! data ibxxav,ibyxav,ibzxav /1, 1, 1/ data ibx2xav,iby2xav,ibz2xav /1, 1, 1/ data ibzbyxav,ibzbxxav,ibxbyxav /1, 1, 1/ end subroutine xaver(u,v,w,ox,oy,oz,bx,by,bz,th,p,tau,iflg) include 'param.nml' include 'msg.inc' logical :: file_exists dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . p(1-ih:np+ih, 1-ih:mp+ih, l), . tau(l,1-ih:np+ih,1-ih:mp+ih), . u2(1-ih:np+ih, 1-ih:mp+ih, l), . v2(1-ih:np+ih, 1-ih:mp+ih, l), . w2(1-ih:np+ih, 1-ih:mp+ih, l), . ox2(1-ih:np+ih, 1-ih:mp+ih, l), . oy2(1-ih:np+ih, 1-ih:mp+ih, l), . oz2(1-ih:np+ih, 1-ih:mp+ih, l), . rwv(1-ih:np+ih, 1-ih:mp+ih, l), . rwu(1-ih:np+ih, 1-ih:mp+ih, l), . rvu(1-ih:np+ih, 1-ih:mp+ih, l), . thw(1-ih:np+ih, 1-ih:mp+ih, l) dimension bx(1-ih:np+ih, 1-ih:mp+ih, l), . by(1-ih:np+ih, 1-ih:mp+ih, l), . bz(1-ih:np+ih, 1-ih:mp+ih, l), . bx2(1-ih:np+ih, 1-ih:mp+ih, l), . by2(1-ih:np+ih, 1-ih:mp+ih, l), . bz2(1-ih:np+ih, 1-ih:mp+ih, l), . bzby(1-ih:np+ih, 1-ih:mp+ih, l), . bzbx(1-ih:np+ih, 1-ih:mp+ih, l), . bxby(1-ih:np+ih, 1-ih:mp+ih, l) dimension arrayyz(m,l) common/profl/ th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common /xavflag/ iuxav,ivxav,iwxav,itxav,ipxav, . iu2xav,iv2xav,iw2xav,irwvxav, . irwuxav,irvuxav,irhoxav,itwxav, . ioxxav,ioyxav,iozxav, . iox2xav,ioy2xav,ioz2xav, . ibxxav,ibyxav,ibzxav, . ibx2xav,iby2xav,ibz2xav, . ibzbyxav,ibzbxxav,ibxbyxav #if (POLES == 0) iulim=np-ibcx*rightedge #else iulim=np #endif if (iflg.eq.0) then call reduce_sum(th0,arrayyz,tau,0) if (mype.eq.0) call write_bcprofl(arrayyz) call reduce_sum(rho,arrayyz,tau,0) if (mype.eq.0) call write_bcprofl(arrayyz) call reduce_sum(the,arrayyz,tau,0) if (mype.eq.0) call write_bcprofl(arrayyz) call reduce_sum(ue,arrayyz,tau,0) if (mype.eq.0) call write_bcprofl(arrayyz) call reduce_sum(ve,arrayyz,tau,0) if (mype.eq.0) call write_bcprofl(arrayyz) endif !computing reynold stresses components do k=1,l do j=1,mp do i=1,np u2(i,j,k)=u(i,j,k)**2 v2(i,j,k)=v(i,j,k)**2 w2(i,j,k)=w(i,j,k)**2 ox2(i,j,k)=ox(i,j,k)**2 oy2(i,j,k)=oy(i,j,k)**2 oz2(i,j,k)=oz(i,j,k)**2 rwv(i,j,k)=rho(i,j,k)*oz(i,j,k)*v(i,j,k) rwu(i,j,k)=rho(i,j,k)*oz(i,j,k)*u(i,j,k) rvu(i,j,k)=rho(i,j,k)*oy(i,j,k)*u(i,j,k) bx2(i,j,k)=bx(i,j,k)**2 by2(i,j,k)=by(i,j,k)**2 bz2(i,j,k)=bz(i,j,k)**2 bzby(i,j,k)=bz(i,j,k)*by(i,j,k) bzbx(i,j,k)=bz(i,j,k)*bx(i,j,k) bxby(i,j,k)=bx(i,j,k)*by(i,j,k) thw(i,j,k)=th(i,j,k)*w(i,j,k) end do end do end do if (iflg.eq.0.and.irst.eq.0) then if(mype.eq.0) then inquire(FILE="xaverages.dat", exist=file_exists) if(file_exists) then print *, 'FILE xaverages.dat EXISTS = ',file_exists open(1,file="xaverages.dat") close(1,status='delete') endif inquire(FILE="fluxav.dat", exist=file_exists) if(file_exists) then print *, 'FILE fluxav.dat EXISTS = ',file_exists open(1,file="fluxav.dat") close(1,status='delete') endif endif else ! HERE SHOULD BE WRITTEN THE QUANTITIES TO AVERAGE if (itwxav.eq.1) call reduce_sum(thw,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iuxav.eq.1) call reduce_sum(u,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ivxav.eq.1) call reduce_sum(v,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iwxav.eq.1) call reduce_sum(w,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ioxxav.eq.1) call reduce_sum(ox,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ioyxav.eq.1) call reduce_sum(oy,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iozxav.eq.1) call reduce_sum(oz,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iu2xav.eq.1) call reduce_sum(u2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iv2xav.eq.1) call reduce_sum(v2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iw2xav.eq.1) call reduce_sum(w2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iox2xav.eq.1) call reduce_sum(ox2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ioy2xav.eq.1) call reduce_sum(oy2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ioz2xav.eq.1) call reduce_sum(oz2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (irwvxav.eq.1) call reduce_sum(rwv,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (irwuxav.eq.1) call reduce_sum(rwu,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (irvuxav.eq.1) call reduce_sum(rvu,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibxxav.eq.1) call reduce_sum(bx,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibyxav.eq.1) call reduce_sum(by,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibzxav.eq.1) call reduce_sum(bz,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibx2xav.eq.1) call reduce_sum(bx2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (iby2xav.eq.1) call reduce_sum(by2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibz2xav.eq.1) call reduce_sum(bz2,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibzbyxav.eq.1) call reduce_sum(bzby,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibzbxxav.eq.1) call reduce_sum(bzbx,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ibxbyxav.eq.1) call reduce_sum(bxby,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (ipxav.eq.1) call reduce_sum(p,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) if (itxav.eq.1) call reduce_sum(th,arrayyz,tau,0) if (mype.eq.0) call write_xaver(arrayyz,iflg) end if return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine write_fluxav(fyz,it) include "param.nml" include "msg.inc" dimension fyz(m,l) open(1,file="fluxav.dat",form='unformatted', & position='append') write(1), fyz,it close(1) return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine write_xaver(fyz,it) include "param.nml" include "msg.inc" dimension fyz(m,l) open(1,file="xaverages.dat",form='unformatted', & position='append') write(1), fyz,it close(1) return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine write_bcprofl(fyz) include "param.nml" include "msg.inc" dimension fyz(m,l) open(1,file="bcprofl.dat",form='unformatted', & position='append') write(1), fyz close(1) return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine iorsh(u,v,w,t,p,bx,by,bz,icomm) !mod iosh C--------------------------------------------------------------------- C icomm=1 -> read data from tape and put its values to local array C icomm=0 -> read data from tape and do nothing, this allow to skip C to the proper record on the tape during the next read attempt C C The other method is to direct specify the initial record C on the tape from which the data have to be read. C--------------------------------------------------------------------- include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) if (mype.eq.0) then call ioreadsh0(u,v,w,t,p,bx,by,bz,icomm) !mod iosh else call ioreadshk(u,v,w,t,p,bx,by,bz,icomm) !mod iosh end if return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C I / O S L I C E S C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine slices(u,v,w,ox,oy,oz,th,p,tke, * chm,qv,qc,qr,qia,qib,iflg) include "param.nml" include "msg.inc" parameter (ispecial=1) parameter (ixz=1, msl=1, inzxz=1) ! XZ slices parameter (iyz=1, nsl=1, inzyz=1) ! YZ slices parameter (ixy=1, lsl=4, inzxy=1) ! XY slices dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . ox(1-ih:np+ih, 1-ih:mp+ih, l), . oy(1-ih:np+ih, 1-ih:mp+ih, l), . oz(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . p(1-ih:np+ih, 1-ih:mp+ih, l), . tke(1-ih:nkep+ih, 1-ih:mkep+ih, lke), . chm(1-ih:nchp+ih, 1-ih:mchp+ih, lch, nspc), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qr(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic) dimension arrayxy(np,mp),iindx(nsl),jindx(msl),kindx(lsl) dimension fisum(n),fjsum(m) dimension findx(n),fjndx(m) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/realtp/ zsib(1-ih:nibp+ih,1-ih:mibp+ih,lib), . zsib2(1-ih:nibp+ih,1-ih:mibp+ih),tsibi common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/chmind/ i1vh,j1vh,i2vh,j2vh,i3vh,j3vh common /ioflags2/ itops common /isflagxz/ iuvsxz,ivvsxz,iwvsxz,ioxsxz,ioysxz,iozsxz, . irhsxz,ithsxz,iprsxz,idvsxz,ikmsxz,ichsxz, . iqvsxz,iqcsxz,iqrsxz,iqasxz,iqbsxz common /isflagyz/ iuvsyz,ivvsyz,iwvsyz,ioxsyz,ioysyz,iozsyz, . irhsyz,ithsyz,iprsyz,idvsyz,ikmsyz,ichsyz, . iqvsyz,iqcsyz,iqrsyz,iqasyz,iqbsyz common /isflagxy/ iuvsxy,ivvsxy,iwvsxy,ioxsxy,ioysxy,iozsxy, . irhsxy,ithsxy,iprsxy,idvsxy,ikmsxy,ichsxy, . iqvsxy,iqcsxy,iqrsxy,iqasxy,iqbsxy common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profrhoi/rhoi(np,mp,l) common/tkeprfl/ tkeprf(1-ih:nkvp+ih, 1-ih:mkvp+ih, lkv) #if(NETCDFO == 2) #include "pnetcdf.inc" #include "msg.lnk" integer(KIND=MPI_OFFSET_KIND) ifrmask character(len=8) chname integer cmode #endif ispec=ispecial iprint=0 if(iflg.eq.0) then if(mype.eq.0) print *,'INITIALIZE SLICE OUTPUT' if(ismode.eq.0) then if(mype.eq.0) then if(ixz.eq.1) write(31) n,m,l,lch,nspc,lms,lic,msl if(iyz.eq.1) write(32) n,m,l,lch,nspc,lms,lic,nsl if(ixy.eq.1) write(33) n,m,l,lch,nspc,lms,lic,lsl endif else #if(NETCDFO == 2) cmode=NF_WRITE+NF_64BIT_OFFSET if(ixz.eq.1) then ier = nfmpi_create(MPI_COMM_EULAG,'xzslc.nc', . cmode, MPI_INFO_NULL, nfhdxz) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice create xzslc.nc ',nfmpi_strerror(ier) ier = nfmpi_close(nfhdxz) endif if(iyz.eq.1) then ier = nfmpi_create(MPI_COMM_EULAG,'yzslc.nc', . cmode, MPI_INFO_NULL, nfhdyz) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice create yzslc.nc ',nfmpi_strerror(ier) ier = nfmpi_close(nfhdyz) endif if(ixy.eq.1) then ier = nfmpi_create(MPI_COMM_EULAG,'xyslc.nc', . cmode, MPI_INFO_NULL, nfhdxy) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice create xyslc.nc ',nfmpi_strerror(ier) ier = nfmpi_close(nfhdxy) endif #endif endif endif ! iflg = 0 create files do k=1,l zcr(k)=(k-1)*dz enddo #if (IMRSB == 0) do j=1,mp do i=1,np arrayxy(i,j)=zs(i,j) enddo enddo #else do j=1,mp do i=1,np arrayxy(i,j)=zsib2(i,j) enddo enddo #endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! slices over topography !-------------------------------------------------- if(ispec.eq.2) then amp=0. do j=1,mp do i=1,np amp=max(amp,arrayxy(i,j)) enddo enddo amp=globmax(amp,1,1,1,1,1,1,1,1,1,1,1,1) if(amp.gt.0) then !-------------------------------------------------- ! find location of max topography amplitude !-------------------------------------------------- fimax=0. fjmax=0. do j=1,mp ja=(mpos-1)*mp + j do i=1,np ia=(npos-1)*np + i if(amp.eq.arrayxy(i,j)) then fimax=float(ia) fjmax=float(ja) endif enddo enddo fimax=globmax(fimax,1,1,1,1,1,1,1,1,1,1,1,1) fjmax=globmax(fjmax,1,1,1,1,1,1,1,1,1,1,1,1) imax=fimax jmax=fjmax !---------------------------------------------------- ! find location of max averaged topography amplitude !---------------------------------------------------- do i=1,n fisum(i)=0. findx(i)=0. enddo do j=1,m fjsum(j)=0. fjndx(j)=0. enddo do i=1,np ia=(npos-1)*np + i fisum(ia)=0. findx(ia)=0. do j=1,mp if(arrayxy(i,j).gt.0.) then fisum(ia)=fisum(ia)+arrayxy(i,j) findx(ia)=findx(ia)+1. endif enddo enddo fisumg=0. iindxg=0 do i=1,n findx(i)=globsum(findx(i),1,1,1,1,1,1,1,1,1,1,1,1) fisum(i)=globsum(fisum(i),1,1,1,1,1,1,1,1,1,1,1,1)/findx(i) fisumg=max(fisumg,fisum(i)) if(fisum(i).eq.fisumg) iindxg=i enddo do j=1,mp ja=(mpos-1)*mp + j fjsum(ja)=0. fjndx(ja)=0. do i=1,np if(arrayxy(i,j).gt.0.) then fjsum(ja)=fjsum(ja)+arrayxy(i,j) fjndx(ja)=fjndx(ja)+1. endif enddo enddo fjsumg=0. jindxg=0 do j=1,n fjndx(j)=globsum(fjndx(j),1,1,1,1,1,1,1,1,1,1,1,1) fjsum(j)=globsum(fjsum(j),1,1,1,1,1,1,1,1,1,1,1,1)/fjndx(j) fjsumg=max(fjsumg,fjsum(j)) if(fjsum(j).eq.fjsumg) jindxg=j enddo iindx(1)=(n-1)/2+1 ! center of the domain iindx(2)=iindxg ! max topography iindx(3)=imax ! max average of topography jindx(1)=(m-j3)/2+1 ! center of the domain jindx(2)=jindxg ! max topography jindx(3)=jmax ! max average of topography kindx(1)=1 kindx(2)=2 kindx(3)=3 kindx(4)=4 kindx(5)=5 kindx(6)=min(nint((amp*0.35)/dz+1.),l) kindx(7)=min(nint((amp*0.50)/dz+1.),l) else ! iamp == 0 ispec=0 endif ! iamp endif ! ispec = 2 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! define slices by hand !-------------------------------------------------- if(ispec.eq.1) then c iindx(1)=i1vh c iindx(2)=i2vh c iindx(3)=i3vh iindx(1)=n/2 c jindx(1)=j1vh c jindx(2)=j2vh c jindx(3)=j3vh jindx(1)=m/2 c kindx(1)=1 c kindx(2)=min(nint((zb*0.10)/dz+1.),l) c kindx(3)=min(nint((zb*0.25)/dz+1.),l) c kindx(4)=min(nint((zb*0.35)/dz+1.),l) c kindx(5)=min(nint((zb*0.50)/dz+1.),l) c kindx(6)=min(nint((zb*0.75)/dz+1.),l) c kindx(7)=min(nint((zb*1.00)/dz+1.),l) kindx(1)=min(nint((zb*0.35)/dz+1.),l) kindx(2)=min(nint((zb*0.50)/dz+1.),l) kindx(3)=min(nint((zb*0.75)/dz+1.),l) kindx(4)=min(nint((zb*0.95)/dz+1.),l) endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! semi-default automatic configuration !-------------------------------------------------- if(ispec.eq.0) then do ii=1,nsl iindx(ii)=max(min((n-1)*ii/(nsl+1)+1,n),1) if(mype.eq.0) print *,'iindx:',ii,iindx(ii) enddo do jj=1,msl jindx(jj)=max(min((m-j3)*jj/(msl+1)+1,m),1) if(mype.eq.0) print *,'jindx:',jj,jindx(jj) enddo do kk=2,lsl-1 kindx(kk)=max(min((l-1)*kk/(lsl+1)+1,l),1) if(mype.eq.0) print *,'kindx:',kk,kindx(kk) enddo kindx(1 )=1 kindx(lsl)=l endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! vertical xz slices ! --------------------------------- if(ixz.eq.1) then inr=31 inz=inzxz if(mype.eq.0) print *,'WRITE XZ SLICE OUTPUT',iflg,jindx if(ismode.eq.0) then if(mype.eq.0) write(inr) jindx if(mype.eq.0) write(inr) inz if(mype.eq.0) write(inr) iflg,stime else #if(NETCDFO == 2) if(iflg.gt.0) then ! advance frame number ier = nfmpi_open( MPI_COMM_EULAG,'xzslc.nc', . NF_READ, MPI_INFO_NULL, nfhdxz) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xzslc open stat ',nfmpi_strerror(ier) ier=nfmpi_inq_unlimdim(nfhdxz,ihnd) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xzslc inq unlim dim ',nfmpi_strerror(ier) ier=nfmpi_inq_dimlen(nfhdxz,ihnd,ifrmask) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xzslc inq dimlen ',nfmpi_strerror(ier) ifraxz=ifrmask+1 ier=nfmpi_close(nfhdxz) else ifraxz=0 endif #endif endif ! -------- ! write zs ! -------- if(ismode.eq.0) then if (mype.eq.0) then call slicexy0(arrayxy,inr) else call slicexyk(arrayxy) end if call mybarrier() else #if(NETCDFO == 2) #if (IMRSB == 0) call pnet_out_chunk('zs ','xzslc.nc',13,1,1,1,ifraxz,zs) #else call pnet_out_chunk('zs ','xzslc.nc',13,1,1,1,ifraxz,zsib) #endif #endif endif ! -------- ! write zh ! -------- C do i=1,np C do j=1,mp C arrayxy(i,j)=zh(i,j) C enddo C enddo C if (mype.eq.0) then C call slicexy0(arrayxy,inr) C else C call slicexyk(arrayxy) C end if c call mybarrier() do jsl=1,msl if(ismode.eq.0) then if(iuvsxz.eq.1) call writeslxz(u ,zcr,inz,jindx(jsl),1,inr) if(ivvsxz.eq.1) call writeslxz(v ,zcr,inz,jindx(jsl),2,inr) if(iwvsxz.eq.1) call writeslxz(w ,zcr,inz,jindx(jsl),3,inr) if(ioxsxz.eq.1) call writeslxz(ox ,zcr,inz,jindx(jsl),4,inr) if(ioysxz.eq.1) call writeslxz(oy ,zcr,inz,jindx(jsl),5,inr) if(iozsxz.eq.1) call writeslxz(oz ,zcr,inz,jindx(jsl),6,inr) if(ithsxz.eq.1) call writeslxz(th ,zcr,inz,jindx(jsl),7,inr) if(iprsxz.eq.1) call writeslxz(p ,zcr,inz,jindx(jsl),8,inr) if(irhsxz.eq.1) call writeslxz(rho,zcr,inz,jindx(jsl),9,inr) if(ikesxz.eq.1) call writeslxz(tke,zcr,inz,jindx(jsl),10,inr) else #if(NETCDFO == 2) if(iuvsxz.eq.1) call pnet_out_chunk . ('u_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,u) if(ivvsxz.eq.1) call pnet_out_chunk . ('v_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,v) if(iwvsxz.eq.1) call pnet_out_chunk . ('w_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,w) if(ioxsxz.eq.1) call pnet_out_chunk . ('ox_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,ox) if(ioysxz.eq.1) call pnet_out_chunk . ('oy_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,oy) if(iozsxz.eq.1) call pnet_out_chunk . ('oz_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,oz) if(ithsxz.eq.1) call pnet_out_chunk . ('th_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,th) if(iprsxz.eq.1) call pnet_out_chunk . ('pr_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,p) if(irhsxz.eq.1) call pnet_out_chunk . ('rh_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,rho) if(ikesxz.eq.1) call pnet_out_chunk . ('ke_xzcross','xzslc.nc',11,1,jindx(jsl),1,ifraxz,tke) #endif cTo add more variables, just copy and edit out_chunk call endif !ismode if(ichsxz.eq.1 .and. lch.gt.1) then do ispc=1,nspc ifl=20+ispc if(ismode.eq.0) then call writeslxz(chm(1-ih,1-ih,1,ispc),zcr,inz,jindx(jsl),ifl,inr) else #if(NETCDFO == 2) if(ich.lt.10) write(chname,'(a,i1)') 'chmsp_0',ich if(ich.ge.10) write(chname,'(a,i2)') 'chmsp_',ich call pnet_out_chunk .(chname,'xzslc.nc',11,1,jindx(jsl),1,ifraxz,chm(1-ih,1-ih,1,ispc)) #endif endif enddo endif if(lms.gt.1) then if(ismode.eq.0) then if(iqvsxz.eq.1) call writeslxz(qv ,zcr,inz,jindx(jsl),12,inr) if(iqcsxz.eq.1) call writeslxz(qc ,zcr,inz,jindx(jsl),13,inr) if(iqrsxz.eq.1) call writeslxz(qr ,zcr,inz,jindx(jsl),14,inr) else #if(NETCDFO == 2) if(iqvsxz.eq.1) call pnet_out_chunk . ('qvxzcros','xzslc.nc',11,1,jindx(jsl),1,ifraxz,qv) if(iqcsxz.eq.1) call pnet_out_chunk . ('qcxzcros','xzslc.nc',11,1,jindx(jsl),1,ifraxz,qc) if(iqrsxz.eq.1) call pnet_out_chunk . ('qrxzcros','xzslc.nc',11,1,jindx(jsl),1,ifraxz,qr) #endif endif !ismode endif !lms if(lic.gt.1) then if(ismode.eq.0) then if(iqasxz.eq.1) call writeslxz(qia,zcr,inz,jindx(jsl),15,inr) if(iqbsxz.eq.1) call writeslxz(qib,zcr,inz,jindx(jsl),16,inr) else #if(NETCDFO == 2) if(iqasxz.eq.1) call pnet_out_chunk . ('qiaxzcro','xzslc.nc',11,1,jindx(jsl),1,ifraxz,qia) if(iqbsxz.eq.1) call pnet_out_chunk . ('qibxzcro','xzslc.nc',11,1,jindx(jsl),1,ifraxz,qib) #endif endif !ismode endif !lic enddo if(mype.eq.0) print *,'WRITE XZ SLICE OUTPUT DONE' endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! vertical yz slices ! --------------------------------- if(iyz.eq.1) then inr=32 inz=inzyz if(mype.eq.0) print *,'WRITE YZ SLICE OUTPUT',iflg,iindx if(ismode.eq.0) then if(mype.eq.0) write(inr) iindx if(mype.eq.0) write(inr) inz if(mype.eq.0) write(inr) iflg,stime else #if(NETCDFO == 2) if(iflg.gt.0) then ! advance frame number ier = nfmpi_open( MPI_COMM_EULAG,'yzslc.nc', . NF_READ, MPI_INFO_NULL, nfhdyz) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice yzslc open stat ', . nfmpi_strerror(ier) ier=nfmpi_inq_unlimdim(nfhdyz,ihnd) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice yzslc inq unlim dim',nfmpi_strerror(ier) ier=nfmpi_inq_dimlen(nfhdyz,ihnd,ifrmask) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice yzslc inq dimlen',nfmpi_strerror(ier) ifrayz=ifrmask+1 ier=nfmpi_close(nfhdyz) else ifrayz=0 endif #endif endif ! -------- ! write zs ! -------- if(ismode.eq.0) then if (mype.eq.0) then call slicexy0(arrayxy,inr) else call slicexyk(arrayxy) end if call mybarrier() else #if(NETCDFO == 2) #if (IMRSB == 0) call pnet_out_chunk('zs ','yzslc.nc',13,1,1,1,ifrayz,zs) #else call pnet_out_chunk('zs ','yzslc.nc',13,1,1,1,ifrayz,zsib) #endif #endif endif ! -------- ! write zh ! -------- C do i=1,np C do j=1,mp C arrayxy(i,j)=zh(i,j) C enddo C enddo C if (mype.eq.0) then C call slicexy0(arrayxy,inr) C else C call slicexyk(arrayxy) C end if c call mybarrier() do isl=1,nsl if(ismode.eq.0) then if(iuvsyz.eq.1) call writeslyz(u ,zcr,inz,iindx(isl),1,inr) if(ivvsyz.eq.1) call writeslyz(v ,zcr,inz,iindx(isl),2,inr) if(iwvsyz.eq.1) call writeslyz(w ,zcr,inz,iindx(isl),3,inr) if(ioxsyz.eq.1) call writeslyz(ox ,zcr,inz,iindx(isl),4,inr) if(ioysyz.eq.1) call writeslyz(oy ,zcr,inz,iindx(isl),5,inr) if(iozsyz.eq.1) call writeslyz(oz ,zcr,inz,iindx(isl),6,inr) if(ithsyz.eq.1) call writeslyz(th ,zcr,inz,iindx(isl),7,inr) if(iprsyz.eq.1) call writeslyz(p ,zcr,inz,iindx(isl),8,inr) if(irhsyz.eq.1) call writeslyz(rho,zcr,inz,iindx(isl),9,inr) if(ikesyz.eq.1) call writeslyz(tke,zcr,inz,iindx(isl),10,inr) else #if(NETCDFO == 2) if(iuvsyz.eq.1) call pnet_out_chunk . ('u_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,u) if(ivvsyz.eq.1) call pnet_out_chunk . ('v_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,v) if(iwvsyz.eq.1) call pnet_out_chunk . ('w_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,w) if(ioxsyz.eq.1) call pnet_out_chunk . ('ox_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,ox) if(ioysyz.eq.1) call pnet_out_chunk . ('oy_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,oy) if(iozsyz.eq.1) call pnet_out_chunk . ('oz_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,oz) if(ithsyz.eq.1) call pnet_out_chunk . ('th_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,th) if(iprsyz.eq.1) call pnet_out_chunk . ('pr_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,p) if(irhsyz.eq.1) call pnet_out_chunk . ('rh_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,rho) if(ikesyz.eq.1) call pnet_out_chunk . ('ke_yzcross','yzslc.nc',12,iindx(isl),1,1,ifrayz,tke) #endif cTo add more variables, just copy and edit out_chunk call endif !ismode if(ichsyz.eq.1 .and. lch.gt.1) then do ispc=1,nspc ifl=20+ispc if(ismode.eq.0) then call writeslyz(chm(1-ih,1-ih,1,ispc),zcr,inz,iindx(isl),ifl,inr) else #if(NETCDFO == 2) if(ich.lt.10) write(chname,'(a,i1)') 'chmsp_0',ich if(ich.ge.10) write(chname,'(a,i2)') 'chmsp_',ich call pnet_out_chunk .(chname,'yzslc.nc',12,iindx(isl),1,1,ifrayz,chm(1-ih,1-ih,1,ispc)) #endif endif enddo endif if(lms.gt.1) then if(ismode.eq.0) then if(iqvsyz.eq.1) call writeslyz(qv ,zcr,inz,iindx(isl),12,inr) if(iqcsyz.eq.1) call writeslyz(qc ,zcr,inz,iindx(isl),13,inr) if(iqrsyz.eq.1) call writeslyz(qr ,zcr,inz,iindx(isl),14,inr) else #if(NETCDFO == 2) if(iqvsyz.eq.1) call pnet_out_chunk . ('qvcrosyz','yzslc.nc',12,iindx(isl),1,1,ifrayz,qv) if(iqcsyz.eq.1) call pnet_out_chunk . ('qccrosyz','yzslc.nc',12,iindx(isl),1,1,ifrayz,qc) if(iqrsyz.eq.1) call pnet_out_chunk . ('qrcrosyz','yzslc.nc',12,iindx(isl),1,1,ifrayz,qr) #endif endif !ismode endif if(lic.gt.1) then if(ismode.eq.0) then if(iqasyz.eq.1) call writeslyz(qia,zcr,inz,iindx(isl),15,inr) if(iqbsyz.eq.1) call writeslyz(qib,zcr,inz,iindx(isl),16,inr) else #if(NETCDFO == 2) if(iqasyz.eq.1) call pnet_out_chunk . ('qiacroyz','yzslc.nc',12,iindx(isl),1,1,ifrayz,qia) if(iqbsyz.eq.1) call pnet_out_chunk . ('qibcroyz','yzslc.nc',12,iindx(isl),1,1,ifrayz,qib) #endif endif !ismode endif enddo if(mype.eq.0) print *,'WRITE YZ SLICE OUTPUT DONE' endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! horixontal xy slices ! --------------------------------- if(ixy.eq.1) then inr=33 inz=inzxy if(mype.eq.0) print *,'WRITE XY SLICE OUTPUT',iflg,kindx if(ismode.eq.0) then if(mype.eq.0) write(inr) kindx if(mype.eq.0) write(inr) inz if(mype.eq.0) write(inr) iflg,stime else #if(NETCDFO == 2) if(iflg.gt.0) then ! advance frame number ier = nfmpi_open( MPI_COMM_EULAG,'xyslc.nc', . NF_READ, MPI_INFO_NULL, nfhdxy) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xyslc open stat ', . nfmpi_strerror(ier) ier=nfmpi_inq_unlimdim(nfhdxy,ihnd) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xyslc inq unlim dim ',nfmpi_strerror(ier) ier=nfmpi_inq_dimlen(nfhdxy,ihnd,ifrmask) if((mype.eq.0.and.iprint.eq.1).or.(iprint.eq.0.and.ier.ne.0)) . print *,'PNCDF slice xyslc inq dimlen ',nfmpi_strerror(ier) ifraxy=ifrmask+1 ier=nfmpi_close(nfhdxy) else ifraxy=0 endif #endif endif ! -------- ! write zs ! -------- if(ismode.eq.0) then if (mype.eq.0) then call slicexy0(arrayxy,inr) else call slicexyk(arrayxy) end if call mybarrier() else #if(NETCDFO == 2) #if (IMRSB == 0) call pnet_out_chunk('zs ','xyslc.nc',13,1,1,1,ifraxy,zs) #else call pnet_out_chunk('zs ','xyslc.nc',13,1,1,1,ifraxy,zsib) #endif #endif endif !ismode ! -------- ! write zh ! -------- C do i=1,np C do j=1,mp C arrayxy(i,j)=zh(i,j) C enddo C enddo C if (mype.eq.0) then C call slicexy0(arrayxy,inr) C else C call slicexyk(arrayxy) C end if c call mybarrier() do ksl=1,lsl if(ismode.eq.0) then if(iuvsxy.eq.1) call writeslxy(u ,zcr,inz,kindx(ksl),1,inr) if(ivvsxy.eq.1) call writeslxy(v ,zcr,inz,kindx(ksl),2,inr) if(iwvsxy.eq.1) call writeslxy(w ,zcr,inz,kindx(ksl),3,inr) if(ioxsxy.eq.1) call writeslxy(ox ,zcr,inz,kindx(ksl),4,inr) if(ioysxy.eq.1) call writeslxy(oy ,zcr,inz,kindx(ksl),5,inr) if(iozsxy.eq.1) call writeslxy(oz ,zcr,inz,kindx(ksl),6,inr) if(ithsxy.eq.1) call writeslxy(th ,zcr,inz,kindx(ksl),7,inr) if(iprsxy.eq.1) call writeslxy(p ,zcr,inz,kindx(ksl),8,inr) if(irhsxy.eq.1) call writeslxy(rho,zcr,inz,kindx(ksl),9,inr) if(ikesxy.eq.1) call writeslxy(tke,zcr,inz,kindx(ksl),10,inr) else #if(NETCDFO == 2) if(iuvsxy.eq.1) call pnet_out_chunk . ('u_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,u) if(ivvsxy.eq.1) call pnet_out_chunk . ('v_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,v) if(iwvsxy.eq.1) call pnet_out_chunk . ('w_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,w) if(ioxsxy.eq.1) call pnet_out_chunk . ('ox_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,ox) if(ioysxy.eq.1) call pnet_out_chunk . ('oy_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,oy) if(iozsxy.eq.1) call pnet_out_chunk . ('oz_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,oz) if(ithsxy.eq.1) call pnet_out_chunk . ('th_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,th) if(iprsxy.eq.1) call pnet_out_chunk . ('pr_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,p) if(irhsxy.eq.1) call pnet_out_chunk . ('rh_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,rho) if(ikesxy.eq.1) call pnet_out_chunk . ('ke_xycross','xyslc.nc',10,1,1,kindx(ksl),ifraxy,tke) #endif cTo add more variables, just copy and edit out_chunk call endif !ismode if(ichsxy.eq.1 .and. lch.gt.1) then do ispc=1,nspc ifl=20+ispc if(ismode.eq.0) then call writeslxy(chm(1-ih,1-ih,1,ispc),zcr,inz,kindx(ksl),ifl,inr) else #if(NETCDFO == 2) if(ich.lt.10) write(chname,'(a,i1)') 'chmsp_0',ich if(ich.ge.10) write(chname,'(a,i2)') 'chmsp_',ich call pnet_out_chunk .(chname,'xyslc.nc',10,1,1,kindx(ksl),ifraxy,chm(1-ih,1-ih,1,ispc)) #endif endif !ismode enddo endif !lch if(lms.gt.1) then if(ismode.eq.0) then if(iqvsxy.eq.1) call writeslxy(qv ,zcr,inz,kindx(ksl),12,inr) if(iqcsxy.eq.1) call writeslxy(qc ,zcr,inz,kindx(ksl),13,inr) if(iqrsxy.eq.1) call writeslxy(qr ,zcr,inz,kindx(ksl),14,inr) else #if(NETCDFO == 2) if(iqvsxy.eq.1) call pnet_out_chunk . ('qv_crosxy','xyslc.nc',10,1,1,kindx(ksl),0,qv) if(iqcsxy.eq.1) call pnet_out_chunk . ('qc_crosxy','xyslc.nc',10,1,1,kindx(ksl),0,qc) if(iqrsxy.eq.1) call pnet_out_chunk . ('qr_crosxy','xyslc.nc',10,1,1,kindx(ksl),0,qr) #endif endif !ismode endif !lms if(lic.gt.1) then if(ismode.eq.0) then if(iqasxy.eq.1) call writeslxy(qia,zcr,inz,kindx(ksl),15,inr) if(iqbsxy.eq.1) call writeslxy(qib,zcr,inz,kindx(ksl),16,inr) else #if(NETCDFO == 2) if(iqasxy.eq.1) call pnet_out_chunk . ('qia_crosxy','xyslc.nc',10,1,1,kindx(ksl),0,qia) if(iqbsxy.eq.1) call pnet_out_chunk . ('qib_crosxy','xyslc.nc',10,1,1,kindx(ksl),0,qib) #endif endif !ismode endif !lic enddo if(mype.eq.0) print *,'WRITE XY SLICE OUTPUT DONE' endif return end !------------------------------------------------------------- subroutine writeslxz(f,zcr,inz,jslice,iflg,inr) include "param.nml" include "msg.inc" dimension f(1-ih:np+ih,1-ih:mp+ih,l) dimension arrayxz(np,l),zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 icomp=0 do j=1,mp ja=(mpos-1)*mp + j if(ja.eq.jslice) then icomp=1 jloc=j endif enddo if(icomp.eq.1) then if(inz.eq.1) then do k=l,1,-1 do i=1,np zbr=(zcr(k)-zs(i,jloc))*gi(i,jloc) brk=zbr*dzi+1. k2=min0(l, nint(brk+.5)) k1=k2-1 fz=brk-float(k1) if (k2.ge.2) then arrayxz(i,k)=f(i,jloc,k1)+(f(i,jloc,k2)-f(i,jloc,k1))*fz else arrayxz(i,k)=f(i,jloc,k2) endif enddo enddo else do k=1,l do i=1,np arrayxz(i,k)=f(i,jloc,k) enddo enddo endif else do k=1,l do i=1,np arrayxz(i,k)=0. enddo enddo endif if (mype.eq.0) then call slicexz0(arrayxz,icomp,inr) else call slicexzk(arrayxz,icomp) end if call mybarrier() return end subroutine slicexz0(arrayxz,icomp,inr) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif dimension arrayxz(np,l) dimension slicexz(n,l) common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz if(icomp.eq.1) then do k=1,l do i=1,np slicexz(i,k)=arrayxz(i,k) end do end do endif #if (PARALLEL > 0) nlp=np*l cccccccccccccccccccccccccccccccccccccc c get data from other processors cccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, c getting their data and transferring it cccccccccccccccccccccccccccccccccccccccccccc do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(fcompxz,fcompxz,1 ,iproc) call shmem_get32(tmpxz,tmpxz,nlp,iproc) #endif #if (SGI_O2K == 2) call shmem_get64(fcompxz,fcompxz,1 ,iproc) call shmem_get64(tmpxz,tmpxz,nlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_get(fcompxz,fcompxz,1 ,iproc) call shmem_get(tmpxz,tmpxz,nlp,iproc) #endif #else call pvmfrecv(iproc, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 in writeit0' stop end if call pvmfunpack(REAL8, fcompxz, 1 , 1, ierr) call pvmfunpack(REAL8, tmpxz, nlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 in iowrite' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(fcompxz, 1 , DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) call MPI_Recv(tmpxz, nlp, DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in iowrite' stop end if #endif kcomp=int(fcompxz) if(kcomp.eq.1) then npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 do k=1,l do i=1,np slicexz(((npos1-1)*np+i),k)=tmpxz(i,k) end do end do endif end do cccccccccccccccccccccccc c endif (PARALLEL > 0) cccccccccccccccccccccccc #endif write(inr) slicexz return end subroutine slicexzk(arrayxz,icomp) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz dimension arrayxz(np,l) #if (PARALLEL > 0) nlp=np*l cccccccccccccccccccccccccccccccccccc c send data to processor 0 cccccccccccccccccccccccccccccccccccc #if (PARALLEL == 1) #if (PVM_IO == 0) do k=1,l do i=1,np tmpxz(i,k)=arrayxz(i,k) end do end do call mybarrier() #else fcompxz=float(icomp) call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in writeitk' stop end if call pvmfpack(REAL8, fcompxz, 1 , 1, ierr) call pvmfpack(REAL8, arrayxz, nlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in writeitk' stop end if call pvmfsend(0,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in writeitk' stop end if #endif #endif #if (PARALLEL == 2) fcompxz=float(icomp) call MPI_Send(fcompxz, 1 , DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) call MPI_Send(arrayxz, nlp, DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in writeitk' stop end if #endif #endif return end !------------------------------------------------------------- subroutine writeslyz(f,zcr,inz,islice,iflg,inr) include "param.nml" include "msg.inc" dimension f(1-ih:np+ih,1-ih:mp+ih,l) dimension arrayyz(mp,l),zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 icomp=0 do i=1,np ia=(npos-1)*np + i if(ia.eq.islice) then icomp=1 iloc=i endif enddo if(icomp.eq.1) then if(inz.eq.1) then do k=l,1,-1 do j=1,mp zbr=(zcr(k)-zs(iloc,j))*gi(iloc,j) brk=zbr*dzi+1. k2=min0(l, nint(brk+.5)) k1=k2-1 fz=brk-float(k1) if (k2.ge.2) then arrayyz(j,k)=f(iloc,j,k1)+(f(iloc,j,k2)-f(iloc,j,k1))*fz else arrayyz(j,k)=f(iloc,j,k2) endif enddo enddo else do k=1,l do j=1,mp arrayyz(j,k)=f(iloc,j,k) enddo enddo endif else do k=1,l do j=1,mp arrayyz(j,k)=0. enddo enddo endif if (mype.eq.0) then call sliceyz0(arrayyz,icomp,inr) else call sliceyzk(arrayyz,icomp) end if call mybarrier() return end subroutine sliceyz0(arrayyz,icomp,inr) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz dimension arrayyz(mp,l) dimension sliceyz(m,l) if(icomp.eq.1) then do k=1,l do j=1,mp sliceyz(j,k)=arrayyz(j,k) end do end do endif #if (PARALLEL > 0) mlp=mp*l cccccccccccccccccccccccccccccccccccccc c get data from other processors cccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, c getting their data and transferring it cccccccccccccccccccccccccccccccccccccccccccc do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(fcompyz,fcompyz,1 ,iproc) call shmem_get32(tmpyz,tmpyz,mlp,iproc) #endif #if (SGI_O2K == 2) call shmem_get64(fcompyz,fcompyz,1 ,iproc) call shmem_get64(tmpyz,tmpyz,mlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_get(fcompyz,fcompyz,1 ,iproc) call shmem_get(tmpyz,tmpyz,mlp,iproc) #endif #else call pvmfrecv(iproc, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 in writeit0' stop end if call pvmfunpack(REAL8, fcompyz, 1 , 1, ierr) call pvmfunpack(REAL8, tmpyz, mlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 in iowrite' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(fcompyz, 1 , DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) call MPI_Recv(tmpyz, mlp, DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in iowrite' stop end if #endif kcomp=int(fcompyz) if(kcomp.eq.1) then mpos1 = iproc/nprocx + 1 do k=1,l do j=1,mp sliceyz(((mpos1-1)*mp+j),k)=tmpyz(j,k) end do end do endif end do cccccccccccccccccccccccc c endif (PARALLEL > 0) cccccccccccccccccccccccc #endif write(inr) sliceyz return end subroutine sliceyzk(arrayyz,icomp) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz dimension arrayyz(mp,l) #if (PARALLEL > 0) mlp=mp*l cccccccccccccccccccccccccccccccccccc c send data to processor 0 cccccccccccccccccccccccccccccccccccc #if (PARALLEL == 1) #if (PVM_IO == 0) do k=1,l do j=1,mp tmpyz(j,k)=arrayyz(j,k) end do end do call mybarrier() #else fcompyz=float(icomp) call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in writeitk' stop end if call pvmfpack(REAL8, fcompyz, 1 , 1, ierr) call pvmfpack(REAL8, arrayyz, mlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in writeitk' stop end if call pvmfsend(0,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in writeitk' stop end if #endif #endif #if (PARALLEL == 2) fcompyz=float(icomp) call MPI_Send(fcompyz, 1 , DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) call MPI_Send(arrayyz, mlp, DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in writeitk' stop end if #endif #endif return end !------------------------------------------------------------- subroutine writeslxy(f,zcr,inz,kslice,iflg,inr) include "param.nml" include "msg.inc" dimension f(1-ih:np+ih,1-ih:mp+ih,l) dimension arrayxy(np,mp),zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 if(inz.eq.1) then do k=l,1,-1 if (k.eq.kslice) then do j=1,mp do i=1,np zbr=(zcr(k)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. k2=min0(l, nint(brk+.5)) k1=k2-1 fz=brk-float(k1) if (k2.ge.2) then arrayxy(i,j)=f(i,j,k1)+(f(i,j,k2)-f(i,j,k1))*fz else arrayxy(i,j)=f(i,j,k2) endif enddo enddo endif enddo else do j=1,mp do i=1,np arrayxy(i,j)=f(i,j,kslice) enddo enddo endif if (mype.eq.0) then call slicexy0(arrayxy,inr) else call slicexyk(arrayxy) end if call mybarrier() return end subroutine slicexy0(arrayxy,inr) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz dimension arrayxy(np,mp) dimension slicexy(n,m) do j=1,mp do i=1,np slicexy(i,j)=arrayxy(i,j) end do end do #if (PARALLEL > 0) nmp=np*mp cccccccccccccccccccccccccccccccccccccc c get data from other processors cccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, c getting their data and transferring it cccccccccccccccccccccccccccccccccccccccccccc do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(tmpxy,tmpxy,nmp,iproc) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxy,tmpxy,nmp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_get(tmpxy,tmpxy,nmp,iproc) #endif #else call pvmfrecv(iproc, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 in writeit0' stop end if call pvmfunpack(REAL8, tmpxy, nmp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 in iowrite' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(tmpxy, nmp, DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in iowrite' stop end if #endif npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 do j=1,mp do i=1,np slicexy(((npos1-1)*np+i),((mpos1-1)*mp+j))=tmpxy(i,j) end do end do end do cccccccccccccccccccccccc c endif (PARALLEL > 0) cccccccccccccccccccccccc #endif write(inr) slicexy return end subroutine slicexyk(arrayxy) c c This subroutine slices array and writes the data to the history file. c include "param.nml" include "msg.inc" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif common/blockslicexy/tmpxy(np,mp) common/blockslicexz/tmpxz(np,l),fcompxz common/blocksliceyz/tmpyz(mp,l),fcompyz dimension arrayxy(np,mp) #if (PARALLEL > 0) nmp=np*mp cccccccccccccccccccccccccccccccccccc c send data to processor 0 cccccccccccccccccccccccccccccccccccc #if (PARALLEL == 1) #if (PVM_IO == 0) do j=1,mp do i=1,np tmpxy(i,j)=arrayxy(i,j) end do end do call mybarrier() #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in writeitk' stop end if call pvmfpack(REAL8, arrayxy, nmp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in writeitk' stop end if call pvmfsend(0,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in writeitk' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Send(arrayxy, nmp, DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in writeitk' stop end if #endif #endif return end subroutine iowrsh(u,v,w,t,p,bx,by,bz) !mod iosh include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) if (mype.eq.0) then call iowritesh0(u,v,w,t,p,bx,by,bz) else call iowriteshk(u,v,w,t,p,bx,by,bz) end if return end c mod-restart subroutine ioread(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,icomm) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) if (mype.eq.0) then c mod-restart call ioread0(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,icomm) else c mod-restart call ioreadk(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,icomm) end if return end c mod-restart subroutine iowrite(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,hise, . hischm,epp1,ihis) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) c real hise(nthv,2),hischm(nthv,4) real hise(nthv,2),hischm(nthv,nspc) if (mype.eq.0) then c mod-restart call iowrite0(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm, . bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,hise, . hischm,epp1,ihis) else c mod-restart call iowritek(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm, . bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke) end if return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine ioreadsh0(u,v,w,t,p,bx,by,bz,icomm) !mod iosh c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' #include "tempr.def" dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif inr=12 ! read from fort.12 ifullarr=1 call readit0(u,temp,ifullarr,icomm,inr) call mybarrier() call readit0(v,temp,ifullarr,icomm,inr) call mybarrier() call readit0(w,temp,ifullarr,icomm,inr) call mybarrier() call readit0(t,temp,ifullarr,icomm,inr) call mybarrier() call readit0(p,temp,ifullarr,icomm,inr) call mybarrier() if(nmhd.eq.n) then call readit0(bx,temp,1,icomm,inr) call mybarrier() call readit0(by,temp,1,icomm,inr) call mybarrier() call readit0(bz,temp,1,icomm,inr) call mybarrier() else call readit0(bx,temp,0,icomm,inr) call mybarrier() call readit0(by,temp,0,icomm,inr) call mybarrier() call readit0(bz,temp,0,icomm,inr) call mybarrier() endif return end subroutine ioreadshk(u,v,w,t,p,bx,by,bz,icomm) !mod iosh c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call readitk(u,ifullarr,icomm) call mybarrier() call readitk(v,ifullarr,icomm) call mybarrier() call readitk(w,ifullarr,icomm) call mybarrier() call readitk(t,ifullarr,icomm) call mybarrier() call readitk(p,ifullarr,icomm) call mybarrier() if(nmhd.eq.n) then call readitk(bx,1,icomm) call mybarrier() call readitk(by,1,icomm) call mybarrier() call readitk(bz,1,icomm) call mybarrier() else call readitk(bx,0,icomm) call mybarrier() call readitk(by,0,icomm) call mybarrier() call readitk(bz,0,icomm) call mybarrier() endif return end subroutine iowritesh0(u,v,w,t,p,bx,by,bz) !mod iosh c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' #include "tempw.def" common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) real hise(nthv,2) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif tempval=time inr=11 ! write to fort.11 ifullarr=1 call writeit0(u,temp,ifullarr,inr) call mybarrier() call writeit0(v,temp,ifullarr,inr) call mybarrier() call writeit0(w,temp,ifullarr,inr) call mybarrier() call writeit0(t,temp,ifullarr,inr) call mybarrier() call writeit0(p,temp,ifullarr,inr) call mybarrier() if(nmhd.eq.n) then call writeit0(bx,temp,1,inr) call mybarrier() call writeit0(by,temp,1,inr) call mybarrier() call writeit0(bz,temp,1,inr) call mybarrier() endif return end subroutine iowriteshk(u,v,w,t,p,bx,by,bz) !mod iosh c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . t(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call writeitk(u,ifullarr) call mybarrier() call writeitk(v,ifullarr) call mybarrier() call writeitk(w,ifullarr) call mybarrier() call writeitk(t,ifullarr) call mybarrier() call writeitk(p,ifullarr) call mybarrier() if(nmhd.eq.n) then call writeitk(bx,1) call mybarrier() call writeitk(by,1) call mybarrier() call writeitk(bz,1) call mybarrier() endif return end c mod-restart subroutine ioread0(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,icomm) c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' #include "tempr.def" dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif inr=10 ! read from fort.10 ifullarr=1 call readit0(u,temp,ifullarr,icomm,inr) call mybarrier() call readit0(v,temp,ifullarr,icomm,inr) call mybarrier() call readit0(w,temp,ifullarr,icomm,inr) call mybarrier() call readit0(ox,temp,ifullarr,icomm,inr) call mybarrier() call readit0(oy,temp,ifullarr,icomm,inr) call mybarrier() call readit0(oz,temp,ifullarr,icomm,inr) call mybarrier() c mod-restart call readit0(ox2,temp,ifullarr,icomm,inr) call mybarrier() call readit0(oy2,temp,ifullarr,icomm,inr) call mybarrier() call readit0(oz2,temp,ifullarr,icomm,inr) call mybarrier() call readit0(th,temp,ifullarr,icomm,inr) call mybarrier() call readit0(p,temp,ifullarr,icomm,inr) call mybarrier() call readit0(fx,temp,ifullarr,icomm,inr) call mybarrier() call readit0(fy,temp,ifullarr,icomm,inr) call mybarrier() call readit0(fz,temp,ifullarr,icomm,inr) call mybarrier() call readit0(ft,temp,ifullarr,icomm,inr) call mybarrier() if (nts.eq.n) then call readit0(fox,temp,1,icomm,inr) call mybarrier() call readit0(foy,temp,1,icomm,inr) call mybarrier() call readit0(foz,temp,1,icomm,inr) call mybarrier() else call readit0(fox,temp,0,icomm,inr) call mybarrier() call readit0(foy,temp,0,icomm,inr) call mybarrier() call readit0(foz,temp,0,icomm,inr) call mybarrier() end if if(nmhd.eq.n) then call readit0(pm,temp,1,icomm,inr) call mybarrier() call readit0(bx,temp,1,icomm,inr) call mybarrier() call readit0(by,temp,1,icomm,inr) call mybarrier() call readit0(bz,temp,1,icomm,inr) call mybarrier() call readit0(fbx,temp,1,icomm,inr) call mybarrier() call readit0(fby,temp,1,icomm,inr) call mybarrier() call readit0(fbz,temp,1,icomm,inr) call mybarrier() c mod-restart call readit0(bx1,temp,1,icomm,inr) call mybarrier() call readit0(by1,temp,1,icomm,inr) call mybarrier() call readit0(bz1,temp,1,icomm,inr) call mybarrier() call readit0(bxe,temp,1,icomm,inr) call mybarrier() call readit0(bye,temp,1,icomm,inr) call mybarrier() call readit0(bze,temp,1,icomm,inr) call mybarrier() else call readit0(pm,temp,0,icomm,inr) call mybarrier() call readit0(bx,temp,0,icomm,inr) call mybarrier() call readit0(by,temp,0,icomm,inr) call mybarrier() call readit0(bz,temp,0,icomm,inr) call mybarrier() call readit0(fbx,temp,0,icomm,inr) call mybarrier() call readit0(fby,temp,0,icomm,inr) call mybarrier() call readit0(fbz,temp,0,icomm,inr) call mybarrier() c mod-restart call readit0(bx1,temp,0,icomm,inr) call mybarrier() call readit0(by1,temp,0,icomm,inr) call mybarrier() call readit0(bz1,temp,0,icomm,inr) call mybarrier() call readit0(bxe,temp,0,icomm,inr) call mybarrier() call readit0(bye,temp,0,icomm,inr) call mybarrier() call readit0(bze,temp,0,icomm,inr) call mybarrier() end if if (nms.eq.n) then call readit0(qv,temp,1,icomm,inr) call mybarrier() call readit0(qc,temp,1,icomm,inr) call mybarrier() call readit0(qr,temp,1,icomm,inr) call mybarrier() call readit0(fqv,temp,1,icomm,inr) call mybarrier() call readit0(fqc,temp,1,icomm,inr) call mybarrier() call readit0(fqr,temp,1,icomm,inr) call mybarrier() else call readit0(qv,temp,0,icomm,inr) call mybarrier() call readit0(qc,temp,0,icomm,inr) call mybarrier() call readit0(qr,temp,0,icomm,inr) call mybarrier() call readit0(fqv,temp,0,icomm,inr) call mybarrier() call readit0(fqc,temp,0,icomm,inr) call mybarrier() call readit0(fqr,temp,0,icomm,inr) call mybarrier() end if if (nicp.eq.n) then call readit0(qia,temp,1,icomm,inr) call mybarrier() call readit0(qib,temp,1,icomm,inr) call mybarrier() call readit0(fqia,temp,1,icomm,inr) call mybarrier() call readit0(fqib,temp,1,icomm,inr) call mybarrier() else call readit0(qia,temp,0,icomm,inr) call mybarrier() call readit0(qib,temp,0,icomm,inr) call mybarrier() call readit0(fqia,temp,0,icomm,inr) call mybarrier() call readit0(fqib,temp,0,icomm,inr) call mybarrier() end if if (nkv.eq.n) then call readit0(tke,temp,1,icomm,inr) call mybarrier() else call readit0(tke,temp,0,icomm,inr) call mybarrier() end if if (nke.eq.n) then call readit0(ftke,temp,1,icomm,inr) call mybarrier() else call readit0(ftke,temp,0,icomm,inr) call mybarrier() end if do jfil=1,nspc call readit0( chm(1-ih,1-ih,1,jfil),temp,ichm,icomm,inr) call mybarrier() enddo do jfil=1,nspc call readit0(fchm(1-ih,1-ih,1,jfil),temp,ichm,icomm,inr) call mybarrier() enddo return end c mod-restart subroutine ioreadk(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,icomm) c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call readitk(u,ifullarr,icomm) call mybarrier() call readitk(v,ifullarr,icomm) call mybarrier() call readitk(w,ifullarr,icomm) call mybarrier() call readitk(ox,ifullarr,icomm) call mybarrier() call readitk(oy,ifullarr,icomm) call mybarrier() call readitk(oz,ifullarr,icomm) call mybarrier() c mod-restart call readitk(ox2,ifullarr,icomm) call mybarrier() call readitk(oy2,ifullarr,icomm) call mybarrier() call readitk(oz2,ifullarr,icomm) call mybarrier() call readitk(th,ifullarr,icomm) call mybarrier() call readitk(p,ifullarr,icomm) call mybarrier() call readitk(fx,ifullarr,icomm) call mybarrier() call readitk(fy,ifullarr,icomm) call mybarrier() call readitk(fz,ifullarr,icomm) call mybarrier() call readitk(ft,ifullarr,icomm) call mybarrier() if (nts.eq.n) then call readitk(fox,1,icomm) call mybarrier() call readitk(foy,1,icomm) call mybarrier() call readitk(foz,1,icomm) call mybarrier() else call readitk(fox,0,icomm) call mybarrier() call readitk(foy,0,icomm) call mybarrier() call readitk(foz,0,icomm) call mybarrier() end if if(nmhd.eq.n) then call readitk(pm,1,icomm) call mybarrier() call readitk(bx,1,icomm) call mybarrier() call readitk(by,1,icomm) call mybarrier() call readitk(bz,1,icomm) call mybarrier() call readitk(fbx,1,icomm) call mybarrier() call readitk(fby,1,icomm) call mybarrier() call readitk(fbz,1,icomm) call mybarrier() c mod-restart call readitk(bx1,1,icomm) call mybarrier() call readitk(by1,1,icomm) call mybarrier() call readitk(bz1,1,icomm) call mybarrier() call readitk(bxe,1,icomm) call mybarrier() call readitk(bye,1,icomm) call mybarrier() call readitk(bze,1,icomm) call mybarrier() else call readitk(pm,0,icomm) call mybarrier() call readitk(bx,0,icomm) call mybarrier() call readitk(by,0,icomm) call mybarrier() call readitk(bz,0,icomm) call mybarrier() call readitk(fbx,0,icomm) call mybarrier() call readitk(fby,0,icomm) call mybarrier() call readitk(fbz,0,icomm) call mybarrier() c mod-restart call readitk(bx1,0,icomm) call mybarrier() call readitk(by1,0,icomm) call mybarrier() call readitk(bz1,0,icomm) call mybarrier() call readitk(bxe,0,icomm) call mybarrier() call readitk(bye,0,icomm) call mybarrier() call readitk(bze,0,icomm) call mybarrier() end if if (nms.eq.n) then call readitk(qv,1,icomm) call mybarrier() call readitk(qc,1,icomm) call mybarrier() call readitk(qr,1,icomm) call mybarrier() call readitk(fqv,1,icomm) call mybarrier() call readitk(fqc,1,icomm) call mybarrier() call readitk(fqr,1,icomm) call mybarrier() else call readitk(qv,0,icomm) call mybarrier() call readitk(qc,0,icomm) call mybarrier() call readitk(qr,0,icomm) call mybarrier() call readitk(fqv,0,icomm) call mybarrier() call readitk(fqc,0,icomm) call mybarrier() call readitk(fqr,0,icomm) call mybarrier() end if if (nicp.eq.n) then call readitk(qia,1,icomm) call mybarrier() call readitk(qib,1,icomm) call mybarrier() call readitk(fqia,1,icomm) call mybarrier() call readitk(fqib,1,icomm) call mybarrier() else call readitk(qia,0,icomm) call mybarrier() call readitk(qib,0,icomm) call mybarrier() call readitk(fqia,0,icomm) call mybarrier() call readitk(fqib,0,icomm) call mybarrier() end if if (nkv.eq.n) then call readitk(tke,1,icomm) call mybarrier() else call readitk(tke,0,icomm) call mybarrier() end if if (nke.eq.n) then call readitk(ftke,1,icomm) call mybarrier() else call readitk(ftke,0,icomm) call mybarrier() end if do jfil=1,nspc call readitk( chm(1-ih,1-ih,1,jfil),ichm,icomm) call mybarrier() enddo do jfil=1,nspc call readitk(fchm(1-ih,1-ih,1,jfil),ichm,icomm) call mybarrier() enddo return end subroutine iovelwrite0(u,v,w,inr) c c This subroutine writes velocity to the history file. c include 'param.nml' include 'msg.inc' #include "tempw.def" common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l) integer inr #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif tempval=time print *,'WRITE VELOCITY at: ',time c inr=19 ! write to fort.19 ifullarr=1 call writeit0(u,temp,ifullarr,inr) call mybarrier() call writeit0(v,temp,ifullarr,inr) call mybarrier() call writeit0(w,temp,ifullarr,inr) call mybarrier() return end subroutine iovelwritek(u,v,w) c c This subroutine writes velocity to the history file. c include 'param.nml' include 'msg.inc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif tempval=time ifullarr=1 call writeitk(u,ifullarr) call mybarrier() call writeitk(v,ifullarr) call mybarrier() call writeitk(w,ifullarr) call mybarrier() return end subroutine iovelread0(u,v,w,icomm,inr) c c This subroutine writes velocity to the history file. c include 'param.nml' include 'msg.inc' #include "tempr.def" dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call readit0(u,temp,ifullarr,icomm,inr) call mybarrier() call readit0(v,temp,ifullarr,icomm,inr) call mybarrier() call readit0(w,temp,ifullarr,icomm,inr) call mybarrier() return end subroutine iovelreadk(u,v,w,icomm) c c This subroutine writes velocity to the history file. c include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call readitk(u,ifullarr,icomm) call mybarrier() call readitk(v,ifullarr,icomm) call mybarrier() call readitk(w,ifullarr,icomm) call mybarrier() return end c mod-restart subroutine iowrite0(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke,hise, . hischm,epp1,ihis) c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' #include "tempw.def" common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) real hise(nthv,2),hischm(nthv,4) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif tempval=time inr=9 ! write to fort.10 ifullarr=1 call writeit0(u,temp,ifullarr,inr) call mybarrier() call writeit0(v,temp,ifullarr,inr) call mybarrier() call writeit0(w,temp,ifullarr,inr) call mybarrier() call writeit0(ox,temp,ifullarr,inr) call mybarrier() call writeit0(oy,temp,ifullarr,inr) call mybarrier() call writeit0(oz,temp,ifullarr,inr) call mybarrier() c mod-restart call writeit0(ox2,temp,ifullarr,inr) call mybarrier() call writeit0(oy2,temp,ifullarr,inr) call mybarrier() call writeit0(oz2,temp,ifullarr,inr) call mybarrier() call writeit0(th,temp,ifullarr,inr) call mybarrier() call writeit0(p,temp,ifullarr,inr) call mybarrier() call writeit0(fx,temp,ifullarr,inr) call mybarrier() call writeit0(fy,temp,ifullarr,inr) call mybarrier() call writeit0(fz,temp,ifullarr,inr) call mybarrier() call writeit0(ft,temp,ifullarr,inr) call mybarrier() if (nts.eq.n) then call writeit0(fox,temp,1,inr) call mybarrier() call writeit0(foy,temp,1,inr) call mybarrier() call writeit0(foz,temp,1,inr) call mybarrier() else call writeit0(fox,temp,0,inr) call mybarrier() call writeit0(foy,temp,0,inr) call mybarrier() call writeit0(foz,temp,0,inr) call mybarrier() end if if(nmhd.eq.n) then call writeit0(pm,temp,1,inr) call mybarrier() call writeit0(bx,temp,1,inr) call mybarrier() call writeit0(by,temp,1,inr) call mybarrier() call writeit0(bz,temp,1,inr) call mybarrier() call writeit0(fbx,temp,1,inr) call mybarrier() call writeit0(fby,temp,1,inr) call mybarrier() call writeit0(fbz,temp,1,inr) call mybarrier() c mod-restart call writeit0(bx1,temp,1,inr) call mybarrier() call writeit0(by1,temp,1,inr) call mybarrier() call writeit0(bz1,temp,1,inr) call mybarrier() call writeit0(bxe,temp,1,inr) call mybarrier() call writeit0(bye,temp,1,inr) call mybarrier() call writeit0(bze,temp,1,inr) call mybarrier() else call writeit0(pm,temp,0,inr) call mybarrier() call writeit0(bx,temp,0,inr) call mybarrier() call writeit0(by,temp,0,inr) call mybarrier() call writeit0(bz,temp,0,inr) call mybarrier() call writeit0(fbx,temp,0,inr) call mybarrier() call writeit0(fby,temp,0,inr) call mybarrier() call writeit0(fbz,temp,0,inr) call mybarrier() c mod-restart call writeit0(bx1,temp,0,inr) call mybarrier() call writeit0(by1,temp,0,inr) call mybarrier() call writeit0(bz1,temp,0,inr) call mybarrier() call writeit0(bxe,temp,0,inr) call mybarrier() call writeit0(bye,temp,0,inr) call mybarrier() call writeit0(bze,temp,0,inr) call mybarrier() end if if (nms.eq.n) then call writeit0(qv,temp,1,inr) call mybarrier() call writeit0(qc,temp,1,inr) call mybarrier() call writeit0(qr,temp,1,inr) call mybarrier() call writeit0(fqv,temp,1,inr) call mybarrier() call writeit0(fqc,temp,1,inr) call mybarrier() call writeit0(fqr,temp,1,inr) call mybarrier() else call writeit0(qv,temp,0,inr) call mybarrier() call writeit0(qc,temp,0,inr) call mybarrier() call writeit0(qr,temp,0,inr) call mybarrier() call writeit0(fqv,temp,0,inr) call mybarrier() call writeit0(fqc,temp,0,inr) call mybarrier() call writeit0(fqr,temp,0,inr) call mybarrier() end if if (nicp.eq.n) then call writeit0(qia,temp,1,inr) call mybarrier() call writeit0(qib,temp,1,inr) call mybarrier() call writeit0(fqia,temp,1,inr) call mybarrier() call writeit0(fqib,temp,1,inr) call mybarrier() else call writeit0(qia,temp,0,inr) call mybarrier() call writeit0(qib,temp,0,inr) call mybarrier() call writeit0(fqia,temp,0,inr) call mybarrier() call writeit0(fqib,temp,0,inr) call mybarrier() end if if (nkv.eq.n) then call writeit0(tke,temp,1,inr) call mybarrier() else call writeit0(tke,temp,0,inr) call mybarrier() end if if (nke.eq.n) then call writeit0(ftke,temp,1,inr) call mybarrier() else call writeit0(ftke,temp,0,inr) call mybarrier() end if do jfil=1,nspc call writeit0( chm(1-ih,1-ih,1,jfil),temp,ichm,inr) call mybarrier() enddo do jfil=1,nspc call writeit0(fchm(1-ih,1-ih,1,jfil),temp,ichm,inr) call mybarrier() enddo if (ihis.eq.1) write(14) hise,hischm return end c mod-restart subroutine iowritek(u,v,w,ox,oy,oz,ox2,oy2,oz2, . th,p,chm,fchm,fx,fy,fz,ft, . fox,foy,foz,pm,bx,by,bz,fbx,fby,fbz, . bx1,by1,bz1,bxe,bye,bze, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke) c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), c mod-restart . ox2(1-ih:np+ih,1-ih:mp+ih,l), . oy2(1-ih:np+ih,1-ih:mp+ih,l), . oz2(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension pm(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bx(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), c mod-restart . bx1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . by1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . bz1(1-ih:nmhdp+ih, 1-ih:mmhdp+ih, lmhd), . fbx(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fby(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . fbz(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc), . fchm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension bxe(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bye(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd), . bze(1-ih:nmhdp+ih,1-ih:mmhdp+ih,lmhd) #if (PARALLEL > 0) common/blocktemp/tmparray(np,mp,l),tempval #endif ifullarr=1 call writeitk(u,ifullarr) call mybarrier() call writeitk(v,ifullarr) call mybarrier() call writeitk(w,ifullarr) call mybarrier() call writeitk(ox,ifullarr) call mybarrier() call writeitk(oy,ifullarr) call mybarrier() call writeitk(oz,ifullarr) call mybarrier() c mod-restart call writeitk(ox2,ifullarr) call mybarrier() call writeitk(oy2,ifullarr) call mybarrier() call writeitk(oz2,ifullarr) call mybarrier() call writeitk(th,ifullarr) call mybarrier() call writeitk(p,ifullarr) call mybarrier() call writeitk(fx,ifullarr) call mybarrier() call writeitk(fy,ifullarr) call mybarrier() call writeitk(fz,ifullarr) call mybarrier() call writeitk(ft,ifullarr) call mybarrier() if (nts.eq.n) then call writeitk(fox,1) call mybarrier() call writeitk(foy,1) call mybarrier() call writeitk(foz,1) call mybarrier() else call writeitk(fox,0) call mybarrier() call writeitk(foy,0) call mybarrier() call writeitk(foz,0) call mybarrier() end if if (nmhd.eq.n) then call writeitk(pm,1) call mybarrier() call writeitk(bx,1) call mybarrier() call writeitk(by,1) call mybarrier() call writeitk(bz,1) call mybarrier() call writeitk(fbx,1) call mybarrier() call writeitk(fby,1) call mybarrier() call writeitk(fbz,1) call mybarrier() c mod-restart call writeitk(bx1,1) call mybarrier() call writeitk(by1,1) call mybarrier() call writeitk(bz1,1) call mybarrier() call writeitk(bxe,1) call mybarrier() call writeitk(bye,1) call mybarrier() call writeitk(bze,1) call mybarrier() else call writeitk(pm,0) call mybarrier() call writeitk(bx,0) call mybarrier() call writeitk(by,0) call mybarrier() call writeitk(bz,0) call mybarrier() call writeitk(fbx,0) call mybarrier() call writeitk(fby,0) call mybarrier() call writeitk(fbz,0) call mybarrier() c mod-restart call writeitk(bx1,0) call mybarrier() call writeitk(by1,0) call mybarrier() call writeitk(bz1,0) call mybarrier() call writeitk(bxe,0) call mybarrier() call writeitk(bye,0) call mybarrier() call writeitk(bze,0) call mybarrier() end if if (nms.eq.n) then call writeitk(qv,1) call mybarrier() call writeitk(qc,1) call mybarrier() call writeitk(qr,1) call mybarrier() call writeitk(fqv,1) call mybarrier() call writeitk(fqc,1) call mybarrier() call writeitk(fqr,1) call mybarrier() else call writeitk(qv,0) call mybarrier() call writeitk(qc,0) call mybarrier() call writeitk(qr,0) call mybarrier() call writeitk(fqv,0) call mybarrier() call writeitk(fqc,0) call mybarrier() call writeitk(fqr,0) call mybarrier() end if if (nicp.eq.n) then call writeitk(qia,1) call mybarrier() call writeitk(qib,1) call mybarrier() call writeitk(fqia,1) call mybarrier() call writeitk(fqib,1) call mybarrier() else call writeitk(qia,0) call mybarrier() call writeitk(qib,0) call mybarrier() call writeitk(fqia,0) call mybarrier() call writeitk(fqib,0) call mybarrier() end if if (nkv.eq.n) then call writeitk(tke,1) call mybarrier() else call writeitk(tke,0) call mybarrier() end if if (nke.eq.n) then call writeitk(ftke,1) call mybarrier() else call writeitk(ftke,0) call mybarrier() end if do jfil=1,nspc call writeitk( chm(1-ih,1-ih,1,jfil),ichm) call mybarrier() enddo do jfil=1,nspc call writeitk(fchm(1-ih,1-ih,1,jfil),ichm) call mybarrier() enddo return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (IORFLAG == 0) /* PE0 read serial array and reditribute it between other PEs */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine readit0(datarr,temp,ifullarr,icomm,inr) c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' #include "tempr.def" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common/blocktemp/tmparray(np,mp,l),tempval #endif dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) call readit0tape(temp,fval,ifullarr,inr,n,m) if (icomm.eq.1) then if (ifullarr.eq.1) then ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c transfer processor 0 data from big array to local array ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np datarr(i,j,k)=temp(i,j,k) end do end do end do #if (PARALLEL > 0) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, sending them their data ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc nmlp=np*mp*l do iproc=1,(nprocx*nprocy - 1) npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 do k=1,l do j=1,mp do i=1,np tmparray(i,j,k) = . temp(((npos1-1)*np + i), ((mpos1-1)*mp + j), k) end do end do end do cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_put32(tmparray,tmparray,nmlp,iproc) #endif #if (SGI_O2K == 2) call shmem_put64(tmparray,tmparray,nmlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_put(tmparray,tmparray,nmlp,iproc) #endif #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readit0' stop end if call pvmfpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readit0' stop end if call pvmfsend(iproc,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in readit0' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Send(tmparray, nmlp, DC_TYPE, iproc, 98, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc end do #endif /* (PARALLEL > 0) */ ccccccccccccccccccccccccccccccccccccccccc c read full array from tape file done ccccccccccccccccccccccccccccccccccccccccc else !ifullarr = 0 - degenerate array; read one value tempval=fval #if (PARALLEL > 0) ccccccccccccccccccccccccccccccccccccccccccccccc c send data from pe 0 to other processors ccccccccccccccccccccccccccccccccccccccccccccccc nmlp=1 #if (PARALLEL == 1) #if (PVM_IO == 0) call shmem_barrier_all() ! tempval is available in common block #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readit0' stop end if call pvmfpack(REAL8, tempval, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readit0' stop end if call pvmfsend(iproc,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in readit0' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Bcast(tempval,nmlp,DC_TYPE,0,MPI_COMM_EULAG,ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif #endif /* (PARALLEL > 0) */ ccccccccccccccccccccccccccccc c end of read one value ccccccccccccccccccccccccccccc end if !ifullarr end if !icomm = 1 return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #endif /* IORFLAG == 0 */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (IOWFLAG == 0) /* PE0 collect data to one big array + write it to the tape */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine writeit0(datarr,temp,ifullarr,inr) c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' #include "tempw.def" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif !mod check common/blocktemp/tmparray(np,mp,l),tempval dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) if (ifullarr.eq.1) then ccccccccccccccccccccccccccccccccccccccccccccc c transfer processor 0 data to big array ccccccccccccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np temp(i,j,k)=datarr(i,j,k) end do end do end do #if (PARALLEL > 0) /* get data from other processors */ cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, getting their data and transferring it cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc nmlp=np*mp*l do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(tmparray,tmparray,nmlp,iproc) #endif #if (SGI_O2K == 2) call shmem_get64(tmparray,tmparray,nmlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_get(tmparray,tmparray,nmlp,iproc) #endif #else call pvmfrecv(iproc, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 in writeit0' stop end if call pvmfunpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 in iowrite' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(tmparray, nmlp, DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in iowrite' stop end if #endif npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 do k=1,l do j=1,mp do i=1,np temp(((npos1-1)*np + i), ((mpos1-1)*mp + j), k)= . tmparray(i,j,k) end do end do end do end do cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors done cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #endif /* (PARALLEL > 0) */ else !ifullarr = 0 c fval=1.0 ! degenerate array; fval=tempval ! write out one value from PE = 0 end if if(inr.ge.0) + call writeit0tape(temp,fval,ifullarr,inr,n,m) return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine bridge_send(dataarr_eu, ind, iblock, rqst) c c this subroutine should be able to send all data into processor 0 of MPI_COMM_WORLD c include 'param.nml' include 'msg.inc' #if (PARALLEL>0) #include "msg.lnk" #include "msg.lnp" #endif integer iproc, lengi, ind integer, dimension(0:nprocx_frn-1)::rqst real temp dimension dataarr_eu( 1-ih:np+ih,1-ih:mp+ih,l) integer :: iblock !common/blocktemp/temparray(l,mp,np) real, dimension(l,mp,np) :: temparray c transfer data to a regular array, EULAG does it all the time !print *, 'EULAG - peer_frn', mype, peer_frn do iproc=0, nprocx_frn - 1 nmlp = np*mp*(xind_rng(iproc,2) - xind_rng(iproc, 1) + 1) !count for mpi_send if(iblock >=3) then call MPI_WAIT(rqst(iproc),status,ierr) print*, 'EULAG: NON_BLOCKING', mype, iblock, + status(MPI_SOURCE),status(MPI_TAG),status(MPI_ERROR) endif do k=xind_rng(iproc,1), xind_rng(iproc, 2) do j=1, mp do i=1, np temparray(k,j,i) = dataarr_eu(i,j,k) enddo enddo enddo ! print *,'EULAG - rank, peer, tag, leng', ! . mype,peer_frn+iproc, mype, nmlp if(iblock>=2) then call MPI_ISend(temparray(xind_rng(iproc,1): + xind_rng(iproc,2),:,:), + nmlp,DC_TYPE,peer_frn+iproc,mype,MPI_COMM_WORLD, + rqst(iproc),ierr) ! print*, 'EULAG: NON_BLOCKING', mype, rqst(iproc), iblock else call MPI_Send(temparray(xind_rng(iproc,1): + xind_rng(iproc,2),:,:), + nmlp,DC_TYPE,peer_frn+iproc,mype,MPI_COMM_WORLD,ierr) endif enddo if(ind.eq.1) . write(30+mype) temparray if(ind.eq.2) . write(40+mype) temparray if(ind.eq.3) . write(50+mype) temparray ! print *,'EULAG Finished send' call mybarrier() end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine bridge_velo_send(u,v,w) ! Just this 3 for now c c This subroutine will send the field/other variables to Pencil c include 'param.nml' include 'msg.inc' #if (PARALLEL>0) #include "msg.lnk" #endif dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l) integer,save::iblock=0 integer,save,dimension(0:nprocx_frn_max-1,3)::rqst double precision :: time0,time1, time2 c Need to be send in the sme order as the receiver if (mype.eq.0.and.iblock.eq.0) time0 = MPI_WTIME() if (mype.eq.0) time1 = MPI_WTIME() call bridge_send(w,3,iblock,rqst(:nprocx_frn-1,3)) call bridge_send(v,2,iblock,rqst(:nprocx_frn-1,2)) call bridge_send(u,1,iblock,rqst(:nprocx_frn-1,1)) if (mype.eq.0) then time2 = MPI_WTIME() print*,'EULAG walltime[min]tot', . iblock, (time2-time0)/60. endif iblock = iblock+1 print *, 'EULAG MIN MAX W', mype,minval(w(1:np,1:mp,:)), . maxval(w(1:np,1:mp,:)) print *, 'EULAG MIN MAX V', mype,minval(v(1:np,1:mp,:)), . maxval(v(1:np,1:mp,:)) print *, 'EULAG MIN MAX U', mype,minval(u(1:np,1:mp,:)), . maxval(u(1:np,1:mp,:)) print*, 'EULAG: successful', mype ! call MPI_BARRIER(MPI_COMM_WORLD, ierr) ! call MPI_FINALIZE(ierr) ! stop return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #endif /* IOWFLAG == 0 */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (IORFLAG == 1) /* Read arrays written sequentially, distribute them to PEs */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine readit0(datarr,temp,ifullarr,icomm,inr) c c This subroutine reads the data from the history file. c include 'param.nml' include 'msg.inc' #include "tempr.def" dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common/blocktemp/tmparray(np,mp,l),tempval nmlp=np*mp*l #endif if (ifullarr.eq.1) then do iproc=0,(nprcxa*nprcya - 1) call readit0tape(temp,fval,ifullarr,inr,npa,mpa) if (icomm.eq.1) then #if (PARALLEL == 0) npos1 = mod((iproc+nprcxa), nprcxa) + 1 mpos1 = iproc/nprcxa + 1 do k=1,l do j=1,mpa do i=1,npa datarr(((npos1-1)*npa+i),((mpos1-1)*mpa+j),k)=temp(i,j,k) end do end do end do #else if (iproc.eq.0) then do k=1,l do j=1,mpa do i=1,npa datarr(i,j,k)=temp(i,j,k) end do end do end do else cccccccccccccccccccccccccccccccccccccccccccccc c send small arrays for other processors cccccccccccccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np tmparray(i,j,k) = temp(i,j,k) end do end do end do #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_put32(tmparray,tmparray,nmlp,iproc) #endif #if (SGI_O2K == 2) call shmem_put64(tmparray,tmparray,nmlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_put(tmparray,tmparray,nmlp,iproc) #endif #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readit0' stop end if call pvmfpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readit0' stop end if call pvmfsend(iproc,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in readit0' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Send(tmparray, nmlp, DC_TYPE, iproc, 98, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif cccccccccccccccccccccccccccccccccccccccccccccc c send small arrays for other processors cccccccccccccccccccccccccccccccccccccccccccccc end if ! iproc #endif /* (PARALLEL > 0) */ end if ! icomm end do ! iproc else !ifullarr = 0 ! degenerate array; read one value call readit0tape(temp,fval,ifullarr,inr,np,mp) if (icomm.eq.1) then tempval=fval #if (PARALLEL > 0) ccccccccccccccccccccccccccccccccccccccccccccccc c send data from pe 0 to other processors ccccccccccccccccccccccccccccccccccccccccccccccc nmlp=1 #if (PARALLEL == 1) #if (PVM_IO == 0) call shmem_barrier_all() ! tempval is available in common block #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readit0' stop end if call pvmfpack(REAL8, tempval, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readit0' stop end if call pvmfsend(iproc,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in readit0' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Bcast(tempval,nmlp,DC_TYPE,0,MPI_COMM_EULAG,ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif #endif /* (PARALLEL > 0) */ ccccccccccccccccccccccccccccc c end of read one value ccccccccccccccccccccccccccccc end if !icomm = 1 end if !ifullarr return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #endif /* IORFLAG == 1 */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (IOWFLAG == 1) /* Collect arrays from PEs, write them sequentially to tape */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine writeit0(datarr,temp,ifullarr,inr) c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' #include "tempw.def" #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common/blocktemp/tmparray(np,mp,l),tempval #endif dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) if (ifullarr.eq.1) then do k=1,l do j=1,mp do i=1,np temp(i,j,k)=datarr(i,j,k) end do end do end do call writeit0tape(temp,fval,ifullarr,inr,np,mp) #if (PARALLEL > 0) /* get data from other processors */ cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, getting their data and write it to tape cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc nmlp=np*mp*l do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(tmparray,tmparray,nmlp,iproc) #endif #if (SGI_O2K == 2) call shmem_get64(tmparray,tmparray,nmlp,iproc) #endif #if (CRAYT3D == 1 || CRAYT3E == 1) call shmem_get(tmparray,tmparray,nmlp,iproc) #endif #else call pvmfrecv(iproc, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 in writeit0' stop end if call pvmfunpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 in iowrite' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(tmparray, nmlp, DC_TYPE, iproc, 99, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in iowrite' stop end if #endif do k=1,l do j=1,mp do i=1,np temp(i,j,k)= tmparray(i,j,k) end do end do end do call writeit0tape(temp,fval,ifullarr,inr,np,mp) end do cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors done cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #endif /* (PARALLEL > 0) */ else !ifullarr = 0 c fval=1.0 ! degenerate array; fval=tempval ! write out one value from PE = 0 call writeit0tape(temp,fval,ifullarr,inr,np,mp) end if return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #endif /* IOWFLAG == 1 */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine readitk(datarr,ifullarr,icomm) c c This subroutine collect data from PE0 on other PEs c include 'param.nml' include 'msg.inc' dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common/blocktemp/tmparray(np,mp,l),tempval if (icomm.eq.1) then if (ifullarr.eq.1) then ccccccccccccccccccccccccccccccc c receive array from pe 0 ccccccccccccccccccccccccccccccc nmlp=np*mp*l #if (PARALLEL == 1) #if (PVM_IO == 0) call mybarrier() #else call pvmfrecv(0, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readitk' stop end if call pvmfunpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readitk' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Recv(tmparray, nmlp, DC_TYPE, 0, 98, . MPI_COMM_EULAG, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readitk' stop end if #endif cccccccccccccccccccccccccccccccccccccccccccccc c transfer received array to local array cccccccccccccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np datarr(i,j,k)=tmparray(i,j,k) end do end do end do cccccccccccccccccccccccccccccccccccccc c end of receive array from pe 0 cccccccccccccccccccccccccccccccccccccc else !ifullarr = 0 ccccccccccccccccccccccccccccccc c receive value from pe 0 ccccccccccccccccccccccccccccccc nmlp=1 #if (PARALLEL == 1) #if (PVM_IO == 0) #if (SGI_O2K == 1) call shmem_get32(tempval,tempval,1,0) #endif #if (SGI_O2K == 2) call shmem_get64(tempval,tempval,1,0) #endif #if (SGI_O2K == 0) call shmem_get(tempval,tempval,1,0) #endif call shmem_barrier_all() #else call pvmfrecv(0, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in readitk' stop end if call pvmfunpack(REAL8, tempval, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in readitk' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Bcast(tempval,nmlp,DC_TYPE,0,MPI_COMM_EULAG,ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readitk' stop end if #endif cccccccccccccccccccccccccccccc c end of receive one value cccccccccccccccccccccccccccccc endif !ifullarr endif !icomm = 1 #endif return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine writeitk(datarr,ifullarr) c c This subroutine send data to PE0 to write them to the history file c include 'param.nml' include 'msg.inc' dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common/blocktemp/tmparray(np,mp,l),tempval nmlp=np*mp*l if (ifullarr.eq.1) then cccccccccccccccccccccccccccccccccccc c transfer data to regular array cccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np tmparray(i,j,k)=datarr(i,j,k) end do end do end do ccccccccccccccccccccccccccccccc c send data to processor 0 ccccccccccccccccccccccccccccccc #if (PARALLEL == 1) #if (PVM_IO == 0) call mybarrier() #else call pvmfinitsend(PVMRAW, ierr) if (ierr.lt.0) then write(*,*)'***pvm1 error in writeitk' stop end if call pvmfpack(REAL8, tmparray, nmlp, 1, ierr) if (ierr.lt.0) then write(*,*)'***pvm2 error in writeitk' stop end if call pvmfsend(0,1,ierr) if (ierr.lt.0) then write(*,*)'***pvm3 error in writeitk' stop end if #endif #endif #if (PARALLEL == 2) call MPI_Send(tmparray, nmlp, DC_TYPE, 0, 99, . MPI_COMM_EULAG, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in writeitk' stop end if #endif end if #endif return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine readit0tape(temp,fval,ifullarr,inr,n1,m1) c c This subroutine reads the data from the history file by PE0 c include 'param.nml' include 'msg.inc' #if (HP > 0 || SGI_O2K > 1) integer CRAYREAD #endif common /hpcray/ ifcw,ifcr,ioptw,ioptr #if (IORTAPE == 3) real*8 temp(n1,m1,l) real*8 fval #endif #if (IORTAPE == 2) real*4 temp(n1,m1,l) real*4 fval #endif #if (IORTAPE == 1) dimension temp(n1,m1,l) real fval #endif if (ifullarr.eq.1) then cccccccccccccccccccccccccccccccccccccc c read full array from tape file cccccccccccccccccccccccccccccccccccccc nml=n1*m1*l #if (HP > 0 ) c read data on HP/Convex machine c ifcr =/= 0 file opened by CRAYOPEN if(ioptr.eq.0) then c read data from HP/Convex or IBM machines read(inr)temp endif if (ioptr.eq.1) then c read data from CRAY MPP machines ierr = CRAYREAD(ifcr, temp, nml, 0) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif if (ioptr.eq.2) then c read data from CRAY PVP machines ierr = CRAYREAD(ifcr, temp, nml, 2) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif #endif #if(SGI_O2K == 1) c read data on SGI Origin 2000 machine c NCARU liblaries not available; read data from SGI Origin 2000 machine read(inr)temp #endif #if(SGI_O2K == 2) c read data on SGI Origin 2000 machine c ifcr =/= 0 file opened by CRAYOPEN if(ioptr.eq.0) then c read data from SGI read(inr)temp endif if (ioptr.eq.1) then c read data from CRAY MPP machines ierr = CRAYREAD(ifcr, temp, nml, 0) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif if (ioptr.eq.2) then c read data from CRAY PVP machines ierr = CRAYREAD(ifcr, temp, nml, 2) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif #endif c read data on Cray machines or on workstation #if (CRAYPVP == 1) read(inr)temp c IOPTR=0 read data from HP/Convex machines : assign -F f77 N ieee_64 u:9 c IOPTR=2 read data from CRAY PVP machines : dont convert datas if (ioptr.eq.1) then c read data from CRAY MPP machines Converts IEEE/Generic 32-bit (on a generic 32-bit platform) data to Cray Research 64-bit data ierr=IEG2CRAY(8,nml,temp,0,temp,1) if(ierr.lt.0) . print *,'IEG2CRAY error:',ierr,' no translation performed' endif #endif #if (CRAYT3D == 1 || CRAYT3E == 1) read(inr)temp c IOPTR=0 read data from HP/Convex machines : assign -F f77 u:9 c IOPTR=1 read data from CRAY MPP machines : dont convert datas if(ioptr.eq.2) then Converts Cray Research PVP 64-bit data to IEEE/MPP 64-bit data print *,'array size is nml=',nml print *,'CRAY2CRI( 2, nml, temp, 0 , temp, 1 )' ierr=CRAY2CRI( 2, nml, temp, 0 , temp, 1 ) if(ierr.lt.0) . print *,'CRAY2CRI error:',ierr,' no translation performed' endif #endif #if (WORKS > 0 || IBM > 0 || PLE > 0 || LNX >0) c read data on "FUJI VPP 700" "IBM" or "Workstation" read(inr)temp #endif ccccccccccccccccccccccccccccccccccccccccc c read full array from tape file done ccccccccccccccccccccccccccccccccccccccccc else !ifullarr = 0 cccccccccccccccccccccccccccccccccccccccc c read one value from tape file cccccccccccccccccccccccccccccccccccccccc nml=1 #if (HP > 0 ) if(ioptr.eq.0) then c read data from HP/Convex or IBM machines read(inr)fval else if (ioptr.eq.1) then c read data from CRAY MPP machines ierr = CRAYREAD(ifcr, fval, 1, 0) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' else if (ioptr.eq.2) then c read data from CRAY PVP machines ierr = CRAYREAD(ifcr, fval, 1, 2) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif #endif #if (SGI_O2K == 1) if(ioptr.eq.0) then c read data from HP/Convex/SGI Origin machines read(inr)fval endif #endif #if (SGI_O2K == 2) if(ioptr.eq.0) then c read data from HP/Convex/SGI Origin machines read(inr)fval else if (ioptr.eq.1) then c read data from CRAY MPP machines ierr = CRAYREAD(ifcr, fval, 1, 0) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' else if (ioptr.eq.2) then c read data from CRAY PVP machines ierr = CRAYREAD(ifcr, fval, 1, 2) c print *,'CRAYREAD from ',ifcr,' ',ierr,' data' endif #endif #if (CRAYPVP == 1) read(inr)fval c IOPTR=0 read data from HP/Convex machines : assign -F f77 N ieee_64 u:9 c IOPTR=2 read data from CRAY PVP machines : dont convert datas if (ioptr.eq.1) then c read data from CRAY MPP machines Converts IEEE/Generic 32-bit (on a generic 32-bit platform) data to Cray Research 64-bit data ierr=IEG2CRAY(8,1,fval,0,fval,1) if(ierr.lt.0) . print *,'IEG2CRAY error:',ierr,' no translation performed' endif #endif #if (CRAYT3D == 1 || CRAYT3E == 1) read(inr)fval c IOPTR=0 read data from HP/Convex machines : assign -F f77 u:9 c IOPTR=1 read data from CRAY MPP machines : dont convert datas if(ioptr.eq.2) then Converts Cray Research PVP 64-bit data to IEEE/MPP 64-bit data print *,'array size is =',1 print *,'CRAY2CRI( 2, 1, fval, 0 , fval, 1 )' ierr=CRAY2CRI( 2, 1, fval, 0 , fval, 1 ) if(ierr.lt.0) . print *,'CRAY2CRI error:',ierr,' no translation performed' endif #endif #if (WORKS > 0 || IBM > 0 || PLE > 0 || LNX >0) read(inr)fval #endif cccccccccccccccccccccccccccccccccccccccc c read one value from tape file done cccccccccccccccccccccccccccccccccccccccc endif return end C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine writeit0tape(temp,fval,ifullarr,inr,n1,m1) c c This subroutine writes the data to the history file by PE0 c include 'param.nml' include 'msg.inc' #if (HP > 0 || SGI_O2K > 1 || IBM > 0|| LNX >0 || PLE > 0) integer CRAYWRITE #endif common /hpcray/ ifcw,ifcr,ioptw,ioptr #if (IOWTAPE == 3) real*8 temp(n1,m1,l) real*8 fval #endif #if (IOWTAPE == 2) real*4 temp(n1,m1,l) real*4 fval #endif #if (IOWTAPE == 1) dimension temp(n1,m1,l) real fval #endif if (ifullarr.eq.1) then ccccccccccccccccccccccccccccccccc c write data to the tape file ccccccccccccccccccccccccccccccccc nml=n1*m1*l #if (HP > 0) if(ioptw.eq.0) then write(inr)temp endif if(ioptw.eq.1) then Converts 64-bit data to Cray MPP 64-bit data ierr = CRAYWRITE(ifcw, temp, nml, 0) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif if(ioptw.eq.2) then Converts 64-bit data to Cray Research PVP 64-bit data ierr = CRAYWRITE(ifcw, temp, nml, 2) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif #endif #if(SGI_O2K == 1) C NCARU libraries not available for WORD = 4 write(inr)temp #endif #if(SGI_O2K == 2) if(ioptw.eq.0) then write(inr)temp endif if(ioptw.eq.1) then Converts 64-bit data to Cray MPP 64-bit data ierr = CRAYWRITE(ifcw, temp, nml, 0) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif if(ioptw.eq.2) then Converts 64-bit data to Cray Research PVP 64-bit data ierr = CRAYWRITE(ifcw, temp, nml, 2) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif #endif #if (CRAYPVP == 1) c IOPTW=0 write data to HP/Convex machines : assign -F f77 -N ieee_64 u:9 c IOPTW=2 write data to CRAY PVP machines : dont convert datas if(ioptw.eq.1) then Converts Cray Research 64-bit data to IEEE/Generic 32-bit data ierr=CRAY2IEG( 8, nml, temp, 0, temp, 1) if(ierr.lt.0) . print *,'CRAY2IEG error:',ierr,' no translation performed' endif write(inr)temp #endif #if (CRAYT3D == 1 || CRAYT3E == 1) c IOPTW=0 write data to HP/Convex machines : assign -F f77 u:9 c IOPTW=1 write data to CRAY MPP machines : dont convert datas if(ioptw.eq.2) then Converts IEEE/MPP 64-bit data to Cray Research PVP 64-bit data print *,'size array is nml=',nml print *,'CRI2CRAY( 2, nml, temp, 0 , temp, 1 )' ierr=CRI2CRAY( 2, nml, temp, 0 , temp, 1 ) if(ierr.lt.0) . print *,'CRI2CRAY error:',ierr,' no translation performed' endif write(inr)temp #endif #if (WORKS > 0 || FUJI_VPP > 0 || IBM > 0 || LNX >0 || PLE > 0) write(inr)temp #endif ccccccccccccccccccccccccccccccccccccccccc c write full array to tape file done ccccccccccccccccccccccccccccccccccccccccc else !ifullarr = 0 ccccccccccccccccccccccccccccccccccccccccc c write out one value ccccccccccccccccccccccccccccccccccccccccc nml=1 #if (HP > 0) if(ioptw.eq.0) then write(inr)fval endif if(ioptw.eq.1) then Converts 64-bit data to Cray MPP 64-bit data ierr = CRAYWRITE(ifcw, fval, 2, 0) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif if(ioptw.eq.2) then Converts 64-bit data to Cray Research PVP 64-bit data ierr = CRAYWRITE(ifcw, fval, 2, 2) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif #endif #if(SGI_O2K == 1) C NCARU libraries not available for WORD = 4 write(inr)fval #endif #if(SGI_O2K == 2) if(ioptw.eq.0) then write(inr)fval endif if(ioptw.eq.1) then Converts 64-bit data to Cray MPP 64-bit data ierr = CRAYWRITE(ifcw, fval, 2, 0) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif if(ioptw.eq.2) then Converts 64-bit data to Cray Research PVP 64-bit data ierr = CRAYWRITE(ifcw, fval, 2, 2) print *,'CRAYWRITE to ',ifcw,' ',ierr,' data' endif #endif #if (CRAYPVP == 1) c IOPTW=0 write data to HP/Convex machines : assign -F f77 -N ieee_64 u:9 c IOPTW=2 write data to CRAY PVP machines : dont convert datas if(ioptw.eq.1) then Converts Cray Research 64-bit data to IEEE/Generic 32-bit data ierr=CRAY2IEG( 8, 1, fval, 0, fval, 1) if(ierr.lt.0) . print *,'CRAY2IEG error:',ierr,' no translation performed' endif write(inr)fval #endif #if (CRAYT3D == 1 || CRAYT3E == 1) c IOPTW=0 write data to HP/Convex machines : assign -F f77 u:9 c IOPTW=1 write data to CRAY MPP machines : dont convert datas if(ioptw.eq.2) then Converts IEEE/MPP 64-bit data to Cray Research PVP 64-bit data print *,'size array is nml=',nml print *,'CRI2CRAY( 2, 1, fval, 0 , fval, 1 )' ierr=CRI2CRAY( 2, 1, fval, 0 , fval, 1 ) if(ierr.lt.0) . print *,'CRI2CRAY error:',ierr,' no translation performed' endif write(inr)fval #endif #if (IBM > 0 || WORKS > 0 || FUJI_VPP > 0 || LNX >0 || PLE > 0) write(inr)fval #endif cccccccccccccccccccccccccccccc c write out one value done cccccccccccccccccccccccccccccc end if return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C S T O P - U N T I L A L L P R O C E S S O R S A R E R E A D Y C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine mybarrier() c c my barrier (machine specific) c #include "msg.lnk" #if (PARALLEL == 2) CMPITEST print *,'Barier',rank #if (CRAYPVP == 1) CPVP Barier Dont Work #else CO2K Barier Dont Scale Above 32 PE, but we need it for I/O operations C call MPI_Barrier(MPI_COMM_EULAG, ierr) #endif CMPITEST print *,'After Barier',rank #endif #if (PARALLEL == 1) integer psync(SHMEM_REDUCE_SYNC_SIZE) data psync/SHMEM_REDUCE_SYNC_SIZE*SHMEM_SYNC_VALUE/ #if (SGI_O2K > 0) call shmem_barrier_all() #else call barrier() #endif c call shmem_barrier(0,0,n$pes,psync) #endif return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C G L O B A L S U M S , M A X I M A S , M I N I M A S C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #define DIAGPLT 0 /* 1=prints for dignose */ #if (PARALLEL > 0) c --------------------------------------- c calculate sums on the MPP computers c --------------------------------------- function globsum(array,ilow,iupp,jlow,jupp,klow,kupp, . i1,i2,j1,j2,k1,k2) include 'param.nml' include 'msg.inc' #include "msg.lnk" common /csum/psum,tsum,work integer bit,neighbor,prevbits integer xor,and,or integer shiftr,shiftl,rval integer level,nodes save level,nodes data ifirst/1/ #if (WORKS == 2) C!!! g77 compiler error when (ilow.lt.0) OR (jlow.lt.0) dimension array(-2:iupp,-2:jupp,klow:kupp) #else dimension array(ilow:iupp,jlow:jupp,klow:kupp) #endif integer DC_TSUM real globsum #if (SUMR16 == 1) real*16 psum0,pa,psum,tsum,work DC_TSUM = MPI_DOUBLE_PRECISION ict=2 #else real psum0,pa,psum,tsum,work c real*8 psum0,pa,psum,tsum,work DC_TSUM = DC_TYPE ict=1 #endif #if (DIAGPLT == 1) print *,'Insite Globsum',mype #endif #if (TIMEPLT == 1) call ttbeg(78) #endif psum0=0. do k=k1,k2 do j=j1,j2 do i=i1,i2 psum0=psum0+array(i,j,k) end do end do end do psum=psum0 #if (PARALLEL == 2) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c routine MPI_ALLReduce is standart but work slowly (4.3 / 3.5) c CALL MPI_ALLReduce(psum,pa,ict,DC_TSUM,MPI_SUM,MPI_COMM_EULAG,ir) c globsum=pa c return cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #endif nodes = mysize tsum=psum c compute global sum if(ifirst.eq.1) then if(nodes .eq. 1) go to 99 level = 0 1 nodes = shiftr(nodes,1) level = level + 1 if(nodes .gt. 1) go to 1 nodes = mysize if(nodes .ne. shiftl(1,level)) level = level + 1 endif if(nodes .eq. 1) go to 99 prevbits = 0 bit=1 rval = 2**level if (nodes.eq.rval) then c c reduction for power of 2 processors c do i=1,level CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 1) call mybarrier() #endif neighbor = xor(mype,bit) #if (PARALLEL == 2) call MPI_Send(tsum,ict,DC_TSUM,neighbor,41, . MPI_COMM_EULAG, ierr) call MPI_Recv(work,ict,DC_TSUM,neighbor,41, . MPI_COMM_EULAG,status, ierr) #endif CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 1) c call shmem_barrier_all() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,tsum,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,tsum,1,neighbor) #endif #else call shmem_put(work,tsum,1,neighbor) #endif call shmem_barrier_all() call shmem_udcflush() #endif CCCCCCCCCCCCCCCCCCC tsum = tsum + work bit=shiftl(bit,1) end do else c c reduction for non-power of 2 processors c do i=1,level #if (PARALLEL == 1) call mybarrier() #endif neighbor=xor(mype,bit) if(neighbor.lt.nodes .and. and(mype,prevbits) .eq. 0) then if(and(bit,mype).eq.bit) then CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 2) call MPI_Send(tsum,ict,DC_TSUM,neighbor,41, . MPI_COMM_EULAG, ierr) #endif CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 1) #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,tsum,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,tsum,1,neighbor) #endif #else call shmem_put(work,tsum,1,neighbor) #endif #endif CCCCCCCCCCCCCCCCCCC end if end if #if (PARALLEL == 1) call shmem_barrier_all() call shmem_udcflush() #endif if(neighbor.lt.nodes .and. and(mype,prevbits) .eq. 0) then if(and(bit,mype).eq.0) then #if (PARALLEL == 2) call MPI_Recv(work,ict,DC_TSUM,neighbor,41, . MPI_COMM_EULAG, status,ierr) #endif tsum=tsum+work end if end if prevbits = or(prevbits,bit) bit=shiftl(bit,1) end do CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 2) call MPI_Bcast(tsum,ict,DC_TSUM,0,MPI_COMM_EULAG, ierr) #endif CCCCCCCCCCCCCCCCCCC #if (PARALLEL == 1) call shmem_barrier_all() if(mype .gt. 0) then #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tsum,tsum,1,0) #endif #if (SGI_O2K == 2) call shmem_get64(tsum,tsum,1,0) #endif #else call shmem_get(tsum,tsum,1,0) #endif endif call shmem_barrier_all() #endif CCCCCCCCCCCCCCCCCCC end if 99 continue globsum=tsum #if (TIMEPLT == 1) call ttend(78) #endif #if (DIAGPLT == 1) print *,'pe :',mype,' globsum =',globsum c stop 'globsum' #endif return end #else c --------------------------------------- c calculate sums on nonparallel computers c --------------------------------------- function globsum(array,ilow,iupp,jlow,jupp,klow,kupp, . i1,i2,j1,j2,k1,k2) #if (WORKS == 2) C!!! g77 compiler error when (ilow.lt.0) OR (jlow.lt.0) dimension array(-2:iupp,-2:jupp,klow:kupp) #else dimension array(ilow:iupp,jlow:jupp,klow:kupp) #endif #if (SUMR16 == 1) real*16 psum0,psum #else c real*16 psum0 c real psum real*8 psum0,psum #endif real globsum #if (TIMEPLT == 1) call ttbeg(78) #endif psum0=0. do k=k1,k2 do j=j1,j2 do i=i1,i2 psum0=psum0+array(i,j,k) end do end do end do psum=psum0 globsum=psum #if (TIMEPLT == 1) call ttend(78) #endif return end #endif function globmax(array,ilow,iupp,jlow,jupp,klow,kupp, . i1,i2,j1,j2,k1,k2) c ------------------------------ c calculate max on MPP computers c ------------------------------ include 'param.nml' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" common /cmax/flocmax,fglobmax,pwrk,work integer bit,neighbor,prevbits integer xor,and,or integer shiftr,shiftl,rval integer level,nodes save level,nodes data ifirst/1/ #endif #if (WORKS == 2) C!!! g77 compiler error when (ilow.lt.0) OR (jlow.lt.0) dimension array(-2:iupp,-2:jupp,klow:kupp) #else dimension array(ilow:iupp,jlow:jupp,klow:kupp) #endif real globmax #if (DIAGPLT == 1) print *,'Insite Globmax',mype #endif #if (TIMEPLT == 1) call ttbeg(79) #endif c compute local max first c flocmax=array(1,1,1) flocmax=-1.e30 do k=k1,k2 do j=j1,j2 do i=i1,i2 flocmax=amax1(flocmax,array(i,j,k)) end do end do end do fglobmax=flocmax #if (PARALLEL > 0) nodes = mysize #if (PARALLEL == 2) ict=1 #endif c compute global max if(ifirst.eq.1) then if(nodes .eq. 1) go to 99 level = 0 1 nodes = shiftr(nodes,1) level = level + 1 if(nodes .gt. 1) go to 1 nodes = mysize if(nodes .ne. shiftl(1,level)) level = level + 1 endif if(nodes .eq. 1) go to 99 prevbits = 0 bit=1 rval = 2**level if (nodes.eq.rval) then c c reduction for power of 2 processors c do i=1,level #if (PARALLEL == 1) call mybarrier() #endif neighbor = xor(mype,bit) #if (PARALLEL == 2) call MPI_Send(fglobmax,ict,DC_TYPE,neighbor,43, . MPI_COMM_EULAG, ierr) call MPI_Recv(work,ict,DC_TYPE,neighbor,43, . MPI_COMM_EULAG,status, ierr) #endif #if (PARALLEL == 1) c call shmem_barrier_all() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,fglobmax,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,fglobmax,1,neighbor) #endif #else call shmem_put(work,fglobmax,1,neighbor) #endif call shmem_barrier_all() call shmem_udcflush() #endif fglobmax = amax1(fglobmax,work) bit=shiftl(bit,1) end do else c c reduction for non-power of 2 processors c do i=1,level #if (PARALLEL == 1) call mybarrier() #endif neighbor=xor(mype,bit) if(neighbor .lt. nodes .and. & and(mype,prevbits) .eq. 0) then if(and(bit,mype) .eq. bit) then #if (PARALLEL == 2) call MPI_Send(fglobmax,ict,DC_TYPE,neighbor,43, . MPI_COMM_EULAG, ierr) #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,fglobmax,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,fglobmax,1,neighbor) #endif #else call shmem_put(work,fglobmax,1,neighbor) #endif #endif endif endif #if (PARALLEL == 1) call shmem_barrier_all() call shmem_udcflush() #endif if(neighbor .lt. nodes .and. & and(mype,prevbits) .eq. 0) then if(and(bit,mype) .eq. 0) then #if (PARALLEL == 2) call MPI_Recv(work,ict,DC_TYPE,neighbor,43, . MPI_COMM_EULAG,status, ierr) #endif fglobmax=amax1(fglobmax,work) end if end if prevbits = or(prevbits,bit) bit=shiftl(bit,1) enddo #if (PARALLEL == 2) call MPI_Bcast(fglobmax,ict,DC_TYPE,0,MPI_COMM_EULAG, ierr) #endif #if (PARALLEL == 1) call shmem_barrier_all() if(mype .gt. 0) then #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(fglobmax,fglobmax,1,0) #endif #if (SGI_O2K == 2) call shmem_get64(fglobmax,fglobmax,1,0) #endif #else call shmem_get(fglobmax,fglobmax,1,0) #endif endif call shmem_barrier_all() #endif end if 99 continue #endif globmax=fglobmax #if (TIMEPLT == 1) call ttend(79) #endif #if (DIAGPLT == 1) print *,'pe :',mype,' globmax =',globmax #endif return end function globmin(array,ilow,iupp,jlow,jupp,klow,kupp, . i1,i2,j1,j2,k1,k2) c c calculate min on MPP computers c include 'param.nml' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" common /cmin/flocmin,fglobmin,pwrk,work integer bit,neighbor,prevbits integer xor,and,or integer shiftr,shiftl,rval integer level,nodes save level,nodes data ifirst/1/ #endif #if (WORKS == 2) C!!! g77 compiler error when (ilow.lt.0) OR (jlow.lt.0) dimension array(-2:iupp,-2:jupp,klow:kupp) #else dimension array(ilow:iupp,jlow:jupp,klow:kupp) #endif real globmin #if (DIAGPLT == 1) print *,'Insite Globmin',mype #endif #if (TIMEPLT == 1) call ttbeg(80) #endif c compute local min first c flocmin=array(1,1,1) flocmin=1.e30 do k=k1,k2 do j=j1,j2 do i=i1,i2 flocmin=amin1(flocmin,array(i,j,k)) end do end do end do fglobmin=flocmin #if (PARALLEL > 0) nodes = mysize #if (PARALLEL == 2) ict=1 #endif c compute global min if(ifirst.eq.1) then if(nodes .eq. 1) go to 99 level = 0 1 nodes = shiftr(nodes,1) level = level + 1 if(nodes .gt. 1) go to 1 nodes = mysize if(nodes .ne. shiftl(1,level)) level = level + 1 endif if(nodes .eq. 1) go to 99 prevbits = 0 bit=1 rval = 2**level if (nodes.eq.rval) then c c reduction for power of 2 processors c do i=1,level #if (PARALLEL == 1) call mybarrier() #endif neighbor = xor(mype,bit) #if (PARALLEL == 2) call MPI_Send(fglobmin,ict,DC_TYPE,neighbor,45, . MPI_COMM_EULAG, ierr) call MPI_Recv(work,ict,DC_TYPE,neighbor,45, . MPI_COMM_EULAG,status, ierr) #endif #if (PARALLEL == 1) c call shmem_barrier_all() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,fglobmin,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,fglobmin,1,neighbor) #endif #else call shmem_put(work,fglobmin,1,neighbor) #endif call shmem_barrier_all() call shmem_udcflush() #endif fglobmin = amin1(fglobmin,work) bit=shiftl(bit,1) end do else c c reduction for non-power of 2 processors c do i=1,level #if (PARALLEL == 1) call mybarrier() #endif neighbor=xor(mype,bit) if(neighbor .lt. nodes .and. & and(mype,prevbits) .eq. 0) then if(and(bit,mype) .eq. bit) then #if (PARALLEL == 2) call MPI_Send(fglobmin,ict,DC_TYPE,neighbor,45, . MPI_COMM_EULAG, ierr) #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_put32(work,fglobmin,1,neighbor) #endif #if (SGI_O2K == 2) call shmem_put64(work,fglobmin,1,neighbor) #endif #else call shmem_put(work,fglobmin,1,neighbor) #endif #endif endif endif #if (PARALLEL == 1) call shmem_barrier_all() call shmem_udcflush() #endif if(neighbor .lt. nodes .and. & and(mype,prevbits) .eq. 0) then if(and(bit,mype) .eq. 0) then #if (PARALLEL == 2) call MPI_Recv(work,ict,DC_TYPE,neighbor,45, . MPI_COMM_EULAG,status, ierr) #endif fglobmin=amin1(fglobmin,work) end if end if prevbits = or(prevbits,bit) bit=shiftl(bit,1) enddo #if (PARALLEL == 2) call MPI_Bcast(fglobmin,ict,DC_TYPE,0,MPI_COMM_EULAG,ierr) #endif #if (PARALLEL == 1) call shmem_barrier_all() if(mype .gt. 0) then #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(fglobmin,fglobmin,1,0) #endif #if (SGI_O2K == 2) call shmem_get64(fglobmin,fglobmin,1,0) #endif #else call shmem_get(fglobmin,fglobmin,1,0) #endif endif call shmem_barrier_all() #endif end if 99 continue #endif globmin=fglobmin #if (TIMEPLT == 1) call ttend(80) #endif #if (DIAGPLT == 1) print *,'pe :',mype,' fglobmin =',fglobmin #endif return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C U P D A T E S H A L L O B E T W E E N P R O C E S S O R S C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (POLES == 0) subroutine updatew(a,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' include "msg.lnk" dimension a(ndim1-ih:ndim2+ih, mdim1-ih:mdim2+ih,l1) #if (PARALLEL > 0) #if (PARALLEL == 2) #if (SGI_O2K > 0) integer stats,statr #endif #endif common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPDATEW',mype,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg #endif #if (TIMEPLT == 1) call ttbeg(75) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=(n2-n1+1)*ihr*l1 mhl=ihr*(m2-m1+1)*l1 ihl=ihr*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c------------------------------------------------------------------- c icnt=1 do k=1,l1 do j=1,ihr do i=n1,n2 #if (PARALLEL == 0) c tmpxrcv1=a(i,j,k) c tmpxrcv2=a(i,m2-ihr+j,k) c a(i,m2+j ,k)=tmpxrcv1 c a(i,m1-1-ihr+j,k)=tmpxrcv2 a(i,m2+j ,k)=a(i, j,k) a(i,m1-1-ihr+j,k)=a(i,m2-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m2-ihr+j,k) icnt=icnt+1 #endif end do end do end do c c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- c icnt=1 do j=m1,m2 do i=1,ihr do k=1,l1 #if (PARALLEL == 0) c tmpyrcv1=a(i,j,k) c tmpyrcv2=a(n2-ihr+i,j,k) c a(n1+i ,j,k)=tmpyrcv1 c a(n1-1-ihr+i,j,k)=tmpyrcv2 a(n2+i ,j,k)=a( i,j,k) a(n1-1-ihr+i,j,k)=a(n2-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n2-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do c print *,'PARALLEL',mype #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif c call mybarrier() #endif #if (PARALLEL == 2) #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) c call mybarrier() call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,1, . tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,2, . tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do k=1,l1 do j=1,ihr do i=n1,n2 a(i,m2+j,k)=tmpxrcv1(icnt) a(i,m1-1-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do icnt=1 do j=m1,m2 do i=1,ihr do k=1,l1 a(n2+i,j,k)=tmpyrcv1(icnt) a(n1-1-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #endif c c now send and receive corner pieces c icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 #if (PARALLEL == 0) tmpcorrcv1=a(n2-ihr+i,m2-ihr+j,k) tmpcorrcv2=a(n2-ihr+i, j,k) tmpcorrcv3=a(i , j,k) tmpcorrcv4=a(i ,m2-ihr+j,k) a(n1-1+i-ihr,m1-1+j-ihr,k)=tmpcorrcv1 a(n1-1+i-ihr,m2+j ,k)=tmpcorrcv2 a(n2+i ,m2+j ,k)=tmpcorrcv3 a(n2+i ,m1-1+j-ihr,k)=tmpcorrcv4 c a(n1-1+i-ihr,m1-1+j-ihr,k)=a(n2-ihr+i,m2-ihr+j,k) c a(n1-1+i-ihr,m2+j ,k)=a(n2-ihr+i,j ,k) c a(n2+i ,m2+j ,k)=a(i ,j ,k) c a(n2+i ,m1-1+j-ihr,k)=a(i ,m2-ihr+j,k) #else tmpcorsnd1(icnt)=a(n2-ihr+i,m2-ihr+j,k) tmpcorsnd2(icnt)=a(n2-ihr+i, j,k) tmpcorsnd3(icnt)=a(i , j,k) tmpcorsnd4(icnt)=a(i ,m2-ihr+j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #else call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C This is ill-constructed in that it relies on the MPI_Send returning C before the MPI_Recv is posted. Since MPI_Send is a blocking send this C will only happen when the implementation provides for (adequate) C buffering for messages. If the send does not return, then the program C enters a deadlock since all processes are blocked from posting the C required receive. Timothy J Campbell CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#if (HP == 0) C call MPI_Send(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, C . MPI_COMM_EULAG,status, ierr) C#else CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,status,ierr) C#endif #endif #endif icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 a(n1-1+i-ihr,m1-1+j-ihr,k)=tmpcorrcv1(icnt) a(n1-1+i-ihr,m2+j ,k)=tmpcorrcv2(icnt) a(n2+i ,m2+j ,k)=tmpcorrcv3(icnt) a(n2+i ,m1-1+j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(75) #endif #if (DIAGPLT == 1) print *,'OUT_UPDATEW',mype #endif return end subroutine updatebtw(a,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' #include "msg.lnk" dimension a(ndim1-ih:ndim2+ih, mdim1-ih:mdim2+ih,l1) #if (PARALLEL > 0) #if (PARALLEL == 2) #if (SGI_O2K > 0) integer stats,statr #endif #endif common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPD_BTW',mype,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg #endif #if (TIMEPLT == 1) call ttbeg(76) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=(n2-n1+1)*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c------------------------------------------------------------------- c icnt=1 do k=1,l1 do j=1,ihr do i=n1,n2 #if (PARALLEL == 0) c tmpxrcv1=a(i, j,k) c tmpxrcv2=a(i,m2-ihr+j,k) c a(i,m2+j ,k)=tmpxrcv1 c a(i,m1-1-ihr+j,k)=tmpxrcv2 a(i,m2+j ,k)=a(i, j,k) a(i,m1-1-ihr+j,k)=a(i,m2-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m2-ihr+j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif c call mybarrier() #endif #if (PARALLEL == 2) #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) c call mybarrier() call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,1, . tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,2, . tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do k=1,l1 do j=1,ihr do i=n1,n2 a(i,m2+j ,k)=tmpxrcv1(icnt) a(i,m1-1-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do #endif #if (TIMEPLT == 1) call ttend(76) #endif #if (DIAGPLT == 1) print *,'OUT_UPDATEBTW',mype #endif return end subroutine updatelrw(a,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' #include "msg.lnk" dimension a(ndim1-ih:ndim2+ih, mdim1-ih:mdim2+ih,l1) #if (PARALLEL > 0) #if (PARALLEL == 2) #if (SGI_O2K > 0) integer stats,statr #endif #endif common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPD_LRW',mype,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg #endif #if (TIMEPLT == 1) call ttbeg(77) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- mhl=ihr*(m2-m1+1)*l1 c c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- c icnt=1 do j=m1,m2 do i=1,ihr do k=1,l1 #if (PARALLEL == 0) c tmpyrcv1=a(i ,j,k) c tmpyrcv2=a(n2-ihr+i,j,k) c a(n1+i ,j,k)=tmpyrcv1 c a(n1-1-ihr+i,j,k)=tmpyrcv2 a(n2+i ,j,k)=a( i,j,k) a(n1-1-ihr+i,j,k)=a(n2-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n2-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif c call mybarrier() #endif #if (PARALLEL == 2) #if (ISEND == 3) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) c call mybarrier() call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do j=m1,m2 do i=1,ihr do k=1,l1 a(n2+i ,j,k)=tmpyrcv1(icnt) a(n1-1-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #endif #if (TIMEPLT == 1) call ttend(77) #endif #if (DIAGPLT == 1) print *,'OUT_UPDATELRW',mype #endif return end subroutine update(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPDATE',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(70) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) print *, 'Parallel == 1' call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=n1*ihr*l1 mhl=ihr*m1*l1 ihl=ihr*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c------------------------------------------------------------------- c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 #if (PARALLEL == 0) c tmpxrcv1=a(i, j,k) c tmpxrcv2=a(i,m1-ihr+j,k) c a(i, m1+j,k)=tmpxrcv1 c a(i,-ihr+j,k)=tmpxrcv2 a(i, m1+j,k)=a(i, j,k) a(i,-ihr+j,k)=a(i,m1-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 #endif end do end do end do c c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- c icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 #if (PARALLEL == 0) c tmpyrcv1=a( i,j,k) c tmpyrcv2=a(n1-ihr+i,j,k) c a( n1+i,j,k)=tmpyrcv1 c a(-ihr+i,j,k)=tmpyrcv2 a( n1+i,j,k)=a( i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif c call mybarrier() #endif #if (PARALLEL == 2) #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) c call mybarrier() call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,1, . tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,2, . tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) #endif #endif c print *,'PARALLEL done',mype c c store data in main array now c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 a(n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #endif c c now send and receive corner pieces c icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 #if (PARALLEL == 0) tmpcorrcv1=a(n1-ihr+i,m1-ihr+j,k) tmpcorrcv2=a(n1-ihr+i, j,k) tmpcorrcv3=a( i, j,k) tmpcorrcv4=a( i,m1-ihr+j,k) a(i-ihr,j-ihr,k)=tmpcorrcv1 a(i-ihr, m1+j,k)=tmpcorrcv2 a( n1+i, m1+j,k)=tmpcorrcv3 a( n1+i,j-ihr,k)=tmpcorrcv4 c a(i-ihr,j-ihr,k)=a(n1-ihr+i,m1-ihr+j,k) c a(i-ihr, m1+j,k)=a(n1-ihr+i, j,k) c a( n1+i, m1+j,k)=a( i, j,k) c a( n1+i,j-ihr,k)=a( i,m1-ihr+j,k) #else tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i, j,k) tmpcorsnd3(icnt)=a( i, j,k) tmpcorsnd4(icnt)=a( i,m1-ihr+j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #else call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C This is ill-constructed in that it relies on the MPI_Send returning C before the MPI_Recv is posted. Since MPI_Send is a blocking send this C will only happen when the implementation provides for (adequate) C buffering for messages. If the send does not return, then the program C enters a deadlock since all processes are blocked from posting the C required receive. Timothy J Campbell CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#if (HP == 0) C call MPI_Send(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, C . MPI_COMM_EULAG,status, ierr) C#else CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_EULAG,status,ierr) C#endif #endif #endif c print *,'PARALLEL 2 done',mype icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) a(i-ihr, m1+j,k)=tmpcorrcv2(icnt) a( n1+i, m1+j,k)=tmpcorrcv3(icnt) a( n1+i,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(70) #endif #if (DIAGPLT == 1) print *,'OUT_UPDATE',mype #endif return end subroutine update2(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPDATE2',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(71) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=n1*ihr*l1 mhl=m1*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below: tmpxsnd1 c prepare top segments for processor above : tmpxsnd2 c------------------------------------------------------------------- c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 #if (PARALLEL == 0) c tmpxrcv1=a(i, j,k) c tmpxrcv2=a(i,m1-ihr+j,k) c a(i, m1+j,k)=tmpxrcv1 c a(i,-ihr+j,k)=tmpxrcv2 a(i, m1+j,k)=a(i, j,k) a(i,-ihr+j,k)=a(i,m1-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 #endif end do end do end do c c------------------------------------------------------------------- c prepare left data segments for processor on the left :tmpysnd1 c prepare right data segments for processor to the right:tmpysnd2 c------------------------------------------------------------------- c icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 #if (PARALLEL == 0) c tmpyrcv1=a( i,j,k) c tmpyrcv2=a(n1-ihr+i,j,k) c a( n1+i,j,k)=tmpyrcv1 c a(-ihr+i,j,k)=tmpyrcv2 a( n1+i,j,k)=a( i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #endif #if (PARALLEL == 2) #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,11,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,12,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,13,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,13,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,14,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,14,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,2,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,3,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,4,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) c call mybarrier() call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv1,nhl,DC_TYPE,peabove,11,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv2,nhl,DC_TYPE,pebelow,12,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,13, . tmpyrcv1,mhl,DC_TYPE,peright,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,14, . tmpyrcv2,mhl,DC_TYPE,peleft,14,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 a(i, m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 a( n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(71) #endif #if (DIAGPLT == 1) print *,'OUT UPDATE2',mype #endif return end #if (SEMILAG == 1) subroutine updatelagr(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' parameter (l3=l+2*ior) dimension a(1-ihlag-ior:ndim+ihlag+ior, . 1-ihlag-ior:mdim+ihlag+ior,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updlagr/ tmpxsnd1((np+2*ior)*ihlag*l3), . tmpxsnd2((np+2*ior)*ihlag*l3), . tmpysnd1((mp+2*ior)*ihlag*l3), . tmpysnd2((mp+2*ior)*ihlag*l3), . tmpcorsnd1(ihlag*ihlag*l3), . tmpcorsnd2(ihlag*ihlag*l3), . tmpcorsnd3(ihlag*ihlag*l3), . tmpcorsnd4(ihlag*ihlag*l3), . tmpxrcv1((np+2*ior)*ihlag*l3), . tmpxrcv2((np+2*ior)*ihlag*l3), . tmpyrcv1((mp+2*ior)*ihlag*l3), . tmpyrcv2((mp+2*ior)*ihlag*l3), . tmpcorrcv1(ihlag*ihlag*l3), . tmpcorrcv2(ihlag*ihlag*l3), . tmpcorrcv3(ihlag*ihlag*l3), . tmpcorrcv4(ihlag*ihlag*l3) #endif #if (DIAGPLT == 1) print *,'UPDATELGR',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(72) #endif ihr=min(ihlag,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- if (leftedge.eq.1) then illim=1-ior else illim=1 end if if (rightedge.eq.1) then iulim=n1+ior else iulim=n1 end if if (botedge.eq.1) then jllim=1-ior else jllim=1 end if if (topedge.eq.1) then julim=m1+ior else julim=m1 end if nhl=(iulim-illim+1)*ihr*l1 mhl=(julim-jllim+1)*ihr*l1 ihl=(ihr*ihr*l1) c c------------------------------------------------------------------- c prepare bottom segments for processor below c prepare upper data segments for processor above c------------------------------------------------------------------- c icnt=1 do i=illim,iulim do j=1,ihr do k=1,l1 #if (PARALLEL == 0) tmpxrcv1=a(i, j,k) tmpxrcv2=a(i,m1-ihr+j,k) a(i, m1+ior+j,k)=tmpxrcv1 a(i,-ior-ihr+j,k)=tmpxrcv2 c a(i, m1+ior+j,k)=a(i, j,k) c a(i,-ior-ihr+j,k)=a(i,m1-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 #endif end do end do end do c c------------------------------------------------------------------- c prepare left data segments for processor on the left c prepare right data segments for processor to the right c------------------------------------------------------------------- c icnt=1 do i=1,ihr do j=jllim,julim do k=1,l1 #if (PARALLEL == 0) tmpyrcv1=a( i,j,k) tmpyrcv2=a(n1-ihr+i,j,k) a( n1+i+ior,j,k)=tmpyrcv1 a(-ior-ihr+i,j,k)=tmpyrcv2 c a( n1+i+ior,j,k)=a( i,j,k) c a(-ior-ihr+i,j,k)=a(n1-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,21,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,21,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,22,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,22,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,23,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,23,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,24,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,24,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,21,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,21,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,22,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,22,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,23,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,23,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,24,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,24,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,21, . tmpxrcv1,nhl,DC_TYPE,peabove,21,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,22, . tmpxrcv2,nhl,DC_TYPE,pebelow,22,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,23, . tmpyrcv1,mhl,DC_TYPE,peright,23,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,24, . tmpyrcv2,mhl,DC_TYPE,peleft,24,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 if (topedge.eq.0) then do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+ior+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do end if icnt=1 if (botedge.eq.0) then do i=illim,iulim do j=1,ihr do k=1,l1 a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihr do k=1,l1 a(i,-ior-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do end if icnt=1 if (rightedge.eq.0) then do i=1,ihr do j=jllim,julim do k=1,l1 a(n1+i,j,k)=tmpyrcv1(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=jllim,julim do k=1,l1 a(n1+i+ior,j,k)=tmpyrcv1(icnt) icnt=icnt+1 end do end do end do end if icnt=1 if (leftedge.eq.0) then do i=1,ihr do j=jllim,julim do k=1,l1 a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=jllim,julim do k=1,l1 a(-ior-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do end if #endif c c now send and receive corner pieces c icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 #if (PARALLEL == 0) tmpcorrcv1=a(n1-ihr+i,m1-ihr+j,k) tmpcorrcv2=a(n1-ihr+i, j,k) tmpcorrcv3=a( i, j,k) tmpcorrcv4=a( i,m1-ihr+j,k) a(i-ihr-ior,j-ihr-ior,k)=tmpcorrcv1 a(i-ihr-ior, m1+j+ior,k)=tmpcorrcv2 a( n1+i+ior, m1+j+ior,k)=tmpcorrcv3 a( n1+i+ior,j-ihr-ior,k)=tmpcorrcv4 c a(i-ihr-ior,j-ihr-ior,k)=a(n1-ihr+i,m1-ihr+j,k) c a(i-ihr-ior, m1+j+ior,k)=a(n1-ihr+i, j,k) c a( n1+i+ior, m1+j+ior,k)=a( i, j,k) c a( n1+i+ior,j-ihr-ior,k)=a( i,m1-ihr+j,k) #else tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i, j,k) tmpcorsnd3(icnt)=a( i, j,k) tmpcorsnd4(icnt)=a( i,m1-ihr+j,k) c if (i.eq.ihr .and. j.eq.ihr .and. k.eq.11) c . icntkp=icnt icnt=icnt+1 #endif end do end do end do c if (mype.eq.17) then c write(*,*)'***tmpcorsnd1(icntkp),tmpcorsnd1(icntkp+1)=', c . tmpcorsnd1(icntkp),tmpcorsnd1(icntkp+1) c end if #if (PARALLEL > 0) #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #else call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl,peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl,peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl,perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl,perightbelow) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,25, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,25, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,26, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,26, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,27, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,27, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,28, . MPI_COMM_EULAG,stats,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,28, . MPI_COMM_EULAG,statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,25, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd1,ihl,DC_TYPE,perightabove,25, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv2,ihl,DC_TYPE,peleftabove,26, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd2,ihl,DC_TYPE,perightbelow,26, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv3,ihl,DC_TYPE,perightabove,27, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,27, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpcorrcv4,ihl,DC_TYPE,perightbelow,28, . MPI_COMM_EULAG,statr,ierr) call MPI_SEND(tmpcorsnd4,ihl,DC_TYPE,peleftabove,28, . MPI_COMM_EULAG,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C This is ill-constructed in that it relies on the MPI_Send returning C before the MPI_Recv is posted. Since MPI_Send is a blocking send this C will only happen when the implementation provides for (adequate) C buffering for messages. If the send does not return, then the program C enters a deadlock since all processes are blocked from posting the C required receive. Timothy J Campbell CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C#if (HP == 0) C call MPI_Send(tmpcorsnd1,ihl,DC_TYPE,perightabove,25, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,25, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd2,ihl,DC_TYPE,perightbelow,26, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv2,ihl,DC_TYPE,peleftabove,26, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,27, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv3,ihl,DC_TYPE,perightabove,27, C . MPI_COMM_EULAG,status, ierr) C C call MPI_Send(tmpcorsnd4,ihl,DC_TYPE,peleftabove,28, C . MPI_COMM_EULAG, ierr) C call MPI_Recv(tmpcorrcv4,ihl,DC_TYPE,perightbelow,28, C . MPI_COMM_EULAG,status, ierr) C#else CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,25, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,25, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,26, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,26, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,27, . tmpcorrcv3,ihl,DC_TYPE,perightabove,27, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,28, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,28, . MPI_COMM_EULAG,status,ierr) C#endif #endif #endif icnt=1 if (leftedge.eq.0 .and. botedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) c if (i.eq.ihr .and. j.eq.ihr .and. k.eq.11) c . icntkp=icnt icnt=icnt+1 end do end do end do c if (mype.eq.26) then c write(*,*)'***tmpcorsnd1(icntkp),tmpcorsnd1(icntkp+1)=', c . tmpcorsnd1(icntkp),tmpcorsnd1(icntkp+1) c end if else if (leftedge.eq.1 .and. botedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr-ior,j-ihr,k)=tmpcorrcv1(icnt) icnt=icnt+1 end do end do end do else if (leftedge.eq.0 .and. botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr-ior,k)=tmpcorrcv1(icnt) icnt=icnt+1 end do end do end do else if (leftedge.eq.1 .and. botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr-ior,j-ihr-ior,k)=tmpcorrcv1(icnt) icnt=icnt+1 end do end do end do end if icnt=1 if (leftedge.eq.0 .and. topedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) icnt=icnt+1 end do end do end do else if (leftedge.eq.1 .and. topedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr-ior,m1+j,k)=tmpcorrcv2(icnt) icnt=icnt+1 end do end do end do else if (leftedge.eq.0 .and. topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,m1+j+ior,k)=tmpcorrcv2(icnt) icnt=icnt+1 end do end do end do else if (leftedge.eq.1 .and. topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr-ior,m1+j+ior,k)=tmpcorrcv2(icnt) icnt=icnt+1 end do end do end do end if c icnt=1 if (rightedge.eq.0 .and. topedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i,m1+j,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.1 .and. topedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i+ior,m1+j,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.0 .and. topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i,m1+j+ior,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.1 .and. topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i+ior,m1+j+ior,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do end if icnt=1 if (rightedge.eq.0 .and. botedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.1 .and. botedge.eq.0) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i+ior,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.0 .and. botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i,j-ihr-ior,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (rightedge.eq.1 .and. botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(n1+i+ior,j-ihr-ior,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do end if #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(72) #endif #if (DIAGPLT == 1) print *,'OUT UPDATELAGR',mype #endif return end #endif subroutine updatebt(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPDATEBT',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(73) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=n1*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below :tmpxsnd1 c prepare upper data segments for processor above:tmpxsnd2 c------------------------------------------------------------------- c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 #if (PARALLEL == 0) c tmpxrcv1=a(i, j,k) c tmpxrcv2=a(i,m1-ihr+j,k) c a(i, m1+j,k)=tmpxrcv1 c a(i,-ihr+j,k)=tmpxrcv2 a(i, m1+j,k)=a(i, j,k) a(i,-ihr+j,k)=a(i,m1-ihr+j,k) #else tmpxsnd1(icnt)=a(i, j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,nhl,peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl,pebelow) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,31,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,31,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpxsnd2,nhl,DC_TYPE,peabove,32,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,32,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,31,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd1,nhl,DC_TYPE,pebelow,31,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,32,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpxsnd2,nhl,DC_TYPE,peabove,32,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,31, . tmpxrcv1,nhl,DC_TYPE,peabove,31,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,32, . tmpxrcv2,nhl,DC_TYPE,pebelow,32,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do k=1,l1 do j=1,ihr do i=1,n1 a(i, m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(73) #endif #if (DIAGPLT == 1) print *,'OUT UPDATEBT',mype #endif return end subroutine updatelr(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif #if (DIAGPLT == 1) print *,'UPDATELR',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(74) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- mhl=ihr*m1*l1 c c------------------------------------------------------------------- c prepare left data segments for processor on the left :tmpysnd1 c prepare right data segments for processor to the right:tmpysnd2 c------------------------------------------------------------------- c icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 #if (PARALLEL == 0) c tmpyrcv1=a( i,j,k) c tmpyrcv2=a(n1-ihr+i,j,k) c a( n1+i,j,k)=tmpyrcv1 c a(-ihr+i,j,k)=tmpyrcv2 a( n1+i,j,k)=a( i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) #else tmpysnd1(icnt)=a( i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 #endif end do end do end do #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #endif #if (PARALLEL == 2) C#if (SGI_O2K == 0) C call mybarrier() C#endif #if (ISEND == 3) call MPI_ISEND(tmpysnd1,mhl,DC_TYPE,peleft,33,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,33,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) call MPI_ISEND(tmpysnd2,mhl,DC_TYPE,peright,34,MPI_COMM_EULAG, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,34,MPI_COMM_EULAG, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 2) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,33,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd1,mhl,DC_TYPE,peleft,33,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,34,MPI_COMM_EULAG, . statr,ierr) call MPI_SEND(tmpysnd2,mhl,DC_TYPE,peright,34,MPI_COMM_EULAG, . ierr) call MPI_WAIT(statr,status,ierr) #endif #if (ISEND == 1) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,33, . tmpyrcv1,mhl,DC_TYPE,peright,33,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,34, . tmpyrcv2,mhl,DC_TYPE,peleft,34,MPI_COMM_EULAG, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do j=1,m1 do i=1,ihr do k=1,l1 a( n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(74) #endif #if (DIAGPLT == 1) print *,'OUT UPDATELR',mype #endif return end #else /* POLES */ #if (SEMILAG == 1) subroutine updatelagr(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' parameter (l3=l+2*ior) dimension a(1-ihlag-ior:ndim+ihlag+ior, . 1-ihlag-ior:mdim+ihlag+ior,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updlagr/ tmpxsnd1((np+2*ior)*ihlag*l3), . tmpxsnd2((np+2*ior)*ihlag*l3), . tmpysnd1((mp+2*ior)*ihlag*l3), . tmpysnd2((mp+2*ior)*ihlag*l3), . tmpcorsnd1(ihlag*ihlag*l3), . tmpcorsnd2(ihlag*ihlag*l3), . tmpcorsnd3(ihlag*ihlag*l3), . tmpcorsnd4(ihlag*ihlag*l3), . tmpxrcv1((np+2*ior)*ihlag*l3), . tmpxrcv2((np+2*ior)*ihlag*l3), . tmpyrcv1((mp+2*ior)*ihlag*l3), . tmpyrcv2((mp+2*ior)*ihlag*l3), . tmpcorrcv1(ihlag*ihlag*l3), . tmpcorrcv2(ihlag*ihlag*l3), . tmpcorrcv3(ihlag*ihlag*l3), . tmpcorrcv4(ihlag*ihlag*l3) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATE',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(72) #endif ihr=min(ihlag,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- if (leftedge.eq.1) then illim=1-ior else illim=1 end if if (rightedge.eq.1) then iulim=n1+ior else iulim=n1 end if if (botedge.eq.1) then jllim=1-ior else jllim=1 end if if (topedge.eq.1) then julim=m1+ior else julim=m1 end if nhl=(iulim-illim+1)*ihr*l1 mhl=(julim-jllim+1)*ihr*l1 ihl=(ihr*ihr*l1) #if (PARALLEL == 0) do i=illim,iulim do j=1,ihr do k=1,l1 tmpxrcv1=a(ip(i), j,k) tmpxrcv2=a(ip(i),m1+1-j,k) a(i, 1-j,k)=tmpxrcv1 a(i,m1+j,k)=tmpxrcv2 end do end do end do do i=1,ihr do j=jllim,julim do k=1,l1 tmpyrcv1=a(i,j,k) tmpyrcv2=a(n1-ihr+i,j,k) a(n1+i,j,k)=tmpyrcv1 a(-ihr+i,j,k)=tmpyrcv2 end do end do end do do i=1,ihr do j=1,ihr do k=1,l1 tmpcorrcv1=a(ip(n1-ihr+i), j,k) tmpcorrcv2=a(ip(n1-ihr+i),m1+1-j,k) tmpcorrcv3=a(ip(i) ,m1+1-j,k) tmpcorrcv4=a(ip(i) , j,k) a(i-ihr, 1-j,k)=tmpcorrcv1 a(i-ihr,m1+j,k)=tmpcorrcv2 a( n1+i,m1+j,k)=tmpcorrcv3 a( n1+i, 1-j,k)=tmpcorrcv4 end do end do end do #else c--------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c--------------------------------------------------------- icnt=1 if (nprocx.eq.1) then if (botedge.eq.1) then do i=illim,iulim do j=1,ihr do k=1,l1 a(i,1-j,k)=a(ip(i),j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do else if (topedge.eq.1) then do i=illim,iulim do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) a(i,m1+j,k)=a(ip(i),m1+1-j,k) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else do i=illim,iulim do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- if (nprocx.eq.1) then do i=1,ihr do j=jllim,julim do k=1,l1 a(n1+i,j,k)=a(i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do else icnt=1 do i=1,ihr do j=jllim,julim do k=1,l1 tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 end do end do end do endif c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then call shmem_get32(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then call shmem_get64(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #else if(nprocx.gt.1) then call shmem_get(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocy.gt.1) then if (botedge.eq.1) then call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif else if (topedge.eq.1) then call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif else call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) endif else !nprocy=1 and nprocx>1 (if nprocx=1 PARALLEL=0 no updates) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif if(nprocx.gt.1) then call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) endif #endif c c store data in main array now c icnt=1 if (nprocy.gt.1) then if (botedge.eq.1) then !-------------------BOTTOM-------- if (nprocx.eq.1) then do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif else if (topedge.eq.1) then !-------------TOP---------- if (nprocx.eq.1) then do i=illim,iulim do j=1,ihr do k=1,l1 a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, -ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else !---------------------------------MIDLE--------- do i=illim,iulim do j=1,ihr do k=1,l1 a(i, m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif !----------------------------------------------- else !nprocy=1 do i=illim,iulim do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif if (nprocx.gt.1) then icnt=1 do i=1,ihr do j=jllim,julim do k=1,l1 a( n1+i, j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do endif c--------------------------------------- c now send and receive corner pieces c--------------------------------------- if (nprocx.eq.1) then if (topedge.eq.1) then icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) a(i-ihr,m1+j,k)=a(ip(n1-ihr+i),m1+1-j,k) a(n1+i, m1+j,k)=a(ip(i) ,m1+1-j,k) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) a(i-ihr, 1-j,k)=a(ip(n1-ihr+i),j,k) a(n1+i, 1-j,k)=a(ip(i) ,j,k) icnt=icnt+1 end do end do end do else icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else !nprocx=1 icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if (nprocx.eq.1) then c updates on poles are just done call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get32(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get32(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get32(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get32(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get32(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get32(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #if (SGI_O2K == 2) if (nprocx.eq.1) then c updates on poles are just done call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get64(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get64(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get64(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get64(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get64(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get64(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #else if (nprocx.eq.1) then c updates on poles are just done call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #endif #if (PARALLEL == 2) call mybarrier() if (nprocx.eq.1) then c updates on poles are just done if (topedge.eq.1) then call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) else if (botedge.eq.1) then call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) else call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) endif else !nprocx>1 if (nprocy.gt.1) then if (topedge.eq.1) then call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,peleftabove,19, . tmpcorrcv2,ihl,DC_TYPE,perightabove,19, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,perightabove,20, . tmpcorrcv3,ihl,DC_TYPE,peleftabove,20, . MPI_COMM_EULAG,status,ierr) else if (botedge.eq.1) then call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,perightbelow,21, . tmpcorrcv4,ihl,DC_TYPE,peleftbelow,21, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,peleftbelow,22, . tmpcorrcv1,ihl,DC_TYPE,perightbelow,22, . MPI_COMM_EULAG,status,ierr) else call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) endif else !nprocy=1 call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,peleftabove,19, . tmpcorrcv2,ihl,DC_TYPE,perightabove,19, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,perightabove,20, . tmpcorrcv3,ihl,DC_TYPE,peleftabove,20, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,perightbelow,21, . tmpcorrcv4,ihl,DC_TYPE,peleftbelow,21, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,peleftbelow,22, . tmpcorrcv1,ihl,DC_TYPE,perightbelow,22, . MPI_COMM_EULAG,status,ierr) endif !nprocy endif !nprocx #endif icnt=1 if (nprocx.gt.1) then if (nprocy.gt.1) then if (topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, -ihr+j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+1+ihr-j,k)=tmpcorrcv2(icnt) a(n1+i ,m1+1+ihr-j,k)=tmpcorrcv3(icnt) a(n1+i , -ihr+j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, 1-j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i ,m1+j,k)=tmpcorrcv3(icnt) a(n1+i , 1-j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) a(i-ihr,m1+j ,k)=tmpcorrcv2(icnt) a(n1+i ,m1+j ,k)=tmpcorrcv3(icnt) a(n1+i ,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif else !nprocy=1 do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, 1-j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+1+ihr-j,k)=tmpcorrcv2(icnt) a(n1+i, m1+1+ihr-j,k)=tmpcorrcv3(icnt) a(n1+i, 1-j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif !nprocy else !nprocx=1 if (topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,-ihr+j,k)=tmpcorrcv1(icnt) a(n1+i, -ihr+j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i, m1+j,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) a(i-ihr, m1+j,k)=tmpcorrcv2(icnt) a(n1+i, m1+j,k)=tmpcorrcv3(icnt) a(n1+i, j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif endif !nprocx #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(72) #endif #if (DIAGPLT == 1) print *,'UPDATELAG DONE',mype #endif return end #endif subroutine updatebtw(a,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' #include "msg.lnk" dimension a(ndim1-ih:ndim2+ih, mdim1-ih:mdim2+ih,l1) #if (PARALLEL > 0) #if (PARALLEL == 2) #if (SGI_O2K > 0) integer stats,statr #endif #endif common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATEW',mype,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg #endif #if (TIMEPLT == 1) call ttbeg(70) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- c nhl=n1*ihr*l1 nhl=(n2-n1+1)*ihr*l1 ihl=ihr*ihr*l1 #if (PARALLEL == 0) do i=n1,n2 !mod check - modified dim for ip(0) case c do i=1,n1 do j=1,ihr do k=1,l1 tmpxrcv1=a(ip(i), j,k) tmpxrcv2=a(ip(i),m2+1-j,k) c tmpxrcv2=a(ip(i),m1+ihr-j,k) a(i, m1-j,k)=tmpxrcv1 c a(i, 1-j,k)=tmpxrcv1 a(i,m2+j,k)=tmpxrcv2 c a(i,m1+j,k)=tmpxrcv2 end do end do end do #else /* (PARALLEL == 0) */ c--------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c--------------------------------------------------------- icnt=1 if (nprocx.eq.1) then if (botedge.eq.1) then do i=n1,n2 !mod check - modified dim for ip(0) case c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1-j,k)=a(ip(n),j,k) a(i,m1-j,k)=a(ip(i),j,k) c a(i,1-j,k)=a(ip(i),j,k) tmpxsnd2(icnt)=a(i,m2-ihr+j,k) c tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do else if (topedge.eq.1) then do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) a(i,m2+j,k)=a(ip(i),m2+1-j,k) c a(i,m1+j,k)=a(ip(i),m1+1-j,k) icnt=icnt+1 end do end do end do else do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m2-ihr+j,k) c tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m2-ihr+j,k) c tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #else /* SGI_O2K > 0 */ if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif /* SGI_O2K > 0 */ #endif /* PARALLEL == 1 */ #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocy.gt.1) then if (botedge.eq.1) then ! print *,'MPI_Sendrecv A:',nhl,DC_TYPE,peabove,14,13 call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then ! print *,'MPI_Sendrecv B:',nhl,DC_TYPE,pebelow,11 call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif else if (topedge.eq.1) then ! print *,'MPI_Sendrecv C:',nhl,DC_TYPE,pebelow,13,14 call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then ! print *,'MPI_Sendrecv D:',nhl,DC_TYPE,peabove,12 call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif else call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) endif else !nprocy=1 and nprocx>1 (if nprocx=1 PARALLEL=0 no updates) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif ! print *,'MPI_Sendrecv F DONE' #endif /* PARALLEL == 2 */ c c store data in main array now c icnt=1 if (nprocy.gt.1) then if (botedge.eq.1) then !-------------------BOTTOM-------- if (nprocx.eq.1) then do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m2+j,k)=tmpxrcv1(icnt) c a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m2+j,k)=tmpxrcv1(icnt) c a(i,m1+j,k)=tmpxrcv1(icnt) a(i, m1-j,k)=tmpxrcv2(icnt) !south pole c a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif else if (topedge.eq.1) then !-------------TOP---------- if (nprocx.eq.1) then do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1-1-ihr+j,k)=tmpxrcv2(icnt) c a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m2+1+ihr-j,k)=tmpxrcv1(icnt) !north pole c a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i,m1-1-ihr+j,k)=tmpxrcv2(icnt) c a(i, -ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else !---------------------------------MIDLE--------- do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i, m2+j,k)=tmpxrcv1(icnt) c a(i, m1+j,k)=tmpxrcv1(icnt) a(i,m1-1-ihr+j,k)=tmpxrcv2(icnt) c a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif !----------------------------------------------- else !nprocy=1 do i=n1,n2 c do i=1,n1 do j=1,ihr do k=1,l1 a(i,m2+1+ihr-j,k)=tmpxrcv1(icnt) !north pole c a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, m1-j,k)=tmpxrcv2(icnt) !south pole c a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif /* (PARALLEL == 0) */ #if (TIMEPLT == 1) call ttend(70) #endif #if (DIAGPLT == 1) print *,'UPDATE DONE 1',mype #endif return end subroutine updatelrw(a,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' #include "msg.lnk" dimension a(ndim1-ih:ndim2+ih, mdim1-ih:mdim2+ih,l1) #if (PARALLEL > 0) #if (PARALLEL == 2) #if (SGI_O2K > 0) integer stats,statr #endif #endif common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATEW',mype,n1,n2,m1,m2,l1,ndim1,ndim2,mdim1,mdim2,ihg #endif #if (TIMEPLT == 1) call ttbeg(70) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- c mhl=ihr*m1*l1 mhl=ihr*(m2-m1+1)*l1 ihl=ihr*ihr*l1 #if (PARALLEL == 0) do i=1,ihr do j=m1,m2 c do j=1,m1 do k=1,l1 tmpyrcv1=a(i,j,k) tmpyrcv2=a(n2-ihr+i,j,k) c tmpyrcv2=a(n1-ihr+i,j,k) a(n2+i,j,k)=tmpyrcv1 c a(n1+i,j,k)=tmpyrcv1 a(n1-1-ihr+i,j,k)=tmpyrcv2 c a(-ihr+i,j,k)=tmpyrcv2 end do end do end do #else c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- if (nprocx.eq.1) then do i=1,ihr do j=m1,m2 c do j=1,m1 do k=1,l1 a(n2+i,j,k)=a(i,j,k) c a(n1+i,j,k)=a(i,j,k) a(n1-1-ihr+i,j,k)=a(n2-ihr+i,j,k) c a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do else icnt=1 do i=1,ihr do j=m1,m2 c do j=1,m1 do k=1,l1 tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n2-ihr+i,j,k) c tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 end do end do end do endif c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then call shmem_get32(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl, peleft) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then call shmem_get64(tmpyrcv1,tmpysnd1,mhl peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl peleft) endif !nprocx #endif #else if(nprocx.gt.1) then call shmem_get(tmpyrcv1,tmpysnd1,mhl peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl peleft) endif !nprocx #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocx.gt.1) then ! print *,'MPI_Sendrecv E:',mhl,DC_TYPE,peleft,3,peright call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) ! print *,'MPI_Sendrecv F:',mhl,DC_TYPE,peright,4,peleft call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) endif ! print *,'MPI_Sendrecv F DONE' #endif c c store data in main array now c if (nprocx.gt.1) then icnt=1 do i=1,ihr do j=m1,m2 c do j=1,m1 do k=1,l1 a( n2+i,j,k)=tmpyrcv1(icnt) c a( n1+i,j,k)=tmpyrcv1(icnt) a(n1-1-ihr+i,j,k)=tmpyrcv2(icnt) c a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif /* (PARALLEL == 0) */ #if (TIMEPLT == 1) call ttend(70) #endif #if (DIAGPLT == 1) print *,'UPDATE DONE 2',mype #endif return end subroutine update(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATE 3',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(70) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big c array. c------------------------------------------------------------------- nhl=n1*ihr*l1 mhl=ihr*m1*l1 ihl=ihr*ihr*l1 #if (PARALLEL == 0) do i=1,n1 do j=1,ihr do k=1,l1 tmpxrcv1=a(ip(i), j,k) tmpxrcv2=a(ip(i),m1+1-j,k) c tmpxrcv2=a(ip(i),m1+ihr-j,k) a(i, 1-j,k)=tmpxrcv1 a(i,m1+j,k)=tmpxrcv2 end do end do end do do i=1,ihr do j=1,m1 do k=1,l1 tmpyrcv1=a(i,j,k) tmpyrcv2=a(n1-ihr+i,j,k) a(n1+i,j,k)=tmpyrcv1 a(-ihr+i,j,k)=tmpyrcv2 end do end do end do do i=1,ihr do j=1,ihr do k=1,l1 tmpcorrcv1=a(ip(n1-ihr+i), j,k) tmpcorrcv2=a(ip(n1-ihr+i),m1+1-j,k) tmpcorrcv3=a(ip(i) ,m1+1-j,k) tmpcorrcv4=a(ip(i) , j,k) a(i-ihr, 1-j,k)=tmpcorrcv1 a(i-ihr,m1+j,k)=tmpcorrcv2 a(n1+i,m1+j,k)=tmpcorrcv3 a(n1+i, 1-j,k)=tmpcorrcv4 end do end do end do #else c--------------------------------------------------------- c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c--------------------------------------------------------- icnt=1 if (nprocx.eq.1) then if (botedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,1-j,k)=a(ip(i),j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do else if (topedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) a(i,m1+j,k)=a(ip(i),m1+1-j,k) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif c------------------------------------------------------------------- c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c------------------------------------------------------------------- if (nprocx.eq.1) then do i=1,ihr do j=1,m1 do k=1,l1 a(n1+i,j,k)=a(i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do else icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 end do end do end do endif c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then call shmem_get32(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then call shmem_get64(tmpyrcv1,tmpysnd1,mhl peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl peleft) if(nprocy.gt.1) then call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #else if(nprocx.gt.1) then call shmem_get(tmpyrcv1,tmpysnd1,mhl peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl peleft) if(nprocy.gt.1) then call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocy.gt.1) then if (botedge.eq.1) then ! print *,'MPI_Sendrecv A:',nhl,DC_TYPE,peabove,14,13 call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then ! print *,'MPI_Sendrecv B:',nhl,DC_TYPE,pebelow,11 call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif else if (topedge.eq.1) then ! print *,'MPI_Sendrecv C:',nhl,DC_TYPE,pebelow,13,14 call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then ! print *,'MPI_Sendrecv D:',nhl,DC_TYPE,peabove,12 call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif else call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) endif else !nprocy=1 and nprocx>1 (if nprocx=1 PARALLEL=0 no updates) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif if(nprocx.gt.1) then ! print *,'MPI_Sendrecv E:',mhl,DC_TYPE,peleft,3,peright call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) ! print *,'MPI_Sendrecv F:',mhl,DC_TYPE,peright,4,peleft call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) endif ! print *,'MPI_Sendrecv F DONE' #endif c c store data in main array now c icnt=1 if (nprocy.gt.1) then if (botedge.eq.1) then !-------------------BOTTOM-------- if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif else if (topedge.eq.1) then !-------------TOP---------- if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, -ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else !---------------------------------MIDLE--------- do i=1,n1 do j=1,ihr do k=1,l1 a(i, m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif !----------------------------------------------- else !nprocy=1 do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif if (nprocx.gt.1) then icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 a( n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do endif c--------------------------------------- c now send and receive corner pieces c--------------------------------------- if (nprocx.eq.1) then ! n=mp if (topedge.eq.1) then icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) a(i-ihr,m1+j,k)=a(ip(n1-ihr+i),m1+1-j,k) a(n1+i,m1+j,k)=a(ip(i) ,m1+1-j,k) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) a(i-ihr, 1-j,k)=a(ip(n1-ihr+i),j,k) a(n1+i, 1-j,k)=a(ip(i) ,j,k) icnt=icnt+1 end do end do end do else icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else !nprocx=1 icnt=1 do i=1,ihr do j=1,ihr do k=1,l1 tmpcorsnd1(icnt)=a(n1-ihr+i,m1-ihr+j,k) tmpcorsnd2(icnt)=a(n1-ihr+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) tmpcorsnd4(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if (nprocx.eq.1) then c updates on poles are just done call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get32(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get32(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get32(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get32(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get32(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get32(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get32(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #if (SGI_O2K == 2) if (nprocx.eq.1) then c updates on poles are just done call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get64(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get64(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get64(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get64(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get64(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get64(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get64(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #else if (nprocx.eq.1) then c updates on poles are just done call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) else !nprocx>1 if (nprocy.gt.1) then call shmem_get(tmpcorrcv1,tmpcorsnd1,ihl, peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,ihl, peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,ihl, perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,ihl, perightbelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) else if (botedge.eq.1) then call shmem_get(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif else !nprocy=1 c updates poles only call shmem_get(tmpcorrcv1,tmpcorsnd2,ihl, perightbelow) call shmem_get(tmpcorrcv2,tmpcorsnd1,ihl, perightabove) call shmem_get(tmpcorrcv3,tmpcorsnd4,ihl, peleftabove) call shmem_get(tmpcorrcv4,tmpcorsnd3,ihl, peleftbelow) endif !nprocy endif !nprocx #endif #endif #if (PARALLEL == 2) call mybarrier() if (nprocx.eq.1) then c updates on poles are just done if (topedge.eq.1) then call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) else if (botedge.eq.1) then call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) else call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) endif else !nprocx>1 if (nprocy.gt.1) then if (topedge.eq.1) then ! print *,'MPI_Sendrecv G:',ihl,perightbelow,16,peleftbelow call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv H:',ihl,peleftbelow,17,perightbelow call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv I:',ihl,peleftabove,19,perightabove call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,peleftabove,19, . tmpcorrcv2,ihl,DC_TYPE,perightabove,19, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv J:',ihl,perightabove,20,peleftabove call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,perightabove,20, . tmpcorrcv3,ihl,DC_TYPE,peleftabove,20, . MPI_COMM_EULAG,status,ierr) else if (botedge.eq.1) then ! print *,'MPI_Sendrecv K:',ihl,perightabove,15,peleftabove call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv L:',ihl,peleftabove,18,perightabove call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv M:',ihl,perightbelow,21,peleftbelow call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,perightbelow,21, . tmpcorrcv4,ihl,DC_TYPE,peleftbelow,21, . MPI_COMM_EULAG,status,ierr) ! print *,'MPI_Sendrecv N:',ihl,peleftbelow,22,perightbelow call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,peleftbelow,22, . tmpcorrcv1,ihl,DC_TYPE,perightbelow,22, . MPI_COMM_EULAG,status,ierr) else call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,15, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,15, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,16, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,16, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,17, . tmpcorrcv3,ihl,DC_TYPE,perightabove,17, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,18, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,18, . MPI_COMM_EULAG,status,ierr) endif else !nprocy=1 call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,peleftabove,19, . tmpcorrcv2,ihl,DC_TYPE,perightabove,19, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,perightabove,20, . tmpcorrcv3,ihl,DC_TYPE,peleftabove,20, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,perightbelow,21, . tmpcorrcv4,ihl,DC_TYPE,peleftbelow,21, . MPI_COMM_EULAG,status,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,peleftbelow,22, . tmpcorrcv1,ihl,DC_TYPE,perightbelow,22, . MPI_COMM_EULAG,status,ierr) endif !nprocy endif !nprocx ! print *,'MPI_Sendrecv P DONE:' #endif icnt=1 if (nprocx.gt.1) then if (nprocy.gt.1) then if (topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, -ihr+j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+1+ihr-j,k)=tmpcorrcv2(icnt) a(n1+i,m1+1+ihr-j,k)=tmpcorrcv3(icnt) a(n1+i, -ihr+j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, 1-j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i,m1+j,k)=tmpcorrcv3(icnt) a(n1+i, 1-j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i,m1+j,k)=tmpcorrcv3(icnt) a(n1+i,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif else !nprocy=1 do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr, 1-j,k)=tmpcorrcv1(icnt) a(i-ihr,m1+1+ihr-j,k)=tmpcorrcv2(icnt) a(n1+i,m1+1+ihr-j,k)=tmpcorrcv3(icnt) a(n1+i, 1-j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif !nprocy else !nprocx=1 if (topedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,-ihr+j,k)=tmpcorrcv1(icnt) a(n1+i,-ihr+j,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do else if (botedge.eq.1) then do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i,m1+j,k)=tmpcorrcv3(icnt) icnt=icnt+1 end do end do end do else do i=1,ihr do j=1,ihr do k=1,l1 a(i-ihr,j-ihr,k)=tmpcorrcv1(icnt) a(i-ihr,m1+j,k)=tmpcorrcv2(icnt) a(n1+i,m1+j,k)=tmpcorrcv3(icnt) a(n1+i,j-ihr,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do endif endif !nprocx #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(70) #endif #if (DIAGPLT == 1) print *,'UPDATE DONE 3',mype #endif return end subroutine update2(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATE2',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(71) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=n1*ihr*l1 mhl=m1*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below: tmpxsnd1 c prepare top segments for processor above : tmpxsnd2 c------------------------------------------------------------------- c icnt=1 #if (PARALLEL == 0) do i=1,n1 do j=1,ihr do k=1,l1 tmpxrcv1=a(ip(i), j,k) tmpxrcv2=a(ip(i),m1+1-j,k) a(i, 1-j,k)=tmpxrcv1 a(i,m1+j,k)=tmpxrcv2 end do end do end do do i=1,ihr do j=1,m1 do k=1,l1 tmpyrcv1=a(i,j,k) tmpyrcv2=a(n1-ihr+i,j,k) a(n1+i,j,k)=tmpyrcv1 a(-ihr+i,j,k)=tmpyrcv2 c a(n1+i,j,k)=a(i,j,k) c a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do #else if (nprocx.eq.1) then if (botedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,1-j,k)=a(ip(i),j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do else if (topedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) a(i,m1+j,k)=a(ip(i),m1+1-j,k) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif c-------------------------------------------------------------------- c prepare left data segments for processor on the left :tmpysnd1 c prepare right data segments for processor to the right:tmpysnd2 c-------------------------------------------------------------------- if (nprocx.eq.1) then do i=1,ihr do j=1,m1 do k=1,l1 a(n1+i,j,k)=a(i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do else icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 end do end do end do endif c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then call shmem_get32(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then call shmem_get64(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #else if(nprocx.gt.1) then call shmem_get(tmpyrcv1,tmpysnd1,mhl, peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl, peleft) if(nprocy.gt.1) then call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocy.gt.1) then if (botedge.eq.1) then !BOTEDGE call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif else if (topedge.eq.1) then !TOPEDGE call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) if (nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif else !MIDDLE call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) endif !DONE else !nprocy=1 and nprocx>1 (if nprocx=1 PARALLEL=0 no updates) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif if(nprocx.gt.1) then call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) endif #endif c c store data in main array now c icnt=1 if (nprocy.gt.1) then if (botedge.eq.1) then if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif else if (topedge.eq.1) then if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, -ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else do i=1,n1 do j=1,ihr do k=1,l1 a(i, m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else !nprocy=1 do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif if (nprocx.gt.1) then icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 a(n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(71) #endif #if (DIAGPLT == 1) print *,'UPDATE2 DONE',mype #endif return end subroutine updatebt(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATEBT',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(73) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- nhl=n1*ihr*l1 c c------------------------------------------------------------------- c prepare bottom segments for processor below :tmpxsnd1 c prepare upper data segments for processor above:tmpxsnd2 c------------------------------------------------------------------- c icnt=1 #if (PARALLEL == 0) do i=1,n1 do j=1,ihr do k=1,l1 tmpxrcv1=a(ip(i), j,k) tmpxrcv2=a(ip(i),m1+1-j,k) a(i, 1-j,k)=tmpxrcv1 a(i,m1+j,k)=tmpxrcv2 end do end do end do #else if (nprocx.eq.1) then if (botedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,1-j,k)=a(ip(i),j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do else if (topedge.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) a(i,m1+j,k)=a(ip(i),m1+1-j,k) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif else do i=1,n1 do j=1,ihr do k=1,l1 tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihr+j,k) icnt=icnt+1 end do end do end do endif #endif #if (PARALLEL > 0) c c exchange data now c #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get32(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get32(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #if (SGI_O2K == 2) if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get64(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get64(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #else if(nprocx.gt.1) then if(nprocy.gt.1) then call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) c updates poles only if (topedge.eq.1) then call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) else if (botedge.eq.1) then call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocy=1 call shmem_get(tmpxrcv1,tmpxsnd2,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd1,nhl, pebelow) endif else !nprocx=1 and nprocy>1 (if nprocy=1 PARALLEL=0 no updates) c updates on poles are just done call shmem_get(tmpxrcv1,tmpxsnd1,nhl, peabove) call shmem_get(tmpxrcv2,tmpxsnd2,nhl, pebelow) endif !nprocx #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif if(nprocy.gt.1) then if (botedge.eq.1) then call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) if(nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) endif else if (topedge.eq.1) then call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) if(nprocx.gt.1) then call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif else call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,13, . tmpxrcv1,nhl,DC_TYPE,peabove,13,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,14, . tmpxrcv2,nhl,DC_TYPE,pebelow,14,MPI_COMM_EULAG, . status,ierr) endif else !nprocy=1 and nprocx>1 (if nprocx=1 PARALLEL=0 no updates) call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv2,nhl,DC_TYPE,pebelow,11,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv1,nhl,DC_TYPE,peabove,12,MPI_COMM_EULAG, . status,ierr) endif #endif c c store data in main array now c icnt=1 if (nprocy.gt.1) then if (botedge.eq.1) then if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i,1-j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else if (topedge.eq.1) then if (nprocx.eq.1) then do i=1,n1 do j=1,ihr do k=1,l1 a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i,-ihr+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do endif else !nprocy=1 do i=1,n1 do j=1,ihr do k=1,l1 a(i,m1+1+ihr-j,k)=tmpxrcv1(icnt) !north pole a(i, 1-j,k)=tmpxrcv2(icnt) !south pole icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(73) #endif #if (DIAGPLT == 1) print *,'UPDATEBT DONE',mype #endif return end subroutine updatelr(a,n1,m1,l1,ndim,mdim,ihg) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c include 'param.nml' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) #include "msg.lnk" common /updblk/ tmpxsnd1((np+2)*ih*(l+2)), . tmpxsnd2((np+2)*ih*(l+2)), . tmpysnd1((mp+2)*ih*(l+2)), . tmpysnd2((mp+2)*ih*(l+2)), . tmpcorsnd1(ih*ih*(l+2)), . tmpcorsnd2(ih*ih*(l+2)), . tmpcorsnd3(ih*ih*(l+2)), . tmpcorsnd4(ih*ih*(l+2)), . tmpxrcv1((np+2)*ih*(l+2)), . tmpxrcv2((np+2)*ih*(l+2)), . tmpyrcv1((mp+2)*ih*(l+2)), . tmpyrcv2((mp+2)*ih*(l+2)), . tmpcorrcv1(ih*ih*(l+2)), . tmpcorrcv2(ih*ih*(l+2)), . tmpcorrcv3(ih*ih*(l+2)), . tmpcorrcv4(ih*ih*(l+2)) #endif common/cyclpole/ irlyq,irlyt,ip(0:n) !mod check #if (DIAGPLT == 1) print *,'UPDATELR',mype,n1,m1,l1,ndim,mdim,ihg #endif #if (TIMEPLT == 1) call ttbeg(74) #endif ihr=min(ih,ihg) #if (PARALLEL == 1) call shmem_set_cache_inv() #endif c------------------------------------------------------------------- c there are four border segments that must be sent and received. c first, we copy from the large array to the tmp arrays for c sending. next, we send our four border segments to surrounding c processors. then, we receive the four segments from the c surrounding processors and we copy that data to the big array. c------------------------------------------------------------------- mhl=ihr*m1*l1 #if (PARALLEL == 0) do i=1,ihr do j=1,m1 do k=1,l1 c tmpyrcv1=a( i,j,k) c tmpyrcv2=a(n1-ihr+i,j,k) c a( n1+i,j,k)=tmpyrcv1 c a(-ihr+i,j,k)=tmpyrcv2 a( n1+i,j,k)=a( i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do #else if (nprocx.eq.1) then do i=1,ihr do j=1,m1 do k=1,l1 a( n1+i,j,k)=a( i,j,k) a(-ihr+i,j,k)=a(n1-ihr+i,j,k) end do end do end do else c-------------------------------------------------------------------- c prepare left data segments for processor on the left :tmpysnd1 c prepare right data segments for processor to the right:tmpysnd2 c-------------------------------------------------------------------- icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ihr+i,j,k) icnt=icnt+1 end do end do end do c---------------------- c exchange data now c---------------------- #if (PARALLEL == 1) c call shmem_udcflush() call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get32(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get64(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #else call shmem_get(tmpyrcv1,tmpysnd1,mhl,peright) call shmem_get(tmpyrcv2,tmpysnd2,mhl,peleft) #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_EULAG, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_EULAG, . status,ierr) #endif c--------------------------------- c store data in main array now c--------------------------------- icnt=1 do i=1,ihr do j=1,m1 do k=1,l1 a( n1+i,j,k)=tmpyrcv1(icnt) a(-ihr+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do endif #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif #if (TIMEPLT == 1) call ttend(74) #endif #if (DIAGPLT == 1) print *,'UPDATELR DONE',mype #endif return end #endif /* POLES */ C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C F U N C T I O N S C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C+++++++++++++++++++++++++ C T I M E function C+++++++++++++++++++++++++ subroutine timefun() include 'param.nml' include 'msg.inc' #if (IBM > 0) character*8 timedat,clock_ #else #if (HP > 0 || WORKS > 0 || FUJI_VPP > 0 || CPQ > 0 || LNX >0 || PLE >0) character*24 timedat #else character*8 timedat #endif #endif if (mype.eq.0) then #if (IBM > 0) timedat= clock_() #else #if (HP > 0 || WORKS > 0 || FUJI_VPP > 0 || CPQ > 0 || LNX >0 || PLE >0) call fdate(timedat) #else call clock(timedat) #endif #endif write(*,*)'*** date: ',timedat end if return end subroutine ttini() parameter(ntimerb=86) real*8 rtimerb(ntimerb) real*8 rtimer0(ntimerb) character*(10)clabels(ntimerb) integer icounts(ntimerb) common/timerx/rtimerb,rtimer0,clabels,icounts do i=1,ntimerb rtimerb(i)=0. rtimer0(i)=0. icounts(i)=0 enddo clabels(1)="main " clabels(2)="initial " clabels(3)="timestep " clabels(4)="moistmod " clabels(5)="timetrans " C-------------------------------- clabels(6)="topolog " clabels(7)="metryc " clabels(8)="tinit " clabels(9)="vstrhat " C-------------------------------- clabels(10)="gcrk " clabels(11)="coef0 " clabels(12)="rhsdiv " clabels(13)="prforc " clabels(14)="precon_df " clabels(15)="precon_bcz" clabels(16)="precon_f " clabels(17)="fourier " clabels(18)="fourieri " clabels(19)="tridg " clabels(20)="spcpri " clabels(21)="laplc " C-------------------------------- clabels(22)="rhngck " clabels(23)="rhotad " clabels(24)="velbc " clabels(25)="vbcad " clabels(26)="transav " clabels(27)="potprs " clabels(28)="zonav " clabels(29)="filstr " C-------------------------------- clabels(30)="advec " clabels(31)="mpdata2 " clabels(32)="mpdatm2 " clabels(33)="mp2bc " clabels(34)="mpdata3 " clabels(35)="mpdatm3 " clabels(36)="mp3bc " clabels(36)="interp " clabels(37)="traject " clabels(38)="trajbc " clabels(39)="velprd " C-------------------------------- clabels(40)="dissip " clabels(41)="stressdv " clabels(42)="strainst " clabels(43)="inject " clabels(44)="normalv " clabels(45)="fckflxdv " clabels(46)="tkefrc " clabels(47)="stress " clabels(48)="lapdf " clabels(49)="rical " C-------------------------------- clabels(50)="pertth " clabels(51)="galin " clabels(52)="cndinst " clabels(53)="cond " clabels(54)="adj_prec " clabels(55)="precip " clabels(56)="rain_fall " clabels(57)="advec1d " clabels(58)="rhfld " clabels(59)="totwrt " C-------------------------------- clabels(60)="diagnos " clabels(61)="lipsch " clabels(62)="drag " clabels(63)="sumcns " clabels(64)="ckcyc " clabels(65)="integz " clabels(66)="filtprf " clabels(67)="noise " clabels(68)="rhfld " clabels(69)=" " C-------------------------------- clabels(70)="update " clabels(71)="update2 " clabels(72)="updatelgr " clabels(73)="updatelr " clabels(74)="updatebt " clabels(75)="updatew " clabels(76)="updatewbt " clabels(77)="updatewlr " clabels(78)="globsum " clabels(79)="globmax " clabels(80)="globmin " C-------------------------------- clabels(81)="iorsh " clabels(82)="ioersh " clabels(83)="ioread " clabels(84)="iowrite " clabels(85)="rdtp " clabels(86)="wrtp " return end subroutine ttbeg(icountnr) integer icountnr real*8, external :: rtc parameter(ntimerb=86) real*8 rtimerb(ntimerb) real*8 rtimer0(ntimerb) character*(10)clabels(ntimerb) integer icounts(ntimerb) common/timerx/rtimerb,rtimer0,clabels,icounts rtimer0(icountnr)=rtc() return end subroutine ttend(icountnr) integer icountnr real*8, external :: rtc parameter(ntimerb=86) real*8 rtimerb(ntimerb) real*8 rtimer0(ntimerb) character*(10)clabels(ntimerb) integer icounts(ntimerb) common/timerx/rtimerb,rtimer0,clabels,icounts rtimerb(icountnr)=rtimerb(icountnr)+(rtc()-rtimer0(icountnr)) icounts(icountnr)=icounts(icountnr)+1 return end subroutine ttprt(rank,iprint) integer i,n,ierr,rank,iptint,nprocs parameter(ntimerb=86) real*8 rtimerb(ntimerb) real*8 rtimer0(ntimerb) character*(10)clabels(ntimerb) integer icounts(ntimerb) common/timerx/rtimerb,rtimer0,clabels,icounts if(rank.eq.iprint) then print *,'Pe #, Item #, Count type, # calls, timer' do i=1,ntimerb if(icounts(i).gt.0) then print 99,rank,i,clabels(i),icounts(i),rtimerb(i) endif if((i.eq.5 ).or.(i.eq.9 ).or.(i.eq.21).or.(i.eq.29).or.(i.eq.39) ..or.(i.eq.49).or.(i.eq.59).or.(i.eq.69).or.(i.eq.80)) . print *,'-------------------------------------------------' enddo ! sort print * print 99,rank, 1,clabels( 1),icounts( 1),rtimerb( 1) print 99,rank, 2,clabels( 2),icounts( 2),rtimerb( 2) print 99,rank, 3,clabels( 3),icounts( 3),rtimerb( 3) print 99,rank, 4,clabels( 4),icounts( 4),rtimerb( 4) print 99,rank, 5,clabels( 5),icounts( 5),rtimerb( 5) print 99,rank,30,clabels(30),icounts(30),rtimerb(30) print 99,rank,40,clabels(40),icounts(40),rtimerb(40) print * rtimerb(1)=0. rtimerb(2)=0. rtimerb(3)=0. rtimerb(4)=0. rtimerb(5)=0. rtimerb(30)=0. 77 continue fmax=0. do i=1,ntimerb temp=rtimerb(i) fmax=max(fmax,temp) enddo if(fmax.gt.0.) then do i=1,ntimerb if(icounts(i).gt.0) then if(fmax.eq.rtimerb(i)) then print 99,rank,i,clabels(i),icounts(i),rtimerb(i) rtimerb(i)=0. goto 77 endif endif enddo endif endif 99 format(1x,i4,1x,i4,4x,a10,2x,i8,1x,f12.4) return end C+++++++++++++++++++++++++ C O T H E R functions C+++++++++++++++++++++++++ integer function find_proc_frn(ipx, ipy,ipz) include 'param.nml' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" #endif integer :: nprocxy c c Returns the rank of a process given its position in (ipx,ipy,ipz). c c 16-sep-15/ccyang: coded. c c integer :: ipx, ipy, ipz c nprocxy = nprocx_frn*nprocy_frn find_proc_frn = ipz * nprocxy + ipy * nprocx_frn + ipx c end subroutine find_proc_coord(rank, ipx, ipy) include 'param.nml' include 'msg.inc' ! integer :: rank, ipx, ipy ! ipx = mod(rank, nprocx) ipy = rank/nprocx ! end ! C+++++++++++++++++++++++++ #if (WORKS > 0 || IBM > 0 || HP > 0 || PLE > 0 || CPQ > 0 || LNX >0 ) function cvmgmxx(a,b,c) real a,b,c,cvmgmxx if (c.gt.0.) then cvmgmxx = b else cvmgmxx = a endif return end #endif #if (HP > 0 || PLE > 0 || IBM > 0 || CPQ > 0 || LNX >0) Create function for HP/Convex fortran - for comparability with Cray fortran cf77 and cf90 intrinsic functions function shiftl(a,b) integer a,b integer shiftl create bitwise function shiftl(a,b) for fortran on HP/Convex c a=236, b=1, shiftl(a,b)=472 c [ 1, 2, 4, 8, 16, 32, 64,128][256,512, ... ] c a=[ 0, 0, 1, 1, 0, 1, 1, 1][ 0, 0, 0, 0, 0, 0, 0, 0] c shiftl(a,b)=[ 0, 0, 0, 1, 1, 0, 1, 1][ 1, 0, 0, 0, 0, 0, 0, 0] c ---------------------------------------------------------------- c some unix systems have oposite direction of bit raising ! shiftl=a*(2**b) c print *,'shiftl',a,b,bb,shift,shiftl return end function shiftr(a,b) integer a,b integer shiftr create bitwise function shiftr(a,b) for fortran on HP/Convex c a=236, b=1, shiftr(a,b)=118 c [ 1, 2, 4, 8, 16, 32, 64,128][256,512, ... ] c a=[ 0, 0, 1, 1, 0, 1, 1, 1][ 0, 0, 0, 0, 0, 0, 0, 0] c shiftr(a,b)=[ 0, 1, 1, 0, 1, 1, 1, 0][ 0, 0, 0, 0, 0, 0, 0, 0] c ---------------------------------------------------------------- c some unix systems have oposite direction of bit raising ! shiftr=int(a/(2**b)) c print *,'shiftr',a,b,shiftr return end #endif #if (HP > 0) Change above HP to other value if you want use f90 on HP/Convex function xor(a,b) integer a,aru,alu,aval integer b,bru,blu,bval integer xor common /msg/ middle,rightedge,leftedge,botedge,topedge,npos,mpos, . perightabove,perightbelow,peleftbelow,peleftabove, . peleft,peright,peabove,pebelow,mype,mysize create bitwise function xor(a,b) for f77 on HP c a=[ 0, 0, 1, 1, 0, 1, 1, 1] (236) c b=[ 1, 0, 1, 1, 1, 0, 1, 1] (221) c xor(a,b)=[ 1, 0, 0, 0, 1, 1, 0, 0] (49) c --------------------------------- c [ 1, 2, 4, 8, 16, 32, 64,128] compute first 2 byte (16 bits) only, if you do need more, change nbyte value nbyte=2 nbyte=nbyte*8 alu=0 blu=0 xor=0 c print *,'mype',mype,'a',a c print *,'mype',mype,'b',b do i=1,nbyte ishift=2**i aru=ishift*int(a/ishift) bru=ishift*int(b/ishift) aval=a-aru-alu bval=b-bru-blu alu=a-aru blu=b-bru xor=xor+abs(aval-bval) enddo c print *,'mype',mype,xor return end function or(a,b) integer a,aru,alu,aval integer b,bru,blu,bval integer or create bitwise function or(a,b) for f77 on HP c a=[ 0, 0, 1, 1, 0, 1, 1, 1] (236) c b=[ 1, 0, 1, 1, 1, 0, 1, 1] (221) c or(a,b)=[ 1, 0, 1, 1, 1, 1, 1, 1] (253) c --------------------------------- c [ 1, 2, 4, 8, 16, 32, 64,128] compute first 2 byte only, if you do need more, change nbyte value nbyte=2 nbyte=nbyte*8 alu=0 blu=0 or=0 do i=1,nbyte ishift=2**i aru=ishift*int(a/ishift) bru=ishift*int(b/ishift) aval=a-aru-alu bval=b-bru-blu alu=a-aru blu=b-bru if((aval.ne.0).or.(bval.ne.0)) or=or+2**(i-1) enddo c print *,'or:',or return end function and(a,b) integer a,aru,alu,aval integer b,bru,blu,bval integer and create bitwise function and(a,b) for f77 on HP c a=[ 0, 0, 1, 1, 0, 1, 1, 1] (236) c b=[ 1, 0, 1, 1, 1, 0, 1, 1] (221) c and(a,b)=[ 0, 0, 1, 1, 0, 0, 1, 1] (204) c --------------------------------- c [ 1, 2, 4, 8, 16, 32, 64,128] compute first 2 byte only, if you do need more, change nbyte value nbyte=2 nbyte=nbyte*8 alu=0 blu=0 and=0 do i=1,nbyte ishift=2**i aru=ishift*int(a/ishift) bru=ishift*int(b/ishift) aval=a-aru-alu bval=b-bru-blu alu=a-aru blu=b-bru if((aval.ne.0).and.(bval.ne.0)) and=and+2**(i-1) enddo c print *,'and:',and return end #endif #if (GKS == 1) block data blncarg include 'param.nml' c------------------------------------------------------------------------ c---> set frame aspect ratios c---> iautoxz,iautoyz,iautoxy - set aspect ratios of frames c---> = 1 -> aspect ratio = domain size c------------------------------------------------------------------------ common/autogks/ iautoxz,iautoyz,iautoxy data iautoxz/0/,iautoyz/0/,iautoxy/0/ c------------------------------------------------------------------------ c---> is,ie,ksx,kex - number of points to skip from boundary in X,Z frame c---> js,je,ksy,key - Y,Z frame c---> ish,ieh,jsh,jeh - X,Y frame c---> t1x,t2x,t3x,x1z,x2z,x3z - dimension of X,Z frame c---> t1y,t2y,t3y,y1z,y2z,y3z - Y,Z frame c---> t1xh,t2xh,t3xh,t1yh,t2yh,t3yh - X,Y frame c------------------------------------------------------------------------ c---> common/xzfrm/is,ie,t1x,t2x,t3x,ks, ke, t1z,t2z,t3z !inside xzplot common/xzfrm/is,ie,t1x,t2x,t3x,ksx,kex,x1z,x2z,x3z data is ,ie ,ksx,kex/ 0, 0, 0, 0/ data t1x,t3x,x1z,x3z/.1,1.,.1,1./ c---> common/yzfrm/js,je,t1y,t2y,t3y,ks ,ke ,t1z,t2z,t3z !inside yzplot common/yzfrm/js,je,t1y,t2y,t3y,ksy,key,y1z,y2z,y3z data js ,je ,ksy,key/ 0, 0, 0, 0/ data t1y,t3y,y1z,y3z/.1,.5,.1,1./ c---> common/xyfrm/is ,ie ,t1x ,t2x ,t3x ,js ,je ,t1y ,t2y ,t3y !xyplot common/xyfrm/ish,ieh,t1xh,t2xh,t3xh,jsh,jeh,t1yh,t2yh,t3yh data ish ,ieh ,jsh ,jeh / 0, 0, 0, 0/ data t1xh,t3xh,t1yh,t3yh/.1,1.,.1,.5/ common/rat/rat1,rat2,rat3 c------------------------------------------------------------------------ c zmin - minimum, zmax - maximum: scale of color vlaues (if izval=1) c these same values for xzplot, yzplot, xyplot c------------------------------------------------------------------------ common /plot2/ zmin(22),zmax(22),izval(22),ihlg(3,22),ihcg(3,22) data zmin(1) ,zmax(1) ,izval(1) /0.,0.,0/ !th/the-1. data zmin(2) ,zmax(2) ,izval(2) /0.,0.,0/ !th data zmin(3) ,zmax(3) ,izval(3) /0.,0.,0/ !p*2.*dti data zmin(4) ,zmax(4) ,izval(4) /0.,0.,0/ !u data zmin(5) ,zmax(5) ,izval(5) /0.,0.,0/ !om data zmin(6) ,zmax(6) ,izval(6) /0.,0.,0/ !w data zmin(7) ,zmax(7) ,izval(7) /0.,0.,0/ data zmin(8) ,zmax(8) ,izval(8) /0.,0.,0/ data zmin(9) ,zmax(9) ,izval(9) /0.,0.,0/ !div*dt data zmin(10),zmax(10),izval(10)/0.,0.,0/ !qv [g/kg] data zmin(11),zmax(11),izval(11)/0.,0.,0/ !qc [g/kg] data zmin(12),zmax(12),izval(12)/0.,0.,0/ !qr,qia,qib [g/kg] data zmin(13),zmax(13),izval(13)/0.,0.,0/ !Rh data zmin(14),zmax(14),izval(14)/0.,0.,0/ !thetav data zmin(15),zmax(15),izval(15)/0.,0.,0/ !Km*dt/Dx**2 data zmin(16),zmax(16),izval(16)/0.,0.,0/ !Ri data zmin(17),zmax(17),izval(17)/0.,0.,0/ !v data zmin(18),zmax(18),izval(18)/0.,0.,0/ !vortx*dt data zmin(19),zmax(19),izval(19)/0.,0.,0/ !vorty*dt data zmin(20),zmax(20),izval(20)/0.,0.,0/ !vortz*dt data zmin(21),zmax(21),izval(21)/0.,0.,0/ !pv data zmin(22),zmax(22),izval(22)/0.,0.,0/ !isentropic surface c------------------------------------------------------------------------ c ihlg - high/low label parameters (=0 off) (=1 on) c 0 - off c 1 - hvalue, lvalue c 2 - H(hvalue), L(lvalue) c 3 - H_hvalue, L_lvalue c 4 - H, L c------------------------------------------------------------------------ c ---- XZPLOT --- YZPLOT --- XYPLO ---------- data ihlg(1,1) ,ihlg(2,1) ,ihlg(3,1) /0,0,1/ !th/the-1. data ihlg(1,2) ,ihlg(2,2) ,ihlg(3,2) /0,0,0/ !th data ihlg(1,3) ,ihlg(2,3) ,ihlg(3,3) /1,1,1/ !p*2.*dti data ihlg(1,4) ,ihlg(2,4) ,ihlg(3,4) /2,2,2/ !u data ihlg(1,5) ,ihlg(2,5) ,ihlg(3,5) /3,3,3/ !om data ihlg(1,6) ,ihlg(2,6) ,ihlg(3,6) /4,4,4/ !w data ihlg(1,7) ,ihlg(2,7) ,ihlg(3,7) /0,0,1/ data ihlg(1,8) ,ihlg(2,8) ,ihlg(3,8) /0,0,1/ data ihlg(1,9) ,ihlg(2,9) ,ihlg(3,9) /0,0,1/ !div*dt data ihlg(1,10),ihlg(2,10),ihlg(3,10)/0,0,1/ !qv [g/kg] data ihlg(1,11),ihlg(2,11),ihlg(3,11)/0,0,1/ !qc [g/kg] data ihlg(1,12),ihlg(2,12),ihlg(3,12)/0,0,1/ !qr,qia,qib [g/kg] data ihlg(1,13),ihlg(2,13),ihlg(3,13)/0,0,1/ !Rh data ihlg(1,14),ihlg(2,14),ihlg(3,14)/0,0,1/ !thetav data ihlg(1,15),ihlg(2,15),ihlg(3,15)/0,0,1/ !Km*dt/Dx**2 data ihlg(1,16),ihlg(2,16),ihlg(3,16)/0,0,1/ !Ri data ihlg(1,17),ihlg(2,17),ihlg(3,17)/3,3,3/ !v data ihlg(1,18),ihlg(2,18),ihlg(3,18)/0,0,1/ !vortx*dt data ihlg(1,19),ihlg(2,19),ihlg(3,19)/0,0,1/ !vorty*dt data ihlg(1,20),ihlg(2,20),ihlg(3,20)/0,0,1/ !vortz*dt data ihlg(1,21),ihlg(2,21),ihlg(3,21)/0,0,1/ !pv data ihlg(1,22),ihlg(2,22),ihlg(3,22)/0,0,1/ !isentropic surface c------------------------------------------------------------------------ c ihcg - hachuring flags c 0 - hachuring off c 1 - all contours hachured c 2 - closed contours hachured if interior is downslope, c open contouts all hachured c 3 - closed contours hachured if interior is downslope, c open contouts not hachured c 4 - closed contours hachured if interior is downslope, c open contouts hachured if interior is downslope c -2,-3,-4 like above but "downslope" change to "upslope" c------------------------------------------------------------------------ c XZPLOT YZPLOT XYPLOT data ihcg(1,1) ,ihcg(2,1) ,ihcg(3,1) /0,0,0/ !th/the-1. data ihcg(1,2) ,ihcg(2,2) ,ihcg(3,2) /0,0,0/ !th data ihcg(1,3) ,ihcg(2,3) ,ihcg(3,3) /0,0,0/ !p*2.*dti data ihcg(1,4) ,ihcg(2,4) ,ihcg(3,4) /0,0,2/ !u data ihcg(1,5) ,ihcg(2,5) ,ihcg(3,5) /0,0,2/ !om data ihcg(1,6) ,ihcg(2,6) ,ihcg(3,6) /0,0,2/ !w data ihcg(1,7) ,ihcg(2,7) ,ihcg(3,7) /0,0,0/ data ihcg(1,8) ,ihcg(2,8) ,ihcg(3,8) /0,0,0/ data ihcg(1,9) ,ihcg(2,9) ,ihcg(3,9) /0,0,0/ !div*dt data ihcg(1,10),ihcg(2,10),ihcg(3,10)/0,0,0/ !qv [g/kg] data ihcg(1,11),ihcg(2,11),ihcg(3,11)/0,0,0/ !qc [g/kg] data ihcg(1,12),ihcg(2,12),ihcg(3,12)/0,0,0/ !qr,qia,qib [g/kg] data ihcg(1,13),ihcg(2,13),ihcg(3,13)/0,0,0/ !Rh data ihcg(1,14),ihcg(2,14),ihcg(3,14)/0,0,0/ !thetav data ihcg(1,15),ihcg(2,15),ihcg(3,15)/0,0,0/ !Km*dt/Dx**2 data ihcg(1,16),ihcg(2,16),ihcg(3,16)/0,0,0/ !Ri data ihcg(1,17),ihcg(2,17),ihcg(3,17)/0,0,2/ !v data ihcg(1,18),ihcg(2,18),ihcg(3,18)/0,0,0/ !vortx*dt data ihcg(1,19),ihcg(2,19),ihcg(3,19)/0,0,0/ !vorty*dt data ihcg(1,20),ihcg(2,20),ihcg(3,20)/0,0,0/ !vortz*dt data ihcg(1,21),ihcg(2,21),ihcg(3,21)/0,0,0/ !pv data ihcg(1,22),ihcg(2,22),ihcg(3,22)/0,0,0/ !isentropic surface c------------------------------------------------------------------------ create color palete,line labeling and isoline levels c xzcol for XZ, yzcol for YZ, xycol for XY plots chose xzcol,yzcol,xycol(1,...)=value for color palete c value = 1 - red into light blue c 2 - dark blue into yellow c 3 - gray into white c 4 - white into dark gray (linear scale) c 5 - white into dark gray (quadratic scale) c 6 - black into yellow c 7 - red into dark blue c 8 - dark blue into red c 9 - white c 10 - dark blue (violet) <0, red >0; min - max blue, max - max red c 11 - seledin (blue sky) <0, red >0; min - max blue, max - max red c 12 - seledin (blue water)<0, red >0; min - max blue, max - max red c 13 - dark blue (violet) <0, red >0; max color - amax1(abs(min,max)) c 14 - seledin (blue sky) <0, red >0; max color - amax1(abs(min,max)) c 15 - seledin (blue water)<0, red >0;max color - amax1(abs(min,max)) c 16 - light blue into light red c 17 - new from Vanda Grubisic (59 isolines) c------------------------------------------------------------------------ chose xzcol,yzcol,xycol(2,...)=value for isoline levels (value<=100) c value = 0 - isoline off c n - n isolines between min, max value of ploted array c (if izval=1 - n isolines between zmin, zmax value) c------------------------------------------------------------------------ chose xzcol,yzcol,xycol(3,...)=value for line labels c value = 0 - line labells off c 1 - each line labelled c 2 - each second line labelled c n - n'th line labelled c integer xzcol,yzcol,xycol c------------------------------------------------------------------------ common /plot1/ xzcol(3,21),yzcol(3,21),xycol(3,22) c COLORPAL ISOLINES LINE_LABELS data xzcol(1,1) ,xzcol(2,1) ,xzcol(3,1) /4,18,0/ !th/the-1. data xzcol(1,2) ,xzcol(2,2) ,xzcol(3,2) /4,20,0/ !th data xzcol(1,3) ,xzcol(2,3) ,xzcol(3,3) /4,18,0/ !p*2.*dti data xzcol(1,4) ,xzcol(2,4) ,xzcol(3,4) /2,18,0/ !u data xzcol(1,5) ,xzcol(2,5) ,xzcol(3,5) /2,18,0/ !om data xzcol(1,6) ,xzcol(2,6) ,xzcol(3,6) /2,18,0/ !w data xzcol(1,7) ,xzcol(2,7) ,xzcol(3,7) /4,18,0/ data xzcol(1,8) ,xzcol(2,8) ,xzcol(3,8) /4,18,0/ data xzcol(1,9) ,xzcol(2,9) ,xzcol(3,9) /2,18,0/ !div*dt data xzcol(1,10),xzcol(2,10),xzcol(3,10)/4,18,0/ !qv [g/kg] data xzcol(1,11),xzcol(2,11),xzcol(3,11)/4,18,0/ !qc [g/kg] data xzcol(1,12),xzcol(2,12),xzcol(3,12)/4,18,0/ !qr,qia,qib [g/kg] data xzcol(1,13),xzcol(2,13),xzcol(3,13)/4,18,0/ !Rh data xzcol(1,14),xzcol(2,14),xzcol(3,14)/4,18,0/ !thetav data xzcol(1,15),xzcol(2,15),xzcol(3,15)/4,18,0/ !Km*dt/Dx**2 data xzcol(1,16),xzcol(2,16),xzcol(3,16)/4,18,0/ !Ri data xzcol(1,17),xzcol(2,17),xzcol(3,17)/2,18,0/ !v data xzcol(1,18),xzcol(2,18),xzcol(3,18)/2,18,0/ !vortx*dt data xzcol(1,19),xzcol(2,19),xzcol(3,19)/2,18,0/ !vorty*dt data xzcol(1,20),xzcol(2,20),xzcol(3,20)/2,18,0/ !vortz*dt data xzcol(1,21),xzcol(2,21),xzcol(3,21)/2,18,0/ !pv c COLORPAL ISOLINES LINE_LABELS data yzcol(1,1) ,yzcol(2,1) ,yzcol(3,1) /4,18,0/ !th/the-1. data yzcol(1,2) ,yzcol(2,2) ,yzcol(3,2) /4,20,0/ !th data yzcol(1,3) ,yzcol(2,3) ,yzcol(3,3) /4,18,0/ !p*2.*dti data yzcol(1,4) ,yzcol(2,4) ,yzcol(3,4) /2,18,0/ !u data yzcol(1,5) ,yzcol(2,5) ,yzcol(3,5) /2,18,0/ !om data yzcol(1,6) ,yzcol(2,6) ,yzcol(3,6) /2,18,0/ !w data yzcol(1,7) ,yzcol(2,7) ,yzcol(3,7) /4,18,0/ data yzcol(1,8) ,yzcol(2,8) ,yzcol(3,8) /4,18,0/ data yzcol(1,9) ,yzcol(2,9) ,yzcol(3,9) /2,18,0/ !div*dt data yzcol(1,10),yzcol(2,10),yzcol(3,10)/4,18,0/ !qv [g/kg] data yzcol(1,11),yzcol(2,11),yzcol(3,11)/4,18,0/ !qc [g/kg] data yzcol(1,12),yzcol(2,12),yzcol(3,12)/4,18,0/ !qr,qia,qib [g/kg] data yzcol(1,13),yzcol(2,13),yzcol(3,13)/4,18,0/ !Rh data yzcol(1,14),yzcol(2,14),yzcol(3,14)/4,18,0/ !thetav data yzcol(1,15),yzcol(2,15),yzcol(3,15)/4,18,0/ !Km*dt/Dx**2 data yzcol(1,16),yzcol(2,16),yzcol(3,16)/4,18,0/ !Ri data yzcol(1,17),yzcol(2,17),yzcol(3,17)/2,18,0/ !v data yzcol(1,18),yzcol(2,18),yzcol(3,18)/2,18,0/ !vortx*dt data yzcol(1,19),yzcol(2,19),yzcol(3,19)/2,18,0/ !vorty*dt data yzcol(1,20),yzcol(2,20),yzcol(3,20)/2,18,0/ !vortz*dt data yzcol(1,21),yzcol(2,21),yzcol(3,21)/2,18,0/ !pv c COLORPAL ISOLINES LINE_LABELS data xycol(1,1) ,xycol(2,1) ,xycol(3,1) /4,18,0/ !th/the-1. data xycol(1,2) ,xycol(2,2) ,xycol(3,2) /4,20,0/ !th data xycol(1,3) ,xycol(2,3) ,xycol(3,3) /4,18,0/ !p*2.*dti data xycol(1,4) ,xycol(2,4) ,xycol(3,4) /2,18,0/ !u data xycol(1,5) ,xycol(2,5) ,xycol(3,5) /2,18,0/ !om data xycol(1,6) ,xycol(2,6) ,xycol(3,6) /2,18,0/ !w data xycol(1,7) ,xycol(2,7) ,xycol(3,7) /4,18,0/ data xycol(1,8) ,xycol(2,8) ,xycol(3,8) /4,18,0/ data xycol(1,9) ,xycol(2,9) ,xycol(3,9) /2,18,0/ !div*dt data xycol(1,10),xycol(2,10),xycol(3,10)/4,18,0/ !qv [g/kg] data xycol(1,11),xycol(2,11),xycol(3,11)/4,18,0/ !qc [g/kg] data xycol(1,12),xycol(2,12),xycol(3,12)/4,18,0/ !qr,qia,qib [g/kg] data xycol(1,13),xycol(2,13),xycol(3,13)/4,18,0/ !Rh data xycol(1,14),xycol(2,14),xycol(3,14)/4,18,0/ !thetav data xycol(1,15),xycol(2,15),xycol(3,15)/4,18,0/ !Km*dt/Dx**2 data xycol(1,16),xycol(2,16),xycol(3,16)/4,18,0/ !Ri data xycol(1,17),xycol(2,17),xycol(3,17)/2,18,0/ !v data xycol(1,18),xycol(2,18),xycol(3,18)/2,18,0/ !vortx*dt data xycol(1,19),xycol(2,19),xycol(3,19)/2,18,0/ !vorty*dt data xycol(1,20),xycol(2,20),xycol(3,20)/2,18,0/ !vortz*dt data xycol(1,21),xycol(2,21),xycol(3,21)/2,18,0/ !pv data xycol(1,22),xycol(2,22),xycol(3,22)/4,18,0/ !isentropic surface end subroutine ncargdef include 'param.nml' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/autogks/iautoxz,iautoyz,iautoxy common/xzfrm/is,ie,t1x,t2x,t3x,ksx,kex,x1z,x2z,x3z common/yzfrm/js,je,t1y,t2y,t3y,ksy,key,y1z,y2z,y3z common/xyfrm/ish,ieh,t1xh,t2xh,t3xh,jsh,jeh,t1yh,t2yh,t3yh common/rat/rat1,rat2,rat3 c nx =n-(is+ie) -1 nzx=l-(ksx+kex)-1 ny =m-(js+je) -1 nzy=l-(ksy+key)-1 nxh=n-(ish+ieh)-1 nyh=m-(jsh+jeh)-1 if (iautoxz.eq.1) then if (((nx)*dx).ge.((nzx)*dz)) then t3x=1. x3z=((nzx)*dz)/((nx)*dx) x1z=0.5-0.4*x3z else t3x=((nx)*dx)/((nzx)*dz) t1x=0.5-0.4*t3x x3z=1. endif endif t2x=t1x+.8*t3x x2z=x1z+.8*x3z if (j3.eq.1) then if (iautoyz.eq.1) then if (((ny)*dy).ge.((nzy)*dz)) then t3y=1. y3z=((nzy)*dz)/((ny)*dy) y1z=0.5-0.4*y3z else t3y=((ny)*dy)/((nzy)*dz) t1y=0.5-0.4*t3y y3z=1. endif endif t2y=t1y+.8*t3y y2z=y1z+.8*y3z if (iautoxy.eq.1) then if (((nxh)*dx).ge.((nyh)*dy)) then t3xh=1. t3yh=((nyh)*dy)/((nxh)*dx) t1yh=0.5-0.4*t3yh else t3xh=((nxh)*dx)/((nyh)*dy) t1xh=0.5-0.4*t3xh t3yh=1. endif endif t2xh=t1xh+.8*t3xh t2yh=t1yh+.8*t3yh endif c nx =n-1 c nzx=l-1 c ny =m-1 c nzy=l-1 c nxh=n-1 c nyh=m-1 rat1=float(nx)*(x2z-x1z)/(float(nzx)*(t2x-t1x)) if (j3.eq.1) then rat2=float(ny)*(y2z-y1z)/(float(nzy)*(t2y-t1y)) rat3=float(nxh)*(t2yh-t1yh)/(float(nyh)*(t2xh-t1xh)) endif ccccccccccccccccccccccccccccccccccccccccccc #if (COLORPL == 1) C define background colors CALL GSCR(1, 0, 1., 1., 1.) !WHITE c CALL GSCR(1, 0, 1., 0., 0.) !RED c CALL GSCR(1, 0, 1., 1., 0.) !YELLOW c CALL GSCR(1, 0, 0., 1., 0.) !GREEN c CALL GSCR(1, 0, 0., 0., 1.) !BLUE c CALL GSCR(1, 0, .5, 1., 0.) !ORANGE c CALL GSCR(1, 0, 0., 1., 1.) !CYAN c CALL GSCR(1, 0, 1., 0., 1.) !MAGENTA c CALL GSCR(1, 0, 0., 0., 0.) !BLACK C define text colors CALL GSCR(1, 1, 0., 0., 0.) !BLACK #else CALL GSCR(1, 0, 0., 0., 0.) !BLACK CALL GSCR(1, 1, 1., 1., 1.) !WHITE #endif ccccccccccccccccccccccccccccccccccccccccccc c set up the text color CALL CPSETI('ILC - INFORMATION LABEL TEXT',1) c set the text color index CALL GSTXCI(1) c set the polyline color index CALL GSPLCI(1) c set the polymarker color index CALL GSPMCI(1) c set the fill area color index CALL GSFACI(1) !foreground CALL GSFACI(0) !background return end #if (PLOTPL == 1) blockdata blplot c----------------------------------------------------- common/plofl/ ibupl,ithpl,iprpl,iuvpl,ivvpl,iwvpl, . ioxpl,ioypl,iozpl,idvpl,ichpl,iripl,iqvpl, . iqcpl,iqrpl,irhpl,ithvpl,ikmpl,iqial,iqibl c ibupl -> dry buoyancy c ithpl -> dry potential temperature c iprpl -> normalized pressure c iuvpl -> zonal wind c ivvpl -> spanwise/meridional wind c iwvpl -> vertical wind c ioxpl -> solenoidal zonal wind c ioypl -> solenoidal spanwise/meridional wind c iozpl -> solenoidal vertical wind c idvpl -> flow divergence*dt c iripl -> Richardson number c iqvpl -> water vapor mixing ratio c iqcpl -> cloud water/ice mixing ratio c iqrpl -> rain/snow water mixing ratio c irhpl -> relative humidity c ithvpl-> moist potential temperature c ikmpl -> c iqipl -> c iqibl -> data ibupl/0/,ithpl/1/,iprpl/1/,iuvpl/1/,ivvpl/1/,iwvpl/1/, 1 ioxpl/0/,ioypl/0/,iozpl/0/,idvpl/0/,ichpl/0/,iripl/0/, 2 iqvpl/0/,iqcpl/0/,iqrpl/0/,irhpl/0/,ithvpl/0/,ikmpl/0/, 3 iqial/0/,iqibl/0/ c----------------------------------------------------- common/plofsl/ ixzpl,iyzpl,ixypl,iznav,isfpl,iprfl,iflxpl,isppl c ixzpl -> plot xz plane contour plots c iyzpl -> plot yz plane contour plots c ixypl -> plot xy plane contour plots c iprfl -> plot 1D horizontally averaged profiles c iflxpl-> plot 1D flux profiles c isppl -> plot 1D power spectra c iznav -> plot zonally averaged yz plane contour plots data ixzpl/1/,iyzpl/1/,ixypl/1/,iznav/0/,isfpl/1/, . iprfl/1/,iflxpl/0/,isppl/0/ c----------------------------------------------------- common/plotxy/ isx,isy,ivctpl,izcr0 data isx,isy/0,0/ ! plot at grid point (0) or between 2 pts (1) c ivctpl = 1 (vectors) c ivctpl = 2 (streamlines) data ivctpl/0/ data izcr0/0/ ! plot 1 vertical level (0) or two (1) common/plotsp/ isptu,isptv,isptw,isptt c declarations for spectrum analysis routine follow; the following arE c for spectral analysis options to be used if isppl = 1 above: c---> isptu = 1 to Fourier analyze u', c---> isptv = 1 for v', c---> isptw = 1 for w', c---> isptt = 1 for theta'. data isptu/1/,isptv/0/,isptw/0/,isptt/0/ c c---> nsppl is number of vertical levels to spectral analyze c---> ksppl(1,2,...nsppl) is vertical grid levels to analyze parameter (nsppl = 9) common/plotsk/ nksppl(nsppl), nkug data nksppl/9*11/ end subroutine plot(th,u,v,w,ox,oy,oz,p,div,chm, * qv,qc,qr,qia,qib,lipps,tke,rhf,tau) c --- th is potential temperture perturbation c --- u,v,w are full zonal, meridional, and vertical wind fields c --- ox, oy, oz are solenoidal? zonal, meridional, and vertical wind c --- fields c --- p,div are pressure perturbation and continuity divergence fields c --- qv,qc,qr are water vapor mixing ratio, cloud water, and c --- precipitating water fields c --- qia,qib are ??? c --- lipps is flag for type of basic state (see subroutine tinit_i) c --- tke is flag for turbulent kinetic energy analysis c --- rhf is Richardson number field include 'param.nml' include 'msg.inc' dimension th(1-ih:np+ih,1-ih:mp+ih,l), . u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . div(1-ih:np+ih,1-ih:mp+ih,l), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . rhf(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . tau(l,1-ih:np+ih,1-ih:mp+ih), . qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . chm(1-ih:nchp+ih,1-ih:mchp+ih,lch,nspc) dimension pz(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) dimension fxz(n,l),fyz(m,l),fxy(n,m),ffz(l), 1 uxz(n,l),wxz(n,l),vyz(m,l),wyz(m,l),uxy(n,m),vxy(n,m) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . df(1-ih:np+ih, 1-ih:mp+ih, l), . hx(1-ih:np+ih, 1-ih:mp+ih, l), . hy(1-ih:np+ih, 1-ih:mp+ih, l), . hz(1-ih:np+ih, 1-ih:mp+ih, l), . scr10(1-ih:np+ih, 1-ih:mp+ih, l, 10) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . df(1-ih:np+ih, 1-ih:mp+ih, l), . hx(1-ih:np+ih, 1-ih:mp+ih, l), . hy(1-ih:np+ih, 1-ih:mp+ih, l), . hz(1-ih:np+ih, 1-ih:mp+ih, l), . scr3(1-ih:np+ih, 1-ih:mp+ih, l, 3) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/sgscnst/ ceps,cL,cm,cs,prndt common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) common/stresd/ diagstr(8),ivis,irid,itstr common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/gora/ xml,yml,amp,xml0,yml0,angle common/plzsmax/ zsmx,mintop common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common blocks defined in block data 'blplot' common/plofl/ ibupl,ithpl,iprpl,iuvpl,ivvpl,iwvpl, . ioxpl,ioypl,iozpl,idvpl,ichpl,iripl,iqvpl, . iqcpl,iqrpl,irhpl,ithvpl,ikmpl,iqial,iqibl common/plofsl/ ixzpl,iyzpl,ixypl,iznav,isfpl,iprfl,iflxpl,isppl common/plotxy/ isx,isy,ivctpl,izcr0 common/plotsp/ isptu,isptv,isptw,isptt parameter (nsppl = 9) !same value as in block data 'blplot' common/plotsk/ nksppl(nsppl), nkug common blocks defined in block data 'blncarg' common/xzfrm/is,ie,t1x,t2x,t3x,ksx,kex,x1z,x2z,x3z common/yzfrm/js,je,t1y,t2y,t3y,ksy,key,y1z,y2z,y3z common/xyfrm/ish,ieh,t1xh,t2xh,t3xh,jsh,jeh,t1yh,t2yh,t3yh common/rat/rat1,rat2,rat3 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c --- initializations nm=n*m nml=n*m*l n1=n n2=m n3=l inorm=0 if(j3.eq.0) then iyzpl=0 ixypl=0 isy=0 if(icorio.eq.0) ivvpl=0 endif iqvpl=iqvpl*moist iqcpl=iqcpl*moist iqrpl=iqrpl*moist irhpl=irhpl*moist ithvpl=ithvpl*moist ikmpl=ikmpl*ivis iripl=iripl*irid isfpl=isfpl*isphere if(ikmpl.eq.1) then if(j3.eq.1) deltl=1.*(dx+dy+dz)/3. if(j3.eq.0) deltl=sqrt(dx*dz) deltc=sqrt(dx**2+j3*dy**2+dz**2) endif ichpl=ichpl*ichm iqial=(iqial*moist)*iceab iqibl=(iqibl*moist)*iceab contour level density nclv=41 nclvs=61 conversions for displays c limit Ri for display purposes if(iripl.eq.1) then ricut=0. do k=1,l do j=1,m do i=1,n ri(i,j,k)=amin1(ri(i,j,k),ricut) enddo enddo enddo endif c filter selected fields for plots ! WARNING: alters p array nullfl=0 if(nullfl.eq.1) then if(iprpl.eq.1) call filtplt( p,fxyz,df,hx,hy,hz,pz) if(idvpl.eq.1) call filtplt(div,fxyz,df,hx,hy,hz,pz) endif iprint=0 if(iprint.eq.1) then c------------------------------------------------------------- c 1 2 3 4 5 6 7 c23456789012345678901234567890123456789012345678901234567890123456789012 c------------------------------------------------------------- print*,'ithpl,iprpl,iuvpl,ivvpl=',ithpl,iprpl,iuvpl,ivvpl print*,'iwvpl,iozpl,idvpl,ichpl=',iwvpl,iozpl,idvpl,ichpl print*,'iqvpl,iqcpl,iqrpl=',iqvpl,iqcpl,iqrpl print*,'iqial,iqibl=',iqial,iqibl print*,'irhpl,ithvpl,ikmpl,iripl=',irhpl,ithvpl,ikmpl,iripl end if cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c------ compute and plot (x,y) averaged profiles if(iprfl.eq.1) then if(ibupl.eq.1) then do 101 k=1,l do 101 j=1,m do 101 i=1,n c 101 fxyz(i,j,k)= th(i,j,k)/th0(i,j,k) 101 fxyz(i,j,k)= th(i,j,k) call profil(fxyz,n,m,l,1) endif if(ithpl.eq.1) then do 102 k=1,l do 102 j=1,m do 102 i=1,n 102 fxyz(i,j,k)= th(i,j,k)+the(i,j,k) call profil(fxyz,n,m,l,2) endif if(iprpl.eq.1) then do 103 k=1,l do 103 j=1,m do 103 i=1,n 103 fxyz(i,j,k)= p(i,j,k)*2.*dti call profil(fxyz,n,m,l,3) endif if(iuvpl.eq.1) then do 104 k=1,l do 104 j=1,m do 104 i=1,n 104 fxyz(i,j,k)= u(i,j,k) call profil(fxyz,n,m,l,4) endif if(ivvpl.eq.1) then do 1041 k=1,l do 1041 j=1,m do 1041 i=1,n 1041 fxyz(i,j,k)= v(i,j,k) call profil(fxyz,n,m,l,41) endif if(iozpl.eq.1) then do 105 k=1,l do 105 j=1,m do 105 i=1,n 105 fxyz(i,j,k)= oz(i,j,k) call profil(fxyz,n,m,l,5) endif if(iwvpl.eq.1) then do 106 k=1,l do 106 j=1,m do 106 i=1,n 106 fxyz(i,j,k)= w(i,j,k) call profil(fxyz,n,m,l,6) endif if(idvpl.eq.1) then do 109 k=1,l do 109 j=1,m do 109 i=1,n 109 fxyz(i,j,k)= div(i,j,k)*dt call profil(fxyz,n,m,l,9) endif if(iqvpl.eq.1) then do 110 k=1,l do 110 j=1,m do 110 i=1,n 110 fxyz(i,j,k)= qv(i,j,k)*1.e3 call profil(fxyz,n,m,l,10) endif if(iqcpl.eq.1) then do 111 k=1,l do 111 j=1,m do 111 i=1,n 111 fxyz(i,j,k)= qc(i,j,k)*1.e3 call profil(fxyz,n,m,l,11) endif if(iqrpl.eq.1) then do 112 k=1,l do 112 j=1,m do 112 i=1,n 112 fxyz(i,j,k)= qr(i,j,k)*1.e3 call profil(fxyz,n,m,l,12) endif if(iqial.eq.1) then do 1121 k=1,l do 1121 j=1,m do 1121 i=1,n 1121 fxyz(i,j,k)= qia(i,j,k)*1.e3 call profil(fxyz,n,m,l,31) endif if(iqibl.eq.1) then do 1122 k=1,l do 1122 j=1,m do 1122 i=1,n 1122 fxyz(i,j,k)= qib(i,j,k)*1.e3 call profil(fxyz,n,m,l,32) endif if(irhpl.eq.1) then do 113 k=1,l do 113 j=1,m do 113 i=1,n 113 fxyz(i,j,k)=rhf(i,j,k) call profil(fxyz,n,m,l,13) endif if(ithvpl.eq.1) then epsb=rv/rg-1. do 114 k=1,l do 114 j=1,m do 114 i=1,n 114 fxyz(i,j,k)=th(i,j,k)+the(i,j,k)+epsb*qv(i,j,k)*th0(i,j,k) call profil(fxyz,n,m,l,14) endif if(ikmpl.eq.1) then do 115 k=1,l do 115 j=1,m do 115 i=1,n coef=cm*amin1(cL*amax1(float(k-1),1.)*dz/gi(i,j),deltl) . *(1-ibcz)+ibcz*deltl c coef=cm*amin1(cL*amax1(float(k-1)*dz/gi(i,j),zo(i,j)),deltl) 115 fxyz(i,j,k)=coef*tke(i,j,k)*dt/deltc**2 call profil(fxyz,n,m,l,15) endif if(iripl.eq.1) then do 116 k=1,l do 116 j=1,m do 116 i=1,n 116 fxyz(i,j,k)=ri(i,j,k) call profil(fxyz,n,m,l,16) endif if(ichpl.eq.1) then do ispc=1,nspc ifsp=16+ispc do 117 k=1,l do 117 j=1,m do 117 i=1,n 117 fxyz(i,j,k)=chm(i,j,k,ispc) call profil(fxyz,n,m,l,ifsp) enddo endif endif close profiles if(iflxpl.eq.1) then if(iuvpl.eq.1) call reystress( u,w,n,m,l,1,lipps) if(ivvpl.eq.1) call reystress( v,w,n,m,l,2,lipps) if(ithpl.eq.1) call reystress(th,w,n,m,l,3,lipps) if(iqvpl.eq.1) call reystress(qv,w,n,m,l,4,lipps) if(iqcpl.eq.1) call reystress(qc,w,n,m,l,5,lipps) endif close flux profiles cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc contour plots follow zsmx=0. mintop=1.e-4 do j=1,m do i=1,n zsmx=amax1(zsmx,abs(zs(i,j))) enddo enddo c---------------------------------------------------------------- if(ixzpl.eq.1) then ! plot xz-planes pi=acos(-1.) jc=pi*(1/6.+.5)*rds*dyi+0.5 !special for Wmson hill c jc=(1+m)/2 j1=jc jm=jc ji=1 do 777 j=j1,jm,ji do 200 k=1,l do 200 i=1,n uxz(i,k)=0.5*(u(i,j,k)+u(i,j+isy,k)) 200 wxz(i,k)=0.5*(w(i,j,k)+w(i,j+isy,k))*(2-ivctpl) . +0.5*(oz(i,j,k)+oz(i,j+isy,k))*(ivctpl-1) do 1017 k=1,l do 1017 i=1,n xnor0=sqrt(wxz(i,k)**2+uxz(i,k)**2) wxz(i,k)=wxz(i,k)*dx*dzi*rat1 xnort=sqrt(wxz(i,k)**2+uxz(i,k)**2) xcos=uxz(i,k)/(xnort+1.e-15) xsin=wxz(i,k)/(xnort+1.e-15) uxz(i,k)=xnor0*xcos wxz(i,k)=xnor0*xsin 1017 continue if(ibupl.eq.1) then do 201 k=1,l do 201 i=1,n fxz(i,k)=( th(i,j,k)+ th(i,j+isy,k)) c . /(th0(i,j,k)+th0(i,j+isy,k)) 201 continue call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,1,nclv) endif if(ithpl.eq.1) then ilog=1 ! plot log(theta) do k=1,l do i=1,n if(ilog.eq.1) then fxz(i,k)= alog(0.5*(th(i, j ,k)+the(i, j ,k)+ . th(i,j+isy,k)+the(i,j+isy,k))) else fxz(i,k)= 0.5*(th(i, j ,k)+the(i, j ,k)+ . th(i,j+isy,k)+the(i,j+isy,k)) end if end do end do c nclvs=2*nclv call xzplot(j,isy,fxz,uxz,wxz,n,l,0,2,nclvs) endif if(iprpl.eq.1) then do 203 k=1,l do 203 i=1,n fxz(i,k)=p(i,j,k)*2.*dti if(isy.eq.1) then fxz(i,k)=.5*(fxz(i,k)+p(i,j+1,k )*2.*dti) endif 203 continue call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,3,nclv) endif if(iuvpl.eq.1) then do 204 k=1,l do 204 i=1,n 204 fxz(i,k)=.5*(u(i,j,k)+u(i,j+isy,k)) c 204 fxz(i,k)=.5*((u(i,j,k)+u(i,j+isy,k))-(ue(i,j,k)+ue(i,j+isy,k))) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,4,nclv) endif if(ivvpl.eq.1) then do 2041 k=1,l do 2041 i=1,n 2041 fxz(i,k)=.5*((v(i,j,k)+v(i,j+isy,k))-(ve(i,j,k)+ve(i,j+isy,k))) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,41,nclv) endif if(iozpl.eq.1) then do 205 k=1,l do 205 i=1,n 205 fxz(i,k)=.5*(oz(i,j,k)+oz(i,j+isy,k)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,5,nclv) endif if(iwvpl.eq.1) then do 206 k=1,l do 206 i=1,n 206 fxz(i,k)=.5*(w(i,j,k)+w(i,j+isy,k)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,6,nclv) endif if(idvpl.eq.1) then do 209 k=1,l do 209 i=1,n 209 fxz(i,k)=.5*(div(i,j,k)+div(i,j+isy,k))*dt call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,9,nclv) endif if(iqvpl.eq.1) then do 210 k=1,l do 210 i=1,n 210 fxz(i,k)=.5*(qv(i,j,k)+qv(i,j+isy,k))*1.e3 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,10,nclv) endif if(iqcpl.eq.1) then do 211 k=1,l do 211 i=1,n 211 fxz(i,k)=.5*(qc(i,j,k)+qc(i,j+isy,k))*1.e3 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,11,nclv) endif if(iqrpl.eq.1) then do 212 k=1,l do 212 i=1,n 212 fxz(i,k)=.5*(qr(i,j,k)+qr(i,j+isy,k))*1.e3 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,12,nclv) endif if(iqial.eq.1) then do 2121 k=1,l do 2121 i=1,n 2121 fxz(i,k)=.5*(qia(i,j,k)+qia(i,j+isy,k))*1.e3 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,31,nclv) endif if(iqibl.eq.1) then do 2122 k=1,l do 2122 i=1,n 2122 fxz(i,k)=.5*(qib(i,j,k)+qib(i,j+isy,k))*1.e3 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,32,nclv) endif if(irhpl.eq.1) then do 213 k=1,l do 213 i=1,n 213 fxz(i,k)=.5*(rhf(i,j,k)+rhf(i,j+isy,k)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,13,nclv) endif if(ithvpl.eq.1) then epsb=rv/rg-1. do 214 k=1,l do 214 i=1,n 214 fxz(i,k)=0.5*(th(i,j,k)+the(i,j,k)+epsb*qv(i,j,k)* . th0(i,j,k)+th(i,j+isy,k)+the(i,j+isy,k)+ . epsb*qv(i,j+isy,k)*th0(i,j+isy,k)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,14,nclv) endif if(ikmpl.eq.1) then do 215 k=1,l do 215 i=1,n giav=0.5*(gi(i,j)+gi(i,j+isy)) c zoav=0.5*(zo(i,j)+zo(i,j+isy)) coef=cm*amin1(cL*amax1(float(k-1),1.)*dz/giav,deltl) . *(1-ibcz)+ibcz*deltl c coef=cm*amin1(cL*amax1(float(k-1)*dz/giav,zoav),deltl) tkeav=.5*(tke(i,j,k)+tke(i,j+isy,k)) 215 fxz(i,k)=coef*tkeav*dt/deltc**2 call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,15,nclv) endif if(iripl.eq.1) then do 216 k=1,l do 216 i=1,n 216 fxz(i,k)=.5*(ri(i,j,k)+ri(i,j+isy,k)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,16,nclv) endif if(ichpl.eq.1) then do ispc=1,nspc ifsp=16+ispc do 217 k=1,l do 217 i=1,n 217 fxz(i,k)=.5*(chm(i,j,k,ispc)+chm(i,j+isy,k,ispc)) call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,ifsp,nclv) enddo endif 777 continue endif close xzplots c---------------------------------------------------------------- if(iyzpl.eq.1) then ! plot yz-planes pi=acos(-1.) ic=1.5*pi*rds*dxi+1. !special for Wmsn hill c ic=(n+1)/2 i1=ic in=ic ii=ic do 888 i=i1,in,ii do 300 k=1,l do 300 j=1,m vyz(j,k)=0.5*(v(i,j,k)+v(i+isx,j,k)) 300 wyz(j,k)=0.5*(w(i,j,k)+w(i+isx,j,k))*(2-ivctpl) . +0.5*(oz(i,j,k)+oz(i+isx,j,k))*(ivctpl-1) do 2017 k=1,l do 2017 j=1,m xnor0=sqrt(wyz(j,k)**2+vyz(j,k)**2) wyz(j,k)=wyz(j,k)*dy*dzi*rat2 xnort=sqrt(wyz(j,k)**2+vyz(j,k)**2) xcos=vyz(j,k)/(xnort+1.e-15) xsin=wyz(j,k)/(xnort+1.e-15) vyz(j,k)=xnor0*xcos 2017 wyz(j,k)=xnor0*xsin if(ibupl.eq.1) then do 301 k=1,l do 301 j=1,m fyz(j,k)=( th(i,j,k)+ th(i+isx,j,k)) C . /(th0(i,j,k)+th0(i+isx,j,k)) 301 continue call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,1,nclv) endif if(ithpl.eq.1) then ilog=1 ! plot log(theta) do k=1,l do j=1,m if(ilog.eq.1) then fyz(j,k)= alog(0.5*(th(i, j ,k)+the(i, j ,k)+ . th(i+isx,j,k)+the(i+isx,j,k))) else fyz(j,k)= 0.5*(th(i, j ,k)+the(i, j ,k)+ . th(i+isx,j,k)+the(i+isx,j,k)) end if end do end do c nclvs=3*nclv call yzplot(i,isx,fyz,vyz,wyz,m,l,0,2,nclvs) endif iprint=0 if(iprint.eq.1) then print*,'E2:plot' print*,'i,isx,nclvs=',i,isx,nclvs write(6,666) (fyz(16,k),k=1,l) write(6,666) (fyz(j,16),j=1,m) write(6,666) (vyz(16,k),k=1,l) write(6,666) (vyz(j,16),j=1,m) write(6,666) (wyz(16,k),k=1,l) write(6,666) (wyz(j,16),j=1,m) end if 666 format(2x,10(e15.7,1x)) if(iprpl.eq.1) then do 303 k=1,l do 303 j=1,m fyz(j,k)=p(i,j,k)*2.*dti if(isx.eq.1) then fyz(j,k)=.5*(fyz(j,k)+p(i+1,j,k)*2.*dti) endif 303 continue call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,3,nclv) endif if(iuvpl.eq.1) then do 304 k=1,l do 304 j=1,m 304 fyz(j,k)=.5*((u(i,j,k)+u(i+isx,j,k))-(ue(i,j,k)+ue(i+isx,j,k))) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,4,nclv) endif if(ivvpl.eq.1) then do 3041 k=1,l do 3041 j=1,m 3041 fyz(j,k)=.5*((v(i,j,k)+v(i+isx,j,k))-(ve(i,j,k)+ve(i+isx,j,k))) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,41,nclv) endif if(iozpl.eq.1) then do 305 k=1,l do 305 j=1,m 305 fyz(j,k)=.5*(oz(i,j,k)+oz(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,5,nclv) endif if(iwvpl.eq.1) then do 306 k=1,l do 306 j=1,m 306 fyz(j,k)=.5*(w(i,j,k)+w(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,6,nclv) endif if(idvpl.eq.1) then do 309 k=1,l do 309 j=1,m 309 fyz(j,k)=.5*(div(i,j,k)+div(i+isx,j,k))*dt call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,9,nclv) endif if(iqvpl.eq.1) then do 310 k=1,l do 310 j=1,m 310 fyz(j,k)=.5*(qv(i,j,k)+qv(i+isx,j,k))*1.e3 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,10,nclv) endif if(iqcpl.eq.1) then do 311 k=1,l do 311 j=1,m 311 fyz(j,k)=.5*(qc(i,j,k)+qc(i+isx,j,k))*1.e3 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,11,nclv) endif if(iqrpl.eq.1) then do 312 k=1,l do 312 j=1,m 312 fyz(j,k)=.5*(qr(i,j,k)+qr(i+isx,j,k))*1.e3 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,12,nclv) endif if(iqial.eq.1) then do 3121 k=1,l do 3121 j=1,m 3121 fyz(j,k)=.5*(qia(i,j,k)+qia(i+isx,j,k))*1.e3 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,31,nclv) endif if(iqibl.eq.1) then do 3122 k=1,l do 3122 j=1,m 3122 fyz(j,k)=.5*(qib(i,j,k)+qib(i+isx,j,k))*1.e3 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,32,nclv) endif if(irhpl.eq.1) then do 313 k=1,l do 313 j=1,m 313 fyz(j,k)=.5*(rhf(i,j,k)+rhf(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,13,nclv) endif if(ithvpl.eq.1) then epsb=rv/rg-1. do 314 k=1,l do 314 j=1,m 314 fyz(j,k)=.5*(th(i,j,k)+the(i,j,k)+epsb*qv(i,j,k)* . th0(i,j,k)+th(i+isx,j,k)+the(i+isx,j,k)+ . epsb*qv(i+isx,j,k)*th0(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,14,nclv) endif if(ikmpl.eq.1) then do 315 k=1,l do 315 j=1,m giav=0.5*(gi(i,j)+gi(i+isx,j)) c zoav=0.5*(zo(i,j)+zo(i+isx,j)) coef=cm*amin1(cL*amax1(float(k-1),1.)*dz/giav,deltl) . *(1-ibcz)+ibcz*deltl c coef=cm*amin1(cL*amax1(float(k-1)*dz/giav,zoav),deltl) tkeav=.5*(tke(i,j,k)+tke(i+isx,j,k)) 315 fyz(j,k)=coef*tkeav*dt/deltc**2 call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,15,nclv) endif if(iripl.eq.1) then do 316 k=1,l do 316 j=1,m 316 fyz(j,k)=.5*(ri(i,j,k)+ri(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,16,nclv) endif if(ichpl.eq.1) then do ispc=1,nspc ifsp=16+ispc do 317 k=1,l do 317 j=1,m 317 fyz(j,k)=.5*(chm(i,j,k,ispc)+chm(i+isx,j,k,ispc)) call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,ifsp,nclv) enddo endif 888 continue endif close yzplots c---------------------------------------------------------------- if(ixypl.eq.1) then ! plot xy-planes do 998 izcr=0,izcr0 if(izcr.eq.0) then k1=1 kl=11 ki=10 else k1=11 kl=11 ki=1 endif do 999 kk=k1,kl,ki if(ivctpl.eq.1) then call inzxy(kk,u,uxy,n,m,l,izcr,0,nkug) call inzxy(kk,v,vxy,n,m,l,izcr,0,nkug) do 400 j=1,m do 400 i=1,n xnor0=sqrt(uxy(i,j)**2+vxy(i,j)**2) vxy(i,j)=vxy(i,j)*dx*dyi*rat3 xnort=sqrt(uxy(i,j)**2+vxy(i,j)**2) xcos=uxy(i,j)/(xnort+1.e-15) xsin=vxy(i,j)/(xnort+1.e-15) uxy(i,j)=xnor0*xcos 400 vxy(i,j)=xnor0*xsin endif if(ibupl.eq.1) then do 401 i=1,n do 401 j=1,m do 401 k=1,l 401 fxyz(i,j,k)=th(i,j,k) C /th0(i,j,k) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,1,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,1,nclv) endif if(ithpl.eq.1) then do i=1,n do j=1,m do k=1,l ilog=0 ! plot log(theta) if(ilog.eq.1) then fxyz(i,j,k)= alog(th(i,j,k)+the(i,j,k)) else fxyz(i,j,k)= th(i,j,k)+the(i,j,k) end if end do end do end do c nclvs=2*nclv call inzxy(kk,th,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,2,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,2,nclv) endif if(iprpl.eq.1) then do 403 i=1,n do 403 j=1,m do 403 k=1,l 403 fxyz(i,j,k)=p(i,j,k)*2.*dti call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,3,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,3,nclv) endif if(iuvpl.eq.1) then do 404 i=1,n do 404 j=1,m do 404 k=1,l 404 fxyz(i,j,k)= u(i,j,k)-ue(i,j,k) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,4,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,4,nclv) endif if(ivvpl.eq.1) then do 4041 i=1,n do 4041 j=1,m do 4041 k=1,l 4041 fxyz(i,j,k)= v(i,j,k)-ve(i,j,k) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,41,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,41,nclv) endif if(iozpl.eq.1) then call inzxy(kk,om,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,5,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,5,nclv) endif if(iwvpl.eq.1) then call inzxy(kk,w,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,6,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,6,nclv) endif if(idvpl.eq.1) then do 409 i=1,n do 409 j=1,m do 409 k=1,l 409 fxyz(i,j,k)= div(i,j,k)*dt call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,9,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,9,nclv) endif if(iqvpl.eq.1) then do 410 i=1,n do 410 j=1,m do 410 k=1,l 410 fxyz(i,j,k)=qv(i,j,k)*1.e3 call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,10,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,10,nclv) endif if(iqcpl.eq.1) then do 411 i=1,n do 411 j=1,m do 411 k=1,l 411 fxyz(i,j,k)=qc(i,j,k)*1.e3 call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,11,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,11,nclv) endif if(iqrpl.eq.1) then do 412 i=1,n do 412 j=1,m do 412 k=1,l 412 fxyz(i,j,k)=qr(i,j,k)*1.e3 call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,12,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,12,nclv) endif if(iqial.eq.1) then do 4121 i=1,n do 4121 j=1,m do 4121 k=1,l 4121 fxyz(i,j,k)=qia(i,j,k)*1.e3 call inzxy(k,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,31,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,31,nclv) endif if(iqibl.eq.1) then do 4122 i=1,n do 4122 j=1,m do 4122 k=1,l 4122 fxyz(i,j,k)=qib(i,j,k)*1.e3 call inzxy(k,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,32,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,32,nclv) endif if(irhpl.eq.1) then call inzxy(kk,rhf,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,13,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,13,nclv) endif if(ithvpl.eq.1) then epsb=rv/rg-1. do 414 i=1,n do 414 j=1,m do 414 k=1,l 414 fxyz(i,j,k)=th(i,j,k)+the(i,j,k)+epsb*qv(i,j,k)*th0(i,j,k) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,14,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,14,nclv) endif if(ikmpl.eq.1) then do 415 k=1,l do 415 i=1,n do 415 j=1,m coef=cm*amin1(cL*amax1(float(k-1),1.)*dz/gi(i,j),deltl) . *(1-ibcz)+ibcz*deltl c coef=cm*amin1(cL*amax1(float(k-1)*dz/gi(i,j),zo(i,j)),deltl) 415 fxyz(i,j,k)=coef*tke(i,j,k)*dt/deltc**2 call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,15,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,15,nclv) endif if(iripl.eq.1) then call inzxy(kk,ri,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,16,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,16,nclv) endif if(ichpl.eq.1) then do ispc=3,nspc ifsp=16+ispc do 417 i=1,n do 417 j=1,m do 417 k=1,l 417 fxyz(i,j,k)=chm(i,j,k,ispc) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,nkug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,ifsp,nclv) if(isfpl.eq.1) call spplot(kk,fxy,n,m,ifsp,nclv) enddo endif 999 continue 998 continue close xyplot endif if(iznav.eq.1) then call zonav(v,vyz,tau,0) call zonav(w,wyz,tau,0) do 5017 k=1,n3 do 5017 j=1,n2 xnor0=sqrt(wyz(j,k)**2+vyz(j,k)**2) wyz(j,k)=wyz(j,k)*dy*dzi xnort=sqrt(wyz(j,k)**2+vyz(j,k)**2) xco=vyz(j,k)/(xnort+1.e-15) xsin=wyz(j,k)/(xnort+1.e-15) vyz(j,k)=xnor0*xcos 5017 wyz(j,k)=xnor0*xsin if(ibupl.eq.1) then do 501 k=1,n3 do 501 j=1,n2 do 501 i=1,n1 501 fxyz(i,j,k)=th(i,j,k) C /the(i,j,k) call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,1,nclv) endif if(ithpl.eq.1) then ilog=1 do 502 k=1,n3 do 502 j=1,n2 do 502 i=1,n1 if(ilog.eq.1) then fxyz(i,j,k)=alog(th(i,j,k)+the(i,j,k)) else fxyz(i,j,k)= th(i,j,k)+the(i,j,k) endif 502 continue call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,0,2,nclvs) endif if(iprpl.eq.1) then do 503 k=1,n3 kp=min0(k+1,n3) km=max0(k-1,1) do 5031 j=1,n2 jp=min0(j+1,n2) jm=max0(j-1,1) do 5032 i=1,n1 5032 fxyz(i,j,k)=( p(i,jp,k)+2.*p(i,j,k)+p(i,jm,k) 1 +p(i,j,kp)+2.*p(i,j,k)+p(i,j,km) )*.125*2.*dti 5031 continue 503 continue call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,3,nclv) endif if(iuvpl.eq.1) then do 504 k=1,n3 do 504 j=1,n2 do 504 i=1,n1 504 fxyz(i,j,k)=u(i,j,k)-0.*ue(i,j,k) call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,4,nclv) endif if(ivvpl.eq.1) then do 5041 k=1,n3 do 5041 j=1,n2 do 5041 i=1,n1 5041 fxyz(i,j,k)=v(i,j,k)-0.*ve(i,j,k) call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,41,nclv) endif if(iwvpl.eq.1) then do 5061 k=1,n3 do 5061 j=1,n2 do 5061 i=1,n1 5061 fxyz(i,j,k)=w(i,j,k) call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,6,nclv) endif if(idvpl.eq.1) then do 5091 k=1,n3 do 5091 j=1,n2 do 5091 i=1,n1 5091 fxyz(i,j,k)=div(i,j,k)*dt call zonav(fxyz,fyz,tau,0) call yzplot(0,0,fyz,vyz,wyz,m,l,ivctpl,9,nclv) endif endif close zaplots c call spectral_phys(u,v,w) !---------------> jad spectra c---------------------------------------------------------------- #if (SPCTPL == 1) c --- Perform spectral analysis on xy planes. Individual 1d c --- spectra are averaged in y for each x line on the specifed c --- plane. Output parameter kug from subroutine inzxy defines c --- underground points which are either avoided or set to zero c --- in this analysis. if((tt.gt.0.) .and. (isppl.eq.1)) then c plot vertical spectrum, at every 80th point if (isptu.eq.1) then do i=1,n,32 do j=1,m c exclude sponge c do k=1,168 do k=1,l ffz(k)= u(i,j,k)-ue(i,j,k) enddo c do the spectral analysis outside write(20) ffz c call specz(ffz,168,i,1) enddo enddo endif do 1098 izcr=0,izcr0 do 510 kk=1,nsppl c do 510 ks=1,l ks = nksppl(kk) if((ks.gt.0) .and. (ks.le.L)) then if(isptu.eq.1) then do 505 i=1,n do 505 j=1,m do 505 k=1,l fxyz(i,j,k)= u(i,j,k)-ue(i,j,k) 505 continue c special power spectrum call inzxy(ks,fxyz,fxy,n,m,l,izcr,1,nkug) do i=1,2 call spxypl(fxy,n,m,1,ks,nkug,i) enddo endif if(isptv.eq.1) then do 506 i=1,n do 506 j=1,m do 506 k=1,l fxyz(i,j,k)= v(i,j,k)-ve(i,j,k) 506 continue call inzxy(ks,fxyz,fxy,n,m,l,izcr,1,nkug) do i=1,2 call spxypl(fxy,n,m,2,ks,nkug,i) enddo endif if(isptw.eq.1) then call inzxy(ks,w,fxy,n,m,l,izcr,1,nkug) do i=1,2 call spxypl(fxy,n,m,3,ks,nkug,i) enddo endif if(isptt.eq.1) then do 508 i=1,n do 508 j=1,m do 508 k=1,l c fxyz(i,j,k)=th(i,j,k)/the(i,j,k)-1. fxyz(i,j,k)=th(i,j,k) 508 continue call inzxy(ks,fxyz,fxy,n,m,l,izcr,1,nkug) do i=1,2 call spxypl(fxy,n,m,4,ks,nkug,i) enddo endif endif 510 continue 1098 continue endif close spectral analysis #endif return end #if (SPCTPL == 1) subroutine spec0(f,n1,n2,k,iflg) dimension f(n1,n2) include 'param.nml' parameter(nm=n-1,nns=nm/2,nnp=nns+1) dimension spc(nnp,m),xx(nnp),a(nnp),b(nnp),cc(nnp), . spav(nnp),re53(nnp) data cc/nnp*2./ character*80 lhead common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 pi=acos(-1.) pi2=2.*pi xnm=1./float(nm) cc(1)=1. cc(nnp)=1. do kk=2,nnp xx(kk)=alog10(float(kk-1)) enddo xmn=0. xmx=float( int(xx(nnp)+1.) ) do 1 j=1,m-1 do jj=1,nnp a(jj)=0. b(jj)=0. do ii=1,nm a(jj)=a(jj)+f(ii,j)*cos(pi2*(ii-1)*(jj-1)*xnm)*xnm b(jj)=b(jj)-f(ii,j)*sin(pi2*(ii-1)*(jj-1)*xnm)*xnm enddo enddo do kk=1,nnp spc(kk,j)=cc(kk)*(a(kk)**2+b(kk)**2) enddo 1 continue do kk=2,nnp spav(kk)=0. do j=1,m-1 spav(kk)=spav(kk)+spc(kk,j)/float(m-1) enddo enddo do kk=2,nnp spav(kk)=alog10(spav(kk)) enddo do j=1,m-1 spmn= 1.e15 spmx=-1.e15 do kk=2,nnp spc(kk,j)=alog10(spc(kk,j)) spmn=amin1(spmn,spc(kk,j)) spmx=amax1(spmx,spc(kk,j)) enddo spmn=int(spmn-1.) spmx=int(spmx+1.) enddo #if (GKS == 1) call set(.1,.9,.1,.9,xmn,xmx,spmn,spmx,1) ipt1=int(192.8+819.2) call gaseti('LTY',1) if(iflg.eq.1) write (lhead,101) time if(iflg.eq.2) write (lhead,102) time if(iflg.eq.3) write (lhead,103) time if(iflg.eq.4) write (lhead,104) time call plchhq(cpux(512),cpuy(ipt1),lhead(1:37),0.015,0.,0.) call labmod('(f3.0)','(f5.0)',4,4,2,2,20,20,0) ix=int(xmx-xmn) iy=int(spmx-spmn) call periml(ix,1,iy,1) c call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) c do j=1,m-1 c call curved(xx(2),spc(2,j),nns) c enddo call setusv('LW',2000) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(xx(2),spav(2),nns) re53(2)=spmx c53=5./3. do kk=3,nnp re53(kk)=amax1(spmn, re53(kk-1)-c53*(xx(kk)-xx(kk-1))) enddo call curved(xx(2),re53(2),nns) call setusv('LW',1000) i1=int(102.4+409.6) call plchhq(cpux(i1),cpuy(50),'log k',0.015,0.,0.) call plchhq(cpux(17),cpuy(i1),'log P',0.015,90.,0.) call frame #endif 101 format(' at time= ',f9.2) 102 format(' at time= ',f9.2) 103 format(' at time= ',f9.2) 104 format(' at time= ',f9.2) 200 format(e11.4,' -->',e11.4) return end subroutine spxypl(fxy, n1, n2, iflg, k, nkug,dsd) c --- Performs spectral analysis of 2D input data array fxy(n1,n2) c --- at grid level k. iflg is an input flag indentifing the field c --- contained in fxy (1=u',2=v',3=w',4=theta'). If underground c --- points exist in the input Cartesian xy plane at level k they c --- are identified by the input value of kug in the appropriate c --- location of the array. c include 'param.nml' integer nmax, numdim c --- set nmax=max(n,m) parameter (nmax=n) parameter (numdim=2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm C --- Load the SRFACE common block COMMON /SRFIP1/ IFR ,ISTP ,IROTS ,IDRX , 1 IDRY ,IDRZ ,IUPPER ,ISKIRT , 2 NCLA ,THETA ,HSKIRT ,CHI , 3 CLO ,CINC ,ISPVAL c --- input parameter declarations real fxy(n,m) c --- local declarations real fx(nmax), a(nmax), b(nmax), kx(nmax), e(nmax), yyp(nmax), 1 avex(nmax), esum(nmax), varx(nmax), xp(nmax), yp(nmax), 2 sdom(nmax), sig(nmax) real ej(nmax,nmax), wsave(4*nmax+15), cr(nmax), ci(nmax) complex c(nmax) real avexy, varxy, ex, sigx, emax, kmax, emin, kmin, varf, 1 varxyy, zkm, twopi integer np, npx, npxy, npy, s1, s2, s2x, s2y, ns, nwork integer i,ii,j,jj,ix,jy,ndim,nd2,nd2p1,s,ixmin,ixmax,jymax, 1 kk, n1d2, n1d2p1, n2d2, n2d2p1, isize integer imin,imax,jmin,jmax,mjrx,mnrx,mjry,mnry,exfmt,eyfmt real del,xlen,xmin,xmax,xlmin,xlmax,ymin,ymax,ylmin,ylmax, 1 xx, yy, zz, cpux, cpuy real slope, xs(2), ys(2) real afit,bfit,ss,st2,sx,sxoss,sy,t real eye(6), stereo integer nns(numdim), ntot, isign, iform, nx, ny, ierr complex work(2*nmax*nmax) real data1((n+2)*m), dkk, dkk1 character*80 title real UL, UR, UB, UT, UX, UY parameter (twopi=6.283185307179586476925286766559) c The following data statements control execution of the spectrum c analysis and provide for plotting options. c dsd - A flag to indicate the type of spectrum to compute. c If dsd =1 1D spectra are computed along the direction of c the first index of fxy, and if dsd=2 the 1D spectra is c computed along the direction of the second index of fxy. c These 1D spectra will averaged in the direction normal to c dsd for output. Otherwise, if dsd ne 1 or 2, a 2D spectrum c is computed and output. c ireset - Set ireset=1 to reset underground values to zero, and c perform Fourier analysis with these zero values included. c Otherwise, if ireset ne 1 the furthest unobstructed c downstream location is determined and only those locations c downstream are Fourier analyzed. c subavg - A flag indicating that the horizontal average of the data c is to be subtracted out before computing the spectrum. c escale - Contols scaling of the resulting spectrum for the plots. c If escale =1, the spectrum is scaled by the variance, by the c variance divided by the wavenumber if escale =2, by wstar**2 c if escale=3, or by Tstar**2 if escale =4. Otherwise no scaling c is performed. c krad - Controls wavenumber definition. If krad=1, wavenumbers c are angular in units of radians/m, otherwise linear in c cylces/m. c kscale - Controls scaling of wavenumber axis for the plots. The c the wavenumber scaled by the domain length in the dsd c direction if kscale=1, or scaled by zi if kscale=2. c Otherwise it is dimensional in units dependent on krad. c LL - Contols log-linear plotting according to NCAR graphics c conventions (LL=1 is linear x and y, LL=2 is linear x, c log y, LL=3 is log x, linear y, LL=4 is log x, log y). c iprint - Set iprint ge 1 to get printed output. c ndec - The number of decades to plot on log-log plots. c plot0 - Set =1 to plot 0 wavenumber. c plotny - Set=1 to plot Nyquist wavenumber (i.e. 2dx). c plotrf - Set=1 to plot reference line of slope on log-log plots, c where setting islope=1 gives -5/3, islope=2 gives -3. c plotsd - Set=1 to plot +/- one sigma deviation from the mean c of the 1D spectra. integer dsd, ireset, subavg, krad, kscale, escale, LL, 1 iprint, ndec, plot0, plotny, plotrf, islope, plotsd data ireset/1/, subavg/0/, escale/3/, kscale/2/, krad/1/, 1 LL/4/, iprint/0/, ndec/2/, plot0/0/, plotny/1/, plotrf/1/, 2 islope/1/, plotsd/0/ common/srprint/ itblpri c if(dsd.eq.0) then call spec0(fxy,n1,n2,k,iflg) return endif c --- print inputs if(iprint.ge.1) then print *,'n1,n2,iflg,k,dsd,nkug,ireset,LL,subavg,kscale,escale=', 1 n1,n2,iflg,k,dsd,nkug,ireset,LL,subavg,kscale,escale if(iprint.ge.3) then do 555 i=1,n1 write(6,222) (fxy(i,j),j=1,n2) 555 continue endif endif c c --- do some consistency checks if(iflg.le.3) escale=3 if(iflg.eq.4) escale=4 if((j3.eq.0).and.((dsd.ne.1).and.(dsd.ne.2))) dsd=1 if((j3.eq.0).and.(plotsd.ne.0)) plotsd=0 if(plotrf.eq.1) then if(islope.eq.2) then slope = -3. else slope = -5./3. endif endif if((kscale.eq.2) .and. (abs(zi).lt.1.0e-30)) then kscale = 0 elseif((escale.eq.3) .and. (abs(wstr).lt.1.0e-30)) then escale = 0 elseif((escale.eq.4) .and. (abs(tstr).lt.1.0e-30)) then escale = 0 endif c c --- remove underground points from the data. If ireset ne 1 c --- analyze only the dataset resulting from downstream points c --- from the largest index with valid data. ixmin = 0 if(nkug.ne.0) then do 10 j=1,n2 do 10 i=1,n1 if(nint(fxy(i,j)).eq.nkug) then if(ireset.eq.1) then fxy(i,j) = 0. else if(dsd.eq.2) then ixmin = max0(ixmin,j) else ixmin = max0(ixmin,i) endif endif endif C# print *,'j,i,fxy,ixmin =',j,i,nint(fxy(i,j)),ixmin 10 continue endif c --- if cyclic reduce dimension by 1 if(dsd.eq.2) then ixmax = n2-ibcy jymax = n1-ibcx else ixmax = n1-ibcx jymax = n2-ibcy if((dsd.ne.1) .and. ((ixmax/2)*2.ne.ixmax)) then c --- ensure first dimension for 2D spectrum is even ixmax = ixmax-1 endif endif ndim = ixmax - ixmin xlen = float(ndim-1)*dx ixmin = ixmin + 1 nd2 = ndim/2 nd2p1 = nd2 + 1 c if(ndim.le.1) then write(6,110) k return endif if(iprint.ge.1) then print *,'nmax,ixmax,jymax =',nmax,ixmax,jymax print *,'kug,ixmin,ndim,nd2 =',nkug,ixmin,ndim,nd2 print *,'xlen =',xlen endif c c --- compute the mean of the input data on the xy plane avexy = 0. npxy = 0 do 14 jy=1,jymax avex(jy) = 0. npx = 0 do 12 ix=ixmin,ixmax if(dsd.eq.2) then avex(jy) = avex(jy) + fxy(jy,ix) avexy = avexy + avex(jy) else avex(jy) = avex(jy) + fxy(ix,jy) avexy = avexy + avex(jy) endif npx = npx + 1 npxy = npxy + 1 12 continue avex(jy) = avex(jy)/float(npx) 14 continue avexy = avexy/float(npxy) c c --- compute the variance of the input data on the xy plane varxy = 0. npxy = 0 do 16 jy=1,jymax do 15 ix=ixmin,ixmax varxy = varxy + fxy(ix,jy)**2 npxy = npxy + 1 15 continue 16 continue varxy = varxy/float(npxy) c --- check if data is worth further analysis if(varxy.lt.1.0e-30) then write(6,120) iflg, varxy, npxy return endif c if((dsd.eq.1) .or. (dsd.eq.2)) then c --- compute and average 1d spectra c c --- initialize the 1D FFT routines for length ndim. CALL CFFTI (NDIM,WSAVE) c c --- Loop over lines in dsd direction varxyy = 0. npy = 0 do 18 s=1,nd2p1 esum(s) = 0. 18 continue do 50 jy=1,jymax npy = npy+1 c --- form a 1D array of data on each x line do 20 ix=ixmin,ixmax i = ix - ixmin + 1 if(dsd.eq.2) then fx(i) = fxy(jy,ix) else fx(i) = fxy(ix,jy) endif if(subavg.eq.1) then fx(i) = fx(i) - avex(jy) avex(jy) = 0. endif 20 continue c --- compute variance of input data sigx = 0. npx = 0 do 22 ix=ixmin,ixmax i = ix - ixmin + 1 sigx = sigx + fx(i)**2 npx = npx + 1 22 continue varx(jy) = sigx/float(npx) varxyy = varxyy + varx(jy) c c --- perform the FFT on the 1D data do 23 i=1,ndim c(i) = CMPLX(fx(i),0.0) 23 continue CALL CFFTF (NDIM,C,WSAVE) do 24 s=1,nd2p1 cr(s) = REAL(c(s))/ndim ci(s) = -AIMAG(c(s))/ndim 24 continue e(1)= cr(1)**2 + ci(1)**2 e(nd2p1)= cr(nd2p1)**2 + ci(nd2p1)**2 do 25 s=2,nd2 e(s)=2.*(cr(s)**2 + ci(s)**2) 25 continue c c --- form the average and variance varf = 0. do 40 s=1,nd2p1 esum(s) = esum(s) + e(s) ej(jy,s) = e(s) varf = varf + e(s) 40 continue c c --- print out the results if iprint=1 if(iprint.ge.1) then print *,'spectra at j =',jy print *,'avex(j),varx(j),varf =',avex(jy),varx(jy),varf do 45 s=1,nd2p1 write(6,115) s-1,cr(s),ci(s),e(s) 45 continue c if(iprint.ge.2) then c --- test by computing coefficients directly A(1) = 0. A(ND2P1) = 0. DO 33 J=1,NDIM A(1) = A(1) + FX(J) A(ND2P1) = A(ND2P1) + FX(J)*(-1)**J 33 CONTINUE A(1) = A(1)/ND2 A(ND2P1) = A(ND2P1)/ND2 B(1) = 0. B(ND2P1) = 0. DO 36 S=2,ND2 A(S) = 0. B(S) = 0. DO 35 J=1,NDIM T = TWOPI*(S-1)*(J-1)/NDIM A(S) = A(S) + FX(J)*COS(T) B(S) = B(S) + FX(J)*SIN(T) 35 CONTINUE A(S) = A(S)/ND2 B(S) = B(S)/ND2 36 CONTINUE do 37 s=1,nd2p1 print *,'s,a,afft =',s,a(s)/2.,cr(s) print *,'s,b,bfft =',s,b(s)/2.,ci(s) 37 continue c PRINT *,'CHECKING INVERSES' CALL CFFTB (NDIM,C,WSAVE) do 46 i=1,ndim write(6,113) i,fx(i),c(i)/ndim 46 continue endif !iprint.eq.2 endif !iprint.eq.1 c c --- end of j loop 50 continue varxyy = varxyy/float(npy) c if(iprint.ge.3) then PRINT *,'E SUMS' do 47 s=1,ND2P1 write(6,116) s-1,esum(s) 47 continue endif c c --- Now compute the power after appropriate normalization. emin = 1.0e+10 kmin = 1.0e+10 emax = 0. kmax = 0. varf = 0. do 60 s=1,nd2p1 kx(s) = float(s-1) if(krad.eq.1) kx(s) = twopi*kx(s) esum(s) = esum(s)/jymax e(s) = esum(s) varf = varf + esum(s) emin = amin1(emin,e(s)) kmin = amin1(kmin,kx(s)) emax = amax1(emax,e(s)) kmax = amax1(kmax,kx(s)) 60 continue c if(iprint.ge.1) then print *,'npxy,avexy,varxy,varxyy,varf =',npxy,avexy, 1 varxy,varxyy,varf print *,'LL,emin,emax,kmin,kmax =',LL,emin,emax,kmin,kmax do 64 s=1,nd2p1 write(6,118) s-1,kx(s),e(s) 64 continue endif c c --- set up values to plot in xp,yp if(plot0.eq.0) then s1=2 else s1=1 endif if(plotny.eq.0) then s2=nd2p1-1 else s2=nd2p1 endif np = s2-s1+1 j = 0 xmax = 0. ymax = 0. do 65 s=s1,s2 j=j+1 if(kscale.eq.1) then c --- nondimensionalize by domain length, xlen xp(j) = kx(s) elseif(kscale.eq.2) then c --- nondimensionalize by zi xp(j) = (kx(s)/xlen)*zi else c --- dimensional in cyc/m xp(j) = kx(s)/xlen endif xmax = amax1(xmax,xp(j)) if(escale.eq.1) then yp(j) = e(s)/varxy elseif(escale.eq.2) then yp(j) = e(s)*kx(s)/varxy elseif(escale.eq.3) then yp(j) = e(s)/(wstr**2) ccc yp(j) = kx(s)/xlen*zi*e(s)/(wstr**2) elseif(escale.eq.4) then yp(j) = e(s)/(tstr**2) ccc yp(j) = kx(s)/xlen*zi*e(s)/(tstr**2) else yp(j) = e(s) endif ymax = amax1(ymax,yp(j)) 65 continue np = j c c --- plot the average 1D spectrum at level k on linear or c --- log axes with appropriate scalings determined by escale if((LL.le.1) .or. (LL.gt.4)) then c --- linear x linear y LL=1 exfmt = 0 mnrx = 5 imax = 5 CALL SCALE1(0.,xmax, imax, UL, UR, del, ierr) mjrx = (UR-UL)/del if(abs(del).lt.1.0e-4) exfmt = 1 if(ierr.ne.0) then exfmt = 1 xlmax = alog10(xmax) imax = int(xlmax) if(xlmax.ge.0.) imax = imax + 1 UL = 0. UR = 10.0**imax mjrx = 5 endif c eyfmt = 0 jmax = 5 CALL SCALE1(0.,ymax, jmax, UB, UT, del, ierr) mjry = (UT-UB)/del if(abs(del).lt.1.0e-4) eyfmt = 1 if(ierr.ne.0) then eyfmt = 1 ylmax = alog10(ymax) jmax = int(ylmax) if(ylmax.ge.0.) jmax = jmax + 1 UB = 0. UT = 10.0**jmax mjry = 5 endif mnry = 5 c elseif(LL.eq.2) then c --- linear x log10 y exfmt = 0 mnrx = 5 imax = 5 CALL SCALE1(0.,xmax, imax, UL, UR, del, ierr) mjrx = (UR-UL)/del if(abs(del).lt.1.0e-4) exfmt = 1 if(ierr.ne.0) then exfmt = 1 xlmax = alog10(xmax) imax = int(xlmax) if(xlmax.ge.0.) imax = imax + 1 UL = 0. UR = 10.0**imax mjrx = 5 endif c jmax = int(alog10(ymax)) + 1 jmin = jmax-ndec UB = 10.0**jmin UT = 10.0**jmax mjry = 1 mnry = 0 eyfmt = 1 c elseif(LL.eq.3) then c --- log10 x linear y exfmt = 1 xlmax = alog10(xmax) imax = int(xlmax) if(xlmax.gt.0.) imax = imax + 1 xlmin = alog10(xp(1)) imin = int(xlmin) UL = 10.0**imin UR = 10.0**imax mjrx = 1 mnrx = 0 c eyfmt = 0 mnry = 5 jmax = 5 CALL SCALE1(0.,ymax, jmax, UB, UT, del, ierr) mjry = (UT-UB)/del if(abs(del).lt.1.0e-4) eyfmt = 1 if(ierr.ne.0) then eyfmt = 1 ylmax = alog10(ymax) jmax = int(ylmax) if(ylmax.ge.0.) jmax = jmax + 1 UB = 0. UT = 10.0**jmax mjry = 5 endif c elseif(LL.eq.4) then c --- log10 x log10 y mjrx = 1 mnrx = 0 exfmt = 1 xlmax = alog10(xmax) imax = int(xlmax) if(xlmax.gt.0.) imax = imax + 1 imin = imax - ndec UL = 10.0**imin UR = 10.0**imax c mjry = 1 mnry = 0 eyfmt = 1 ylmax = alog10(ymax) jmax = int(ylmax) if(ylmax.gt.0.) jmax = jmax + 1 jmin = jmax - ndec UB = 10.0**jmin UT = 10.0**jmax c endif !LL eq 1,2,3,4 c c --- protect against plotting outside plot window do 70 j=1,np xp(j) = amax1(xp(j),UL) xp(j) = amin1(xp(j),UR) yp(j) = amax1(yp(j),UB) yp(j) = amin1(yp(j),UT) 70 continue c if(iprint.ge.2) then print *,'np=',np do 72 j=1,np write(6,119) j, xp(j), yp(j) 72 continue print *,'UL,UR,UB,UT,LL=',UL,UR,UB,UT,LL print *,'imin,imax,jmin,jmax=',imin,imax,jmin,jmax print *,'mjrx,mnrx,mjry,mnry=',mjrx,mnrx,mjry,mnry print *,'exfmt,eyfmt=',exfmt,eyfmt endif c #if (GKS == 1) c --- set up the plot call set(.175,.90,.175,.90,UL,UR,UB,UT,LL) call gaseti('LTY',1) c --- attach a title zkm = float(k-1)*dz/1000. if(iflg.eq.1) write (title,101) time,zkm if(iflg.eq.2) write (title,102) time,zkm if(iflg.eq.3) write (title,103) time,zkm if(iflg.eq.4) write (title,104) time,zkm c print *,'title =',title(1:51) ux = cpux(512) uy = cpuy(1012) call plchhq(ux,uy,title(1:51),0.015,0.,0.) c --- label ordinate according to escale ux = cpux(20) uy = cpuy(512) if(escale.eq.1) then call plchhq(ux,uy,'E(k)/Var',0.025,90.,0.) elseif(escale.eq.2) then call plchhq(ux,uy,'kE(k)/Var',0.025,90.,0.) elseif(escale.eq.3) then call plchhq(ux,uy,'E(k)/w?B1?*?S1?2',0.025,90.,0.) ccc call plchhq(ux,uy,'E(k)/w:B1:*:S1:2',0.025,90.,0.) ccc call plchhq(ux,uy,'kE(k)/w:B1:*:S1:2',0.025,90.,0.) elseif(escale.eq.4) then call plchhq(ux,uy,'E(k)/w?B1?*?S1?2',0.025,90.,0.) ccc call plchhq(ux,uy,'E(k)/w:B1:*:S1:2',0.025,90.,0.) ccc call plchhq(ux,uy,'kE(k)/t:B1:*:S1:2',0.025,90.,0.) else call plchhq(ux,uy,'E(k)',0.025,90.,0.) endif c --- label abscissa according to kscale ux = cpux(512) uy = cpuy(80) if(kscale.eq.1) then call plchhq(ux,uy,'kL',0.025,0.,0.) elseif(kscale.eq.2) then call plchhq(ux,uy,'kz?B?i',0.025,0.,0.) ccc call plchhq(ux,uy,'kz:B:i',0.025,0.,0.) else if(krad.eq.1) then call plchhq(ux,uy,'k(rad/m)',0.025,0.,0.) else call plchhq(ux,uy,'k(cy/m)',0.025,0.,0.) endif endif call gaseti('LTY',1) if((exfmt.eq.1).and.(eyfmt.eq.0)) then call labmod('(1PE7.1)','(f6.4)',7,6,15,15,0,0,0) elseif((eyfmt.eq.1).and.(exfmt.eq.0)) then call labmod('(f7.2)','(1PE7.1)',6,7,15,15,0,0,0) elseif((exfmt.eq.0).and.(eyfmt.eq.0)) then call labmod('(f7.2)','(f6.4)',6,6,15,15,0,0,0) else call labmod('(1PE7.1)','(1PE7.1)',7,7,15,15,0,0,0) endif c --- specify major and minor tick marks on x,y respectively call periml(mjrx,mnrx,mjry,mnry) c --- specify solid ($) line of length 10 and width 12 units call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) c --- plot the points call curved(xp,yp,np) #endif if(itblpri.eq.1) then 770 format(4x,e14.7) if(iflg.eq.3) then print 701 701 format(2x,'w spec. yp(j)=e(s)/wstr**2') print 770, (yp(j),j=1,np) c print 702 c 702 format(2x,' abscissa xp(j) = (kx(s)/xlen)*zi ') c print 770, (xp(j),j=1,np) endif c if(iflg.eq.4) then c print 703 c 703 format(2x,'th spec. yp(j)=e(s)/tstr**2') c print 770, (yp(j),j=1,np) c print 702 c print 770, (xp(j),j=1,np) c endif endif C --- plot +/- one sigma lines as dashed if(plotsd.eq.1) then do 75 s=s1,s2 sx = 0. c --- compute average of data plotted do 73 j=1,jymax if(escale.eq.1) then ex = ej(j,s)/varxy elseif(escale.eq.2) then ex = ej(j,s)*kx(s)/varxy elseif(escale.eq.3) then ex = ej(j,s)/(wstr**2) elseif(escale.eq.4) then ex = ej(j,s)/(tstr**2) else ex = ej(j,s) endif ej(j,s) = ex sx = sx + ex 73 continue esum(s) = sx/float(jymax) c --- compute standard deviation (sig) and standard deviation c --- of mean (sdom) for data plotted sigx = 0. do 74 j=1,jymax sigx = sigx + (ej(j,s)-esum(s))**2 74 continue sig(s) = sqrt(sigx/float(jymax-1)) sdom(s) = sig(s)/sqrt(float(jymax)) if(iprint.ge.1) then print *,'s,esum(s)=',s,esum(s) print *,'s,sig(s),sdom(s)=',s,sig(s),sdom(s) endif 75 continue c --- plot +- sdom i=0 do 76 s=s1,s2 i=i+1 yyp(i) = esum(s) + sdom(s) yyp(i) = amax1(yyp(i),UB) yyp(i) = amin1(yyp(i),UT) 76 continue #if (GKS == 1) call dashdc('$''$''$''$''$''$''',10,12) call curved(xp,yyp,np) #endif i=0 do 77 s=s1,s2 i=i+1 yyp(i) = esum(s) - sdom(s) yyp(i) = amax1(yyp(i),UB) yyp(i) = amin1(yyp(i),UT) 77 continue #if (GKS == 1) call curved(xp,yyp,np) #endif c endif c c --- plot the reference line for log-log plots if((plotrf.eq.1) .and. (LL.eq.4)) then xlmax = alog10(0.6*UR) ylmin = jmin + float(ndec)/2. xlmin = imax - float(ndec)/4. ylmax = ylmin - slope*(xlmax-xlmin) ymax = 10.**ylmax if(ymax.gt.UT) then ymax = 0.6*UT ylmax = alog10(ymax) xlmin = xlmax + (ylmax-ylmin)/slope endif xmin = 10.**xlmin xmax = 10.**xlmax ymin = 10.**ylmin ns = 2 xs(1) = xmin ys(1) = ymax xs(2) = xmax ys(2) = ymin #if (GKS == 1) c --- specify solid ($) line of length 10 and width 8 units call dashdc('$$$$$$$$$$$$$$$$$$$$',10,8) c --- plot the points call curved(xs,ys,ns) c --- label it ux = 1.05*xmin uy = ymax if(islope.eq.2) then call plchhq(ux,uy,'-3',0.015,0.,-1.) else call plchhq(ux,uy,'-5/3',0.015,0.,-1.) endif #endif c if(iprint.ge.1) then print *,'slope,xmin,ymin,xmax,ymax=',slope,xmin,ymin,xmax, 1 ymax c --- compute slope of least squares linear fit to data i=0 sx=0. sy=0. st2=0. afit=0. do 81 s=np/2,np i=i+1 xp(i) = alog10(xp(i)) yp(i) = alog10(yp(i)) sx=sx+xp(i) sy=sy+yp(i) 81 continue np = i ss=float(np) sxoss=sx/ss bfit=0. do 82 i=1,np t=xp(i)-sxoss st2=st2+t*t bfit=bfit+t*yp(i) 82 continue bfit=bfit/st2 afit=(sy-sx*bfit)/ss print *,'for last n points: np,afit,bfit =',np,afit,bfit endif !iprint.eq.1 endif !LL.eq.4 c #if (GKS == 1) c --- advance the frame call frame #endif c else c c --- compute and plot the 2D spectrum nns(1) = ndim nns(2) = jymax ntot = nns(1)*nns(2) nwork = nmax*nmax n1d2 = nns(1)/2 n1d2p1 = n1d2+1 n2d2 = nns(2)/2 n2d2p1 = n2d2+1 NTOT = N1D2*N2D2 if(plot0.eq.0) then s1=2 else s1=1 endif if(plotny.eq.0) then s2x=n1d2p1-1 s2y=n2d2p1-1 else s2x=n1d2p1 s2y=n2d2p1 endif c c --- set up coordinate axes for x and y wavenumbers i=0 xmax = -1.0e30 do 97 s=s1,s2x kx(s) = float(s-1) i=i+1 if(kscale.eq.1) then c --- nondimensionalize by domain length, xlen xp(i) = kx(s) elseif(kscale.eq.2) then c --- nondimensionalize by zi xp(i) = (kx(s)/xlen)*zi else c --- dimensional in cyc/m xp(i) = kx(s)/xlen endif if((LL.eq.3) .or. (LL.eq.4)) then xp(i) = alog10(amax1(xp(i),1.0e-30)) endif xmax = amax1(xmax,xp(i)) 97 continue nx = i j=0 ymax = -1.0e30 do 98 s=s1,s2y kx(s) = float(s-1) j=j+1 if(kscale.eq.1) then c --- nondimensionalize by domain length, xlen yp(j) = kx(s) elseif(kscale.eq.2) then c --- nondimensionalize by zi yp(j) = (kx(s)/xlen)*zi else c --- dimensional in cyc/m yp(j) = kx(s)/xlen endif if((LL.eq.3) .or. (LL.eq.4)) then yp(j) = alog10(amax1(yp(j),1.0e-30)) endif ymax = amax1(ymax,yp(j)) 98 continue ny = j ymax = amax1(ymax,xmax) if(iprint.ge.1) then print *,'computing 2D spectra: nx,ny,s1,s2x,s2y,ymax =', 1 nx,ny,s1,s2x,s2y,ymax print *,'xp=',xp print *,'yp=',yp endif c c --- call the 2D spectral decomposition program to get the c --- Fourier amplitudes ISIGN = +1 IFORM = 0 ii=0 do 92 j=1,nns(2) do 91 i=1,nns(1) ii=ii+1 data1(ii) = fxy(i,j) 91 continue 92 continue CALL FOURT (data1,nn,numdim,ISIGN,IFORM,WORK,nwork,ierr) if(iprint.ge.1) then print *,'FOURT results: nn,numdim,isign,iform,ierr =', 1 nns(1),nns(2),numdim,isign,iform,ierr endif c c --- set up array of spectral amplitudes for use with SRFACE emax = -1.0e30 emin = 1.0e30 if(ierr.eq.0) then kk = 0 do 94 j=1,n2d2p1 do 93 i=1,n1d2p1 kk = kk+1 dkk = data1(kk)/ntot kk = kk+1 dkk1 = data1(kk)/ntot if((i.ge.s1).and.(j.ge.s1) .and. 1 (i.le.s2x).and.(j.le.s2y)) then ii=i-s1+1 jj=j-s1+1 ex = dkk**2 + dkk1**2 if(escale.eq.1) then ex = ex/varxy elseif(escale.eq.2) then ex = ex*kx(s)/varxy elseif(escale.eq.3) then ex = ex/(wstr**2) elseif(escale.eq.4) then ex = ex/(tstr**2) endif ej(ii,jj) = ex emax = amax1(ej(ii,jj),emax) emin = amin1(ej(ii,jj),emin) if(iprint.ge.2) then write(6,114) j,i,kk,jj,ii,dkk,dkk1,ej(ii,jj) endif !iprint.ge.2 endif 93 continue 94 continue c c --- rescale if log option was requested if((LL.eq.2) .or. (LL.eq.4)) then emax = -1.0e30 ylmin = alog10(amax1(emin,1.0e-30)) do 87 jj=1,ny do 86 ii=1,nx ej(ii,jj) = alog10(amax1(ej(ii,jj),1.0e-30)) - ylmin emax = amax1(ej(ii,jj),emax) 86 continue 87 continue endif c c --- SRFACE requires magnitude of e consistent with axis c --- scalings sy = 0.5*ymax/emax do 89 jj=1,ny do 88 ii=1,nx ej(ii,jj)=ej(ii,jj)*sy 88 continue 89 continue #if (GKS == 1) c --- plot it eye(1) = -xp(nx) eye(2) = -yp(ny) eye(3) = 1.5*amax1(abs(eye(1)),abs(eye(2))) eye(4) = 0. eye(5) = 0. eye(6) = 0. stereo = 0.0 call gselnt(0) C --- Set SRFACE parameters to supress FRAME call and draw skirt. IFR = 0 ISKIRT = 1 HSKIRT = 0. call srface(xp, yp, ej, work, nmax, nx, ny, eye, stereo) isize = 35 xx = (xp(nx)-xp(1))/2. yy = yp(1) - .05*(yp(ny)-yp(1)) zz = 0. if((LL.eq.3) .or. (LL.eq.4)) then call pwrzs(xx,yy,zz,'LOG(K) -',8,isize,+1,+2,0) else call pwrzs(xx,yy,zz,'K -',3,isize,+1,+2,0) endif xx = xp(1) - .05*(xp(nx)-xp(1)) yy = (yp(ny)-yp(1))/2. if((LL.eq.3) .or. (LL.eq.4)) then call pwrzs(xx,yy,zz,'- LOG(L)',8,isize,-2,+1,0) else call pwrzs(xx,yy,zz,'- L',3,isize,-2,+1,0) endif c --- attach a title zkm = float(k-1)*dz/1000. if(iflg.eq.1) write (title,105) time,zkm if(iflg.eq.2) write (title,106) time,zkm if(iflg.eq.3) write (title,107) time,zkm if(iflg.eq.4) write (title,108) time,zkm ux = cpux(512) uy = cpuy(1012) call pwrit(ux,uy,title(1:51),51,2,0,0) c --- now advance to the next frame call frame #endif c c --- process error conditions from FOURT elseif(ierr.eq.-1) then write(6,130) iform, (nns(i),i=1,numdim) elseif(ierr.eq.-2) then write(6,170) nwork else write(6,180) ierr endif c endif !1D or 2D c 101 format(' spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 102 format(' spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 103 format(' spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 104 format(' spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 105 format(' 2d uprime spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 106 format(' 2d vprime spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 107 format(' 2d wprime spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 108 format('2d thprime spectrum at t(min)= ',f7.2,', z(km)=',f6.2) 110 format(1h ,'Error in spxypl: all points underground for level =', 1 i4) 112 format(1h ,2i3,1p,2e12.4) 113 format(1H ,'i,fx,Re(C),Im(C) =',I3,1P,3E14.6) 114 format(1h ,5i5,1p,4e12.4) 115 format(1H ,'s,a(s),b(s),E(s) =',I3,1P,3E14.6) 116 format(1H ,'s,esum(s) =',I3,1P,3E14.6) 118 format(1h ,'s,k(s),e(s) =',i3,1p,2e14.6) 119 format(1h ,'j,x(j),y(j) =',i4,1p,2e14.6) 120 format(1h ,'input variance too small for field =',i4,/, 1 ' variance =',e14.6,' number of input points =',i5) 130 FORMAT(1H ,'ERROR IN FOURT. N(1) =',I4,' IS NOT EVEN.') 170 FORMAT(1H ,'ERROR IN FOURT. NWORK =',I4,' IS TOO SMALL') 180 FORMAT(1H ,'ERROR IN FOURT. UNRECOGNIZED ERROR CODE =',I4) 222 format(1h ,1p,5e15.6) c return end subroutine scale1(xmin, xmax, n, xminp, xmaxp, dist,ierr) c given xmin, xmax and n, scale1 finds a new range xminp and c xmaxp divisible into approximately n linear intervals of c size dist. on return ierr=-1 if improper inputs, otherwise c ierr is set to 0. c vint is an array of acceptable values for dist (times an c integer power of 10). c sqr is an array of geometric means of adjacent values of c vint. it is used as break points to determine which vint c value to assign to dist. del accounts for computer c roundoff. it should be greater than the roundoff expected c from a division and float operation, and less than the c minimum increment of the plotting device dived by the c plot size times the number of intervals n. c ref: algorithm 462 from collected algorithms of the CACM implicit none real xmin, xmax, xminp, xmaxp, dist integer n, ierr real a, al, b, del, fm1, fm2, fn integer nal, i, m1, m2 real vint(4), sqr(3) data vint/1., 2., 5., 10./ data sqr/1.414214, 3.162278, 7.071068/ data del/0.00002/ c c check whether proper input values were supplied if((xmin.ge.xmax).or.(n.le.0)) then ierr=-1 return endif c c find approximate interval size a ierr = 0 fn = n a = (xmax-xmin)/fn al = alog10(a) nal = al if(a.lt.1.) nal = nal-1 c scale a into variable b between 1 and 10 b = a/(10.**nal) c find the closest permissible value for b do 20 i=1,3 if(b.lt.sqr(i)) go to 30 20 continue i=4 c compute the interval size 30 dist = vint(i)*10.**nal fm1 = xmin/dist m1 = fm1 if(fm1.lt.0.) m1=m1-1 if(abs(float(m1)+1.-fm1).lt.del) m1 = m1 + 1 c find the new minimum and maximum limits xminp = dist*float(m1) fm2 = xmax/dist m2 = fm2+1. if(fm2.lt.(-1.)) m2=m2-1 if(abs(fm2+1.-float(m2)).lt.del) m2 = m2 - 1 xmaxp = dist*float(m2) c adjust limits to account for roundoff if necessary if(xminp.gt.xmin) xminp = xmin if(xmaxp.lt.xmax) xmaxp = xmax c return end #endif C PLOTPL #endif #if (ENERGY == 1) subroutine sort(arr) include 'param.nml' include 'msg.inc' dimension arr(1-ih:np+ih,1-ih:mp+ih,l) dimension sor(np*mp*l) ik=1 do k=2,l-1 do j=1,mp do i=1,np c sor(ik)=arr(i,j,k) c vertical filter density field before sorting sor(ik)=0.25*(arr(i,j,k+1)+2.*arr(i,j,k)+arr(i,j,k-1)) ik=ik+1 enddo enddo enddo c filter do j=1,mp do i=1,np sor(ik)=arr(i,j,1) ik=ik+1 sor(ik)=arr(i,j,l) ik=ik+1 enddo enddo nml=np*mp*l do ik=1,nml do ii=ik,nml if ( sor(ii) .lt. sor(ik) ) then temp=sor(ii) sor(ii)=sor(ik) sor(ik)=temp endif enddo enddo c largest values at the bottom ik=1 nml=np*mp*l do k=1,l do j=1,mp do i=1,np arr(i,j,k)=sor(nml-ik+1) ik=ik+1 enddo enddo enddo return end subroutine energy(u,v,w,oz,th,p,ehise,ivis,ikf) include 'param.nml' include 'msg.inc' dimension tau(l,1-ih:np+ih,1-ih:mp+ih,2) dimension ehise(nth,17) dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l) . ox1(1-ih:np+ih,1-ih:mp+ih,l), . oy1(1-ih:np+ih,1-ih:mp+ih,l), . oz1(1-ih:np+ih,1-ih:mp+ih,l), dimension p(1-ih:np+ih,1-ih:mp+ih,l), . fx(1-ih:np+ih,1-ih:mp+ih,l), . fy(1-ih:np+ih,1-ih:mp+ih,l), . fz(1-ih:np+ih,1-ih:mp+ih,l), . ft(1-ih:np+ih,1-ih:mp+ih,l) dimension fox(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foy(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . foz(1-ih:ntsp+ih,1-ih:mtsp+ih,lts), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . fqr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . ftke(1-ih:nkep+ih,1-ih:mkep+ih,lke) dimension chm(1-ih:nchp+ih, 1-ih:mchp+ih, lds, nspc), . fchm(1-ih:nchp+ih, 1-ih:mchp+ih, lds, nspc) dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqia(1-ih:nicp+ih,1-ih:micp+ih,lic), . fqib(1-ih:nicp+ih,1-ih:micp+ih,lic) dimension pfx(1-ih:np+ih, 1-ih:mp+ih, l), . pfy(1-ih:np+ih, 1-ih:mp+ih, l), . pfz(1-ih:np+ih, 1-ih:mp+ih, l) dimension fu(1-ih:np+ih, 1-ih:mp+ih, l), . fv(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l) dimension ekbot(1-ih:np+ih, 1-ih:mp+ih), . epbot(1-ih:np+ih, 1-ih:mp+ih), . pnx(1-ih:np+ih, 1-ih:mp+ih), . pny(1-ih:np+ih, 1-ih:mp+ih), . pnz(1-ih:np+ih, 1-ih:mp+ih) dimension sorarr(1-ih:np+ih, 1-ih:mp+ih,l) common/davies/ relx(np,mp),rely(np,mp),zab,towx,towy,towz, 1 dxabL,dxabR,dyab,iab,iabb,iabth,iabqw c 1 dxab,dyab,iab,iabth,iabqw common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/ttbar/wb(1-ih:np+ih,1-ih:mp+ih,l), . ub(1-ih:np+ih,1-ih:mp+ih,l), . vb(1-ih:np+ih,1-ih:mp+ih,l), . rhob(1-ih:np+ih,1-ih:mp+ih,l), . reyb(1-ih:np+ih,1-ih:mp+ih,l), . ureyb(1-ih:np+ih,1-ih:mp+ih,l), . wstb(1-ih:np+ih,1-ih:mp+ih,l,4), . rstb(1-ih:np+ih,1-ih:mp+ih,l,4), . ustb(1-ih:np+ih,1-ih:mp+ih,l,4), . vstb(1-ih:np+ih,1-ih:mp+ih,l,4), . istore fsi(zt)=zt c assuming boussinesq !!!! lipps==0 do ii=1,17 ehise(ikf,ii)=0. enddo c kin energy do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=0.5*(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2)*dx*dy*dz pfy(i,j,k)=0. enddo enddo enddo do j=1,mp do i=1,np ekbot(i,j)=pfx(i,j,1)/(dx*dy*dz) enddo enddo call sumcns(pfx,pfy,rho,ehise(ikf,1),1) c print *,'kin energy ',ikf,ehise(ikf,1) c pfx(:,:,:)=2.5 c pfz(:,:,:)=1. c rho(:,:,:)=1. c call sumcns(pfx,pfy,rho,ehise(ikf,1),1) c print *,'test kin energy ',ikf,ehise(ikf,1) c total potential energy - environmental do k=1,l do j=1,mp do i=1,np zstr=fsi((k-1)*dz) zcrl=zstr/gi(i,j)+zs(i,j) pfx(i,j,k)=g*zcrl*dx*dy*dz pfy(i,j,k)=0. c pfz(i,j,k)=(1./gi(i,j))*(th(i,j,k)+the(i,j,k)) pfz(i,j,k)=(1./gi(i,j))*th(i,j,k) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,2),1) c available potential energy (pot energy - minimum actual background pot. energy) do k=1,l do j=1,mp do i=1,np sorarr(i,j,k)=th(i,j,k)+the(i,j,k) enddo enddo enddo call sort(sorarr) c available potential energy do k=1,l do j=1,mp do i=1,np zstr=fsi((k-1)*dz) zcrl=zstr/gi(i,j)+zs(i,j) pfx(i,j,k)=g*zcrl*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=(1./gi(i,j)) . *(th(i,j,k)+the(i,j,k)-sorarr(i,j,k)) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,3),1) c background do k=1,l do j=1,mp do i=1,np zstr=fsi((k-1)*dz) zcrl=zstr/gi(i,j)+zs(i,j) pfx(i,j,k)=g*zcrl*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=(1./gi(i,j)) . *(sorarr(i,j,k)-the(i,j,k)) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,15),1) c calculate normal to surface k=1 c note that gradient is normal to surface kk=1 do j=1,mp do i=1,np cx=(s13(i,j)*gmul(kk)-h13(i,j))*gmus(kk) cy=(s23(i,j)*gmul(kk)-h23(i,j))*gmus(kk) cz=gmus(kk)*gi(i,j) zsx=-cx/cz zsy=-cy/cz gnr=sqrt(1.+zsx**2+zsy**2) pnx(i,j)=-zsx/gnr pny(i,j)=-zsy/gnr pnz(i,j)=-1./gnr enddo enddo c total rate of inviscid kinetic energy change == flux at bottom c calculate energy flux at the bottom only, top is assumed flat ehise(ikf,4)=0. do j=1,mp do i=1,np pp=p(i,j,1)*2.*dti ehise(ikf,4)=ehise(ikf,4) . -(rho(i,j,1)*gi(i,j)*ekbot(i,j)+pp) . *(u(i,j,1)*pnx(i,j)+v(i,j,1)*pny(i,j) . +w(i,j,1)*pnz(i,j))*dx*dy enddo enddo c save this, represents external energy flux ?! ehise(ikf,11)=ehise(ikf,4) c total rate of inviscid potential energy change == flux at bottom c calculate energy flux at the bottom only, top is assumed flat ehise(ikf,7)=0. do j=1,mp do i=1,np ehise(ikf,7)=ehise(ikf,7) c . -g*zs(i,j)*(th(i,j,1)+the(i,j,1)) . -g*zs(i,j)*th(i,j,1) . *(u(i,j,1)*pnx(i,j)+v(i,j,1)*pny(i,j) . +w(i,j,1)*pnz(i,j))*dx*dy enddo enddo c save this, represents external energy flux, added ehise(ikf,11)=ehise(ikf,11)+ehise(ikf,7) c calculate absorber towi=1./towz do k=1,l zstr=fsi((k-1)*dz) do j=1,mp do i=1,np zl=zstr/gi(i,j)+zs(i,j) t1=iab*amax1(0.,zl-zab) tau(k,i,j,1)=towi*t1/(zb-zab) c tau(k,i,j,1)=iab*towi*exp((zl-zb)/6.e3) end do end do end do c calculate energy dissipation due to absorber do k=1,l do j=1,mp do i=1,np c relt=relx(i,j)+rely(i,j)-relx(i,j)*rely(i,j) c astr =tau(k,i,j,1)*(1.-relt)+relt relt =(relx(i,j)**2+rely(i,j)**2) !mod Andii & /(relx(i,j)+rely(i,j)+1.e-13) astr =dth*(tau(k,i,j,1)**2+relt**2) & /(tau(k,i,j,1)+relt+1.e-13) pfx(i,j,k)=-astr*(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2)*dx*dy*dz pfy(i,j,k)=0. enddo enddo enddo call sumcns(pfx,pfy,rho,ehise(ikf,5),1) c print *,'dissip energ',ikf,ehise(ikf,5) c update total rate of kinetic energy change ehise(ikf,4)=ehise(ikf,4)+ehise(ikf,5) c reversible rate of exchange with pot. energy due to boyancy flux do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=g*w(i,j,k)*dx*dy*dz pfy(i,j,k)=0. c pfz(i,j,k)=(1./gi(i,j))*(th(i,j,k)+the(i,j,k)) pfz(i,j,k)=(1./gi(i,j))*th(i,j,k) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,6),1) c update total rate of kinetic energy change ehise(ikf,4)=ehise(ikf,4)-ehise(ikf,6) c update total rate of potential energy change ehise(ikf,7)=ehise(ikf,7)+ehise(ikf,6) c irreversible mean kin. energy growth from pot. energy C_{\bar{K}P} iav=4 avi=1./4. if( ikf.eq.1 ) then istore=1 wb(:,:,:)=0.0 ub(:,:,:)=0.0 vb(:,:,:)=0.0 rhob(:,:,:)=0.0 reyb(:,:,:)=0.0 ureyb(:,:,:)=0.0 endif do k=1,l do j=1,mp do i=1,np wb(i,j,k)=wb(i,j,k)+avi*w(i,j,k) ub(i,j,k)=ub(i,j,k)+avi*u(i,j,k) vb(i,j,k)=vb(i,j,k)+avi*v(i,j,k)*j3 c rhob(i,j,k)=rhob(i,j,k)+avi*(th(i,j,k)+the(i,j,k)) rhob(i,j,k)=rhob(i,j,k)+avi*th(i,j,k) wstb(i,j,k,istore)=w(i,j,k) c rstb(i,j,k,istore)=(th(i,j,k)+the(i,j,k)) rstb(i,j,k,istore)=th(i,j,k) ustb(i,j,k,istore)=u(i,j,k) vstb(i,j,k,istore)=v(i,j,k)*j3 enddo enddo enddo if(ikf/iav*iav.eq.ikf) then do is=1,istore do k=1,l do j=1,mp do i=1,np wprime=wstb(i,j,k,is)-wb(i,j,k) rprime=rstb(i,j,k,is)-rhob(i,j,k) reyb(i,j,k)=reyb(i,j,k)+avi*wprime*rprime enddo enddo enddo enddo c mean kin. energy growth from pot. energy C_{\bar{K}P} do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=g*wb(i,j,k)*rhob(i,j,k)*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=1./gi(i,j) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,13),1) c mean kin. energy do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=0.5*(ub(i,j,k)**2+vb(i,j,k)**2+wb(i,j,k)**2)*dx*dy*dz pfy(i,j,k)=0. enddo enddo enddo call sumcns(pfx,pfy,rho,ehise(ikf,16),1) c transient kin energy do is=1,istore do k=1,l do j=1,mp do i=1,np wprime=wstb(i,j,k,is)-wb(i,j,k) uprime=ustb(i,j,k,is)-ub(i,j,k) vprime=vstb(i,j,k,is)-vb(i,j,k) ureyb(i,j,k)=ureyb(i,j,k) . +avi*(uprime**2+vprime**2+wprime**2) enddo enddo enddo enddo do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=0.5*ureyb(i,j,k)*dx*dy*dz pfy(i,j,k)=0. enddo enddo enddo call sumcns(pfx,pfy,rho,ehise(ikf,17),1) c transient kin. energy growth from pot. energy C_{\prime{K}P} do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=g*reyb(i,j,k)*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=1./gi(i,j) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,14),1) do ik=1,3 ehise(ikf-ik,13)=ehise(ikf,13) ehise(ikf-ik,14)=ehise(ikf,14) ehise(ikf-ik,16)=ehise(ikf,16) ehise(ikf-ik,17)=ehise(ikf,17) enddo istore=1 wb(:,:,:)=0.0 ub(:,:,:)=0.0 vb(:,:,:)=0.0 rhob(:,:,:)=0.0 reyb(:,:,:)=0.0 ureyb(:,:,:)=0.0 else istore=istore+1 endif c kinetic energy dissipation due to kinematic viscosity fu,fv,fw c density dissipation due to dissipation of salt/heat #if( SGS == 1 || SGS == 2) if( ivis.eq.1 ) then do k=1,l do j=1,mp do i=1,np ft(i,j,k)=0. fu(i,j,k)=0. fv(i,j,k)=0. fw(i,j,k)=0. enddo enddo enddo #if (SGS == 1) call dissip(u,v,w, 1 th, chm, qv, qc, qr, tke, 1 fx,fy,fz,ft, fchm, qia,qib,fqia,fqib, 3 fqv,fqc,fqr,ftke, fox,foy,foz,pfx,pfy,pfz, 3 fu, fv, fw, 3 ox,oy,oz) #endif #if (SGS == 2) call dissip(ox1,oy1,oz1, u,v,w, 1 th, qv, qc, qr, tke, c 1 fx,fy,fz,ft, qia,qib,fqia,fqib, 1 fx,fy,fz,ft, 3 fqv,fqc,fqr,ftke, fox,foy,foz,pfx,pfy,pfz, 3 fu, fv, fw, 3 ox,oy,oz) #endif do k=1,l do j=1,mp do i=1,np pfx(i,j,k)=(u(i,j,k)*fu(i,j,k)+v(i,j,k)*fv(i,j,k) . +w(i,j,k)*fw(i,j,k))*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=1./gi(i,j) c kappa*lapl(th+the) ft(i,j,k)=ft(i,j,k)/2. enddo enddo enddo c total change due to kinematic dissipation (incl. flux + epsilon) c if we want the flux and epsilon contributions separately c dissip needs changing !!! call sumcns(pfx,pfy,pfz,ehise(ikf,8),1) c update total rate of kinetic energy change ehise(ikf,4)=ehise(ikf,4)+ehise(ikf,8) c update total rate of potential energy change (due to diffusion) do k=1,l do j=1,mp do i=1,np zstr=fsi((k-1)*dz) zcrl=zstr/gi(i,j)+zs(i,j) pfx(i,j,k)=g*zcrl*ft(i,j,k)*dx*dy*dz pfy(i,j,k)=0. pfz(i,j,k)=1./gi(i,j) enddo enddo enddo call sumcns(pfx,pfy,pfz,ehise(ikf,9),1) ehise(ikf,7)=ehise(ikf,7)+ehise(ikf,9) endif c SGS #endif c external energy flux ehise(ikf,11) c total rate of kinetic energy change ehise(ikf,4) c total rate of potential energy change ehise(ikf,7) c total energy ehise(ikf,10) = ehise(ikf,1) + ehise(ikf,2) c total rate of change (excluding numerical viscosity !!) ehise(ikf,12) = ehise(ikf,4) + ehise(ikf,7) return end C ENERGY #endif #if (TURBPL == 1) subroutine turban(u,v,w,th,p,qv,qc,qr,lipps,e,ivis) include 'param.nml' include 'msg.inc' dimension th(1-ih:np+ih,1-ih:mp+ih,l), . u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . e(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv) dimension awp(l),awn(l) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . f1(1-ih:np+ih, 1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 13) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . f1(1-ih:np+ih, 1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l), . scr6(1-ih:np+ih, 1-ih:mp+ih, l, 6) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/gora/ xml,yml,amp,xml0,yml0,angle common/plotur/ iuvpl,ivvpl,iwvpl,ithpl,iprpl, . iqvpl,iqcpl,ikepl,itkpl,idspl, . ihfpl,imfpl,iw3pl,ipwpl,iball common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/srprint/ itblpri data itblpri/0/ data iuvpl/1/,ivvpl/1/,iwvpl/1/,ithpl/1/,iprpl/1/, 1 iqvpl/1/,iqcpl/1/,ikepl/1/,itkpl/1/, 1 ihfpl/1/,imfpl/1/,iw3pl/1/,iskew/1/,ipwpl/1/, 1 iarea/1/,iball/1/ c inorm=1 if(hf00.eq.0.) then inorm=0 iball=0 endif nml=n*m*l nm=n*m ivvpl=ivvpl*j3 iqvpl=iqvpl*moist iqcpl=iqcpl*moist itkpl=itkpl*ivis if(j3.eq.1) then !3D case cii=2./3. else !2D case cii=2./2. endif convert sqrt(tke) to tke if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l e(i,j,k)=e(i,j,k)**2 enddo enddo enddo endif covariance statistics if(inorm.eq.1.or.ihfpl.eq.1) then call reystress(th,w,n,m,l, 3,lipps) call reystress(th,u,n,m,l,31,lipps) call reystress(th,v,n,m,l,32,lipps) endif if(imfpl.eq.1) then call reystress(u,w,n,m,l,1,lipps) call reystress(v,w,n,m,l,2,lipps) endif if(ipwpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*(p(i,j,k)-cii*e(i,j,k)) enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*p(i,j,k) enddo enddo enddo endif call reystress(f1,w,n,m,l, 4,lipps) call reystress(f1,u,n,m,l,41,lipps) call reystress(f1,v,n,m,l,42,lipps) endif if(iw3pl.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) enddo enddo enddo call reystress(f1,w,n,m,l, 8,lipps) call reystress( u,w,n,m,l,81,lipps) call reystress( v,w,n,m,l,82,lipps) endif if(iskew.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) enddo enddo enddo call reystress(f1,w,n,m,l, 9,lipps) do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) enddo enddo enddo call reystress(f1,w,n,m,l,91,lipps) endif if (iuvpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=u(i,j,k) f2(i,j,k)=e(i,j,k)*cii enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=u(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,1) endif if (ivvpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=v(i,j,k) f2(i,j,k)=e(i,j,k)*cii enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=v(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,2) endif if (iwvpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) f2(i,j,k)=e(i,j,k)*cii enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,3) endif if (ithpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=th(i,j,k) f2(i,j,k)=0. enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=th(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,4) endif if (iprpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*(p(i,j,k)-cii*e(i,j,k)) f2(i,j,k)=0. enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*p(i,j,k) f2(i,j,1)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,5) endif if (iqvpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=qv(i,j,k) f2(i,j,k)=0. enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=qv(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,6) endif if (iqcpl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=qc(i,j,k) f2(i,j,k)=0. enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=qc(i,j,k) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,7) endif if (ikepl.eq.1) then if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=0.5*(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2) f2(i,j,k)=e(i,j,k) enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=0.5*(u(i,j,k)**2+v(i,j,k)**2+w(i,j,k)**2) f2(i,j,k)=0. enddo enddo enddo endif call statv(f1,f2,n,m,l,8) endif if(iarea.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=1. if(w(i,j,k).le.0.) f1(i,j,k)=0. f2(i,j,k)=1.-f1(i,j,k) enddo enddo enddo call areapl(f1,f2,awp,awn,n,m,l,0) do i=1,n do j=1,m do k=1,l f1(i,j,k)=amax1(0.,w(i,j,k)) f2(i,j,k)=amin1(0.,w(i,j,k)) enddo enddo enddo call areapl(f1,f2,awp,awn,n,m,l,1) call aver(th,zcr,n,m,l) do i=1,n do j=1,m do k=1,l f1(i,j,k)=th(i,j,k)-the(i,j,k)*0.-zcr(k)*1. f2(i,j,k)=th(i,j,k)-the(i,j,k)*0.-zcr(k)*1. if(w(i,j,k).gt.0.) then f2(i,j,k)=0. else f1(i,j,k)=0. endif enddo enddo enddo call areapl(f1,f2,awp,awn,n,m,l,2) endif if(iball.eq.1) call budget(u,v,w,p,th,e,lipps,ivis) inorm=0 convert tke back to sqrt(tke) if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l e(i,j,k)=sqrt(e(i,j,k)) enddo enddo enddo endif return end subroutine budget(u,v,w,p,th,e,lipps,ivis) include 'param.nml' include 'msg.inc' dimension th(1-ih:np+ih,1-ih:mp+ih,l), . u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . e(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv) dimension fl(l,6) character*80 lhead #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . f1(1-ih:np+ih, 1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 13) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . f1(1-ih:np+ih, 1-ih:mp+ih, l), . f2(1-ih:np+ih, 1-ih:mp+ih, l), . scr6(1-ih:np+ih, 1-ih:mp+ih, l, 6) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/sgscnst/ ceps,cL,cm,cs,prndt common/zbigs/ tauw(1-ih:np+ih, 1-ih:mp+ih), . hfx(1-ih:np+ih, 1-ih:mp+ih), . qfx(1-ih:nmsp+ih, 1-ih:mmsp+ih), . zo(np,mp),itkes common/srprint/ itblpri nml=n*m*l nm=n*m if(j3.eq.1) then !3D case cii=2./3. c deltl=(dx*dy*dz)**(1./3.) deltl=1.*(dx+dy+dz)/3. c deltl=amax1(dx,dy,dz) c deltl=sqrt(0.5*(dx**2+dy**2+dz**2)) else !2D case cii=2./2. deltl=sqrt(dx*dz) endif xnorm=zi/wstr**3 call fluxb(th,w,fl(1,1),n,m,l,1,lipps) do k=1,l zcr(k)=(k-1)*dz enddo call thprof(fl(1,2),zcr,l,lipps) do k=1,l fl(k,1)=g*fl(k,1)/fl(k,2)*xnorm enddo do i=1,n do j=1,m do k=1,l f1(i,j,k)=w(i,j,k) enddo enddo enddo call fluxb(f1,w,fl(1,2),n,m,l, 2,lipps) call fluxb( u,w,fl(1,3),n,m,l,21,lipps) call fluxb( v,w,fl(1,4),n,m,l,22,lipps) do k=1,l fl(k,2)=0.5*(fl(k,2)+fl(k,3)+fl(k,4)) enddo if(ivis.eq.1) then do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*(p(i,j,k)-cii*e(i,j,k)) enddo enddo enddo else do i=1,n do j=1,m do k=1,l f1(i,j,k)=2.*dti*p(i,j,k) enddo enddo enddo endif call fluxb(f1,w,fl(1,3),n,m,l,3,lipps) do k=1,l fl(k,2)=fl(k,2)+fl(k,3) enddo do k=2,l-1 fl(k,3)=(fl(k+1,2)-fl(k-1,2))*dzi*0.5 enddo fl(1,3)=(fl(2,2)-fl(1 ,2))*dzi fl(l,3)=(fl(l,2)-fl(l-1,2))*dzi do k=1,l fl(k,2)=-fl(k,3)*xnorm enddo c filter c do k=2,l-1 c fl(k,3)=0.25*(fl(k+1,2)+2.*fl(k,2)+fl(k-1,2)) c enddo c do k=2,l-1 c fl(k,2)=fl(k,3) c enddo if(ivis.eq.1) then eps=1.e-15 do i=1,n do j=1,m do k=1,l EsqE=e(i,j,k)*sqrt(e(i,j,k)) cLz=cL*amax1(float(k-1),1.)*dz/gi(i,j) c cLz=cL*amax1((k-1)*dz/gi(i,j),zo(i,j)) Diss=ceps*EsqE/( (1-ibcz)*amin1(cLz,deltl) . +ibcz*deltl ) f1(i,j,k)=Diss enddo enddo enddo do i=1,n do j=1,m f1(i,j,1)=0. enddo enddo call aver(f1,fl(1,3),n,m,l) else do k=1,l fl(k,3)=0. enddo endif do k=1,l fl(k,3)=-fl(k,3)*xnorm enddo call aver( u,fl(1,4),n,m,l) do k=2,l-1 fl(k,5)=(fl(k+1,4)-fl(k-1,4))*dzi*0.5 enddo fl(1,5)=(fl(2,4)-fl(1 ,4))*dzi fl(l,5)=(fl(l,4)-fl(l-1,4))*dzi call fluxb(u,w,fl(1,4),n,m,l,4,lipps) do k=1,l fl(k,4)=-fl(k,4)*fl(k,5)*xnorm enddo call aver( v,fl(1,5),n,m,l) do k=2,l-1 fl(k,6)=(fl(k+1,5)-fl(k-1,5))*dzi*0.5 enddo fl(1,6)=(fl(2,5)-fl(1 ,5))*dzi fl(l,6)=(fl(l,5)-fl(l-1,5))*dzi call fluxb(v,w,fl(1,5),n,m,l,5,lipps) do k=1,l fl(k,5)=-fl(k,5)*fl(k,6)*xnorm enddo do k=1,l fl(k,6)=fl(k,1)+fl(k,2)+fl(k,3)+fl(k,4)+fl(k,5) enddo zlam=1.e-2 ntp=l top=(ntp-1)*dz/zlam do 1 kc=1,l 1 zcr(kc)=(kc-1)*dz if(inorm.eq.1) then zlam=zi top=(ntp-1)*dz/zlam endif #if (GKS == 1) t1=-1.e10 t2=+1.e10 do 22 k=1,l zcr(k)=zcr(k)/zlam t1=amax1(t1,fl(k,1),fl(k,2),fl(k,3),fl(k,4),fl(k,5),fl(k,6)) 22 t2=amin1(t2,fl(k,1),fl(k,2),fl(k,3),fl(k,4),fl(k,5),fl(k,6)) c ... set limits del=abs(t1-t2)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta c ... set slim1 to largest multiple of delta less than t2 c ... n.b. if this delta doesnt give proper slim2, use 2*delta 45 t=t2/delta+1.e-3+sign(1.e-3,t2) it=int(t) slim1=float(it)*delta if (slim1.gt.t2) slim1=float(it-1)*delta slim2=slim1+4.*delta if (slim2.ge.t1) go to 55 delta=2.*delta go to 45 55 continue call set(.1,.9,.1,.9,0.,1.,0.,top,1) ipt1=int(192.8+819.2) write (lhead,100) time call plchhq(cpux(512),cpuy(ipt1),lhead(1:39),0.015,0.,0.) if(inorm.eq.0) then call plchhq(cpux(990),cpuy(512),'z [cm] -->',0.02,90.,0.) else call plchhq(cpux(990),cpuy(512),'z/zi -->',0.02,90.,0.) endif call set(.1,.9,.1,.9,0.,1.,0.,top,1) call gaseti('LTY',1) call labmod('(f3.1)','(f6.1)',3,6,2,2,20,20,0) call periml(1,10,5,2) write (lhead,200) slim1,slim2 call plchhq(cpux(257),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.1,.9,.1,.9,slim1,slim2,0.,top,1) call dashdc('$''$''$''$''$''$''$''',10,12) call curved(fl(1,1),zcr,l) call dashdc('$$''$$''$$''$$''$$''',10,12) call curved(fl(1,2),zcr,l) call dashdc('$$$''$$$''$$$''$$$''',10,12) call curved(fl(1,3),zcr,l) call dashdc('$$$$''$$$$''$$$$''',10,12) call curved(fl(1,4),zcr,l) call dashdc('$$$$$''$$$$$''$$$$$''',10,12) call curved(fl(1,5),zcr,l) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fl(1,6),zcr,l) call frame #endif if(itblpri.eq.1) then 769 format(24x,' next ') 770 format(4x,e14.7) print 701 701 format(2x,' *** elements of tke budget *** ') print 770, (fl(k,1),k=1,l) print 769 print 770, (fl(k,2),k=1,l) print 769 print 770, (fl(k,3),k=1,l) print 769 print 770, (fl(k,4),k=1,l) print 769 print 770, (fl(k,5),k=1,l) print 769 print 770, (fl(k,6),k=1,l) endif 100 format('tke budget at time= ',f9.2) 200 format(e11.4,' -->',e11.4) return end subroutine fluxb(f,w,reys,n1,n2,n3,iflg,lipps) include 'param.nml' include 'msg.inc' real reys(n3) character*80 lhead dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l) dimension fav(l),wav(l),zcr(l),wgt(l),ar(l),rho(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/dragc/ dragx(nth),dragy(nth),drgnorm, itd, idrag common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm #if (ANALIZE == 0) common/blank/ ri3(1-ih:np+ih, 1-ih:mp+ih, l, 3), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . wz(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 13) #else common/blank/ ri3(1-ih:np+ih, 1-ih:mp+ih, l, 3), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . wz(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 4) #endif nsq=1 if(iflg.eq.2.or.iflg.eq.21.or.iflg.eq.22) nsq=2 il=1 ir=n1-ibcx jl=1 jr=n2-ibcy do 1 kc=1,n3 1 zcr(kc)=(kc-1)*dz call density profile call rhprof(rho,zcr,n3,lipps) create interpolated fields call interz( f, fz, fav,wgt,n1,n2,n3) call interz( w, wz, wav,wgt,n1,n2,n3) compute fluxes cnorm=1. ip=0 do 3 kc=n3,1,-1 reys(kc)=0. do i=il,ir do j=jl,jr reys(kc) = reys(kc) + * (fz(i,j,kc)-fav(kc))**nsq*(wz(i,j,kc)-wav(kc))*rho(kc) enddo enddo if (wgt(kc).gt.0.) then reys(kc)=reys(kc)/wgt(kc) ip=ip+1 else reys(kc)=2.*reys(kc+1)-reys(kc+2) endif 3 continue return end subroutine aver(f,fav,n1,n2,n3) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l) dimension fav(n3),wgt(l),zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc il=1 ir=n1-ibcx jl=1 jr=n2-ibcy do 1 kc=1,n3 zcr(kc)=(kc-1)*dz 1 continue do 2 kc=n3,1,-1 fav(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if (kbr.ge.2) then fav(kc)=fav(kc) + f(i,j,kbrm)+ * (f(i,j,kbr )-f(i,j,kbrm))*(brk-float(kbrm)) wgt(kc)=wgt(kc) + 1. endif enddo enddo if (wgt(kc).gt.0.) then fav(kc)=fav(kc)/wgt(kc) else fav(kc)=2.*fav(kc+1)-fav(kc+2) endif 2 continue return end subroutine statv(f,e,n1,n2,n3,iflg) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . e(1-ih:np+ih, 1-ih:mp+ih, l) dimension zcr(l),fav(l),fsd(l),fss(l),wgt(l) character*80 lhead common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/gora/ xml,yml,amp,xml0,yml0,angle common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/srprint/ itblpri c zlam=1.e-2 ntp=n3 top=(ntp-1)*dz/zlam il=1 ir=n1-ibcx jl=1 jr=n2-ibcy nml=n1*n2*n3 do 1 kc=1,n3 1 zcr(kc)=(kc-1)*dz compute zonal-mean do 2 kc=n3,1,-1 fav(kc)=0. fss(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if(kbr.ge.2) then fav(kc)=fav(kc) + * f(i,j,kbrm)+(f(i,j,kbr)-f(i,j,kbrm))*(brk-float(kbrm)) fss(kc)=fss(kc) + * e(i,j,kbrm)+(e(i,j,kbr)-e(i,j,kbrm))*(brk-float(kbrm)) wgt(kc)=wgt(kc) + 1. endif enddo enddo if(wgt(kc).gt.0.) then fav(kc)=fav(kc)/wgt(kc) fss(kc)=fss(kc)/wgt(kc) else fav(kc)=2.*fav(kc+1)-fav(kc+2) fss(kc)=2.*fss(kc+1)-fss(kc+2) endif 2 continue if(iflg.eq.8) then do kc=1,n3 fsd(kc)=fav(kc)+fss(kc) enddo endif if(iflg.ne.8) then compute zonal-mean of primed variables + tke contribution do 3 kc=n3,1,-1 fsd(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if(kbr.ge.2) then fsd(kc)=fsd(kc) + ( f(i,j,kbrm)+(f(i,j,kbr)-f(i,j,kbrm)) * *(brk-float(kbrm))-fav(kc) )**2 wgt(kc)=wgt(kc) + 1. endif enddo enddo if(wgt(kc).gt.0.) then fsd(kc)=fsd(kc)/wgt(kc) else fsd(kc)=2.*fsd(kc+1)-fsd(kc+2) endif 3 continue do kc=1,n3 fsd(kc)=fsd(kc)+fss(kc) enddo endif if(inorm.eq.1) then zlam=zi top=(ntp-1)*dz/zlam if(iflg.le.3.or.iflg.eq.8) xnorm=1./wstr**2 if(iflg.eq.4) xnorm=1./tstr**2 if(iflg.eq.5) xnorm=1./wstr**4 if(iflg.eq.6.or.iflg.eq.7) xnorm=1./qstr**2 do k=1,n3 fsd(k)=fsd(k)*xnorm fss(k)=fss(k)*xnorm enddo endif #if (GKS == 1) t1=-1.e10 t2=+1.e10 t3=-1.e10 do 22 k=1,n3 zcr(k)=zcr(k)/zlam t1=amax1(t1,fav(k)) t2=amin1(t2,fav(k)) 22 t3=amax1(t3,fsd(k),fss(k)) c ... set limits on fsd del=abs(t3)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta slim3=0.0 slim4=4.*delta c ... set limits on avg del=abs(t1-t2)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta c ... set slim1 to largest multiple of delta less than t2 c ... n.b. if this delta doesnt give proper slim2, use 2*delta 45 t=t2/delta+1.e-3+sign(1.e-3,t2) it=int(t) slim1=float(it)*delta if (slim1.gt.t2) slim1=float(it-1)*delta slim2=slim1+4.*delta if (slim2.ge.t1) go to 55 delta=2.*delta go to 45 55 continue call set(.1,.9,.1,.9,0.,1.,0.,top,1) ipt1=int(192.8+819.2) if(iflg.eq.1) write (lhead,101) time if(iflg.eq.2) write (lhead,102) time if(iflg.eq.3) write (lhead,103) time if(iflg.eq.4) write (lhead,104) time if(iflg.eq.5) write (lhead,105) time if(iflg.eq.6) write (lhead,106) time if(iflg.eq.7) write (lhead,107) time if(iflg.eq.8) write (lhead,108) time call plchhq(cpux(512),cpuy(ipt1),lhead(1:39),0.015,0.,0.) if(inorm.eq.0) then call plchhq(cpux(990),cpuy(512),'z [cm] -->',0.02,90.,0.) else call plchhq(cpux(990),cpuy(512),'z/zi -->',0.02,90.,0.) endif call plchhq(cpux(307),cpuy(50),'mean resolved',0.015,0.,0.) if(iflg.eq.8) then call plchhq(cpux(717),cpuy(50),'total and subgrid',0.015,0.,0.) else call plchhq(cpux(717),cpuy(50),'variance, total and subgrid', . 0.015,0.,0.) endif call gaseti('LTY',1) call set(.1,.45,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.1)',3,6,2,2,20,20,0) call periml(1,10,5,2) write (lhead,200) slim1,slim2 call plchhq(cpux(257),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.1,.45,.1,.9,slim1,slim2,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fav,zcr,n3) call set(.55,.9,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.1)',3,6,2,2,20,20,0) call periml(1,10,5,2) write (lhead,200) slim3,slim4 call plchhq(cpux(717),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.55,.9,.1,.9,slim3,slim4,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fsd,zcr,n3) call dashdc('$''$''$''$''$''$''$''',10,12) call curved(fss,zcr,n3) call frame #endif if(itblpri.eq.1) then 770 format(4x,e14.7) if(iflg.eq.1) then print 701 701 format(2x,' *** *** ') print 770, (fsd(k),k=1,l) endif if(iflg.eq.3) then print 703 703 format(2x,' *** *** ') print 770, (fsd(k),k=1,l) endif if(iflg.eq.4) then print 7041 7041 format(2x,' *** *** ') print 770, (fav(k),k=1,l) print 7042 7042 format(2x,' *** *** ') print 770, (fsd(k),k=1,l) endif endif 101 format('u statistics at time= ',f9.2) 102 format('v statistics at time= ',f9.2) 103 format('w statistics at time= ',f9.2) 104 format('theta statistics at time= ',f9.2) 105 format('p/rho statistics at time= ',f9.2) 106 format('qv statistics at time= ',f9.2) 107 format('qc statistics at time= ',f9.2) 108 format('kin. en. statistics at time= ',f9.2) 200 format(e11.4,' -->',e11.4) return end subroutine areapl(f,e,awp,awn,n1,n2,n3,iflg) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . e(1-ih:np+ih, 1-ih:mp+ih, l) dimension zcr(l),fav(l),fss(l),wgt(l),awp(n3),awn(n3) character*80 lhead common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/gora/ xml,yml,amp,xml0,yml0,angle common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/srprint/ itblpri c zlam=1.e-2 ntp=n3 top=(ntp-1)*dz/zlam il=1 ir=n1-ibcx jl=1 jr=n2-ibcy nml=n1*n2*n3 do 1 kc=1,n3 1 zcr(kc)=(kc-1)*dz compute zonal-mean do 2 kc=n3,1,-1 fav(kc)=0. fss(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if(kbr.ge.2) then fav(kc)=fav(kc) + * f(i,j,kbrm)+(f(i,j,kbr)-f(i,j,kbrm))*(brk-float(kbrm)) fss(kc)=fss(kc) + * e(i,j,kbrm)+(e(i,j,kbr)-e(i,j,kbrm))*(brk-float(kbrm)) wgt(kc)=wgt(kc) + 1. endif enddo enddo if(wgt(kc).gt.0.) then fav(kc)=fav(kc)/wgt(kc) fss(kc)=fss(kc)/wgt(kc) else fav(kc)=2.*fav(kc+1)-fav(kc+2) fss(kc)=2.*fss(kc+1)-fss(kc+2) endif 2 continue if(iflg.eq.0) then do k=1,n3 awp(k)=fav(k) awn(k)=fss(k) enddo else do k=2,n3-1 fav(k)=fav(k)/awp(k) fss(k)=fss(k)/awn(k) enddo endif if(inorm.eq.1) then zlam=zi top=(ntp-1)*dz/zlam if(iflg.eq.0) xnorm=1. if(iflg.eq.1) xnorm=1./wstr if(iflg.eq.2) xnorm=1./tstr do k=1,n3 fav(k)=fav(k)*xnorm fss(k)=fss(k)*xnorm enddo endif #if (GKS == 1) t1=-1.e10 t2=+1.e10 do 22 k=1,n3 zcr(k)=zcr(k)/zlam t1=amax1(t1,fav(k),fss(k)) 22 t2=amin1(t2,fav(k),fss(k)) c ... set limits on avg del=abs(t1-t2)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta c ... set slim1 to largest multiple of delta less than t2 c ... n.b. if this delta doesnt give proper slim2, use 2*delta 45 t=t2/delta+1.e-3+sign(1.e-3,t2) it=int(t) slim1=float(it)*delta if (slim1.gt.t2) slim1=float(it-1)*delta slim2=slim1+4.*delta if (slim2.ge.t1) go to 55 delta=2.*delta go to 45 55 continue call set(.1,.9,.1,.9,0.,1.,0.,top,1) ipt1=int(192.8+819.2) if(iflg.eq.0) write (lhead,100) time if(iflg.eq.1) write (lhead,101) time if(iflg.eq.2) write (lhead,102) time call plchhq(cpux(512),cpuy(ipt1),lhead(1:39),0.015,0.,0.) if(inorm.eq.0) then call plchhq(cpux(990),cpuy(512),'z [cm] -->',0.02,90.,0.) else call plchhq(cpux(990),cpuy(512),'z/zi -->',0.02,90.,0.) endif call set(.1,.9,.1,.9,0.,1.,0.,top,1) call gaseti('LTY',1) call labmod('(f3.1)','(f6.1)',3,6,2,2,20,20,0) call periml(1,10,5,2) write (lhead,200) slim1,slim2 call plchhq(cpux(257),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.1,.9,.1,.9,slim1,slim2,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fav,zcr,n3) call dashdc('$''$''$''$''$''$''$''',10,12) call curved(fss,zcr,n3) call frame #endif if(itblpri.eq.1) then 770 format(4x,e14.7) if(iflg.eq.1) then print 7011 7011 format(2x,' *** w in ups *** ') print 770, (fav(k),k=1,l) print 7012 7012 format(2x,' *** w in downs *** ') print 770, (fss(k),k=1,l) endif if(iflg.eq.2) then print 7031 7031 format(2x,' *** thp in ups *** ') print 770, (fav(k),k=1,l) print 7032 7032 format(2x,' *** thp in downs *** ') print 770, (fss(k),k=1,l) endif endif 100 format('up/down-drafts areas at time= ',f9.2) 101 format('w in ups and downs at time= ',f9.2) 102 format('th in ups and downs at time= ',f9.2) 200 format(e11.4,' -->',e11.4) return end C TURBPL #endif subroutine profil(f,n1,n2,n3,iflg) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l) dimension zcr(l),fav(l),fsd(l),wgt(l) character*80 lhead common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/gora/ xml,yml,amp,xml0,yml0,angle common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc c c zlam=1.e3 ntp=n3 top=(ntp-1)*dz/zlam if( icylind.eq.1 ) then jl=1 jr=n2-ibcy il=(n1-1)/2 ir=(n1-1)/2 else il=1 ir=n1-ibcx c 3d plotting, only equator jl=(n2-1)/2 jr=(n2-1)/2 c 2d plotting or average over tank c jl=1 c jr=n2-ibcy endif do 1 kc=1,n3 1 zcr(kc)=(kc-1)*dz compute zonal-mean do 2 kc=n3,1,-1 fav(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if(kbr.ge.2) then fav(kc)=fav(kc) + * f(i,j,kbrm)+(f(i,j,kbr)-f(i,j,kbrm))*(brk-float(kbrm)) wgt(kc)=wgt(kc) + 1. endif enddo enddo if(wgt(kc).gt.0.) then fav(kc)=fav(kc)/wgt(kc) else fav(kc)=2.*fav(kc+1)-fav(kc+2) endif 2 continue compute zonal-mean of primed variables do 3 kc=n3,1,-1 fsd(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if(kbr.ge.2) then fsd(kc)=fsd(kc) + ( f(i,j,kbrm)+(f(i,j,kbr)-f(i,j,kbrm)) * *(brk-float(kbrm))-fav(kc) )**2 wgt(kc)=wgt(kc) + 1. endif enddo enddo if(wgt(kc).gt.0.) then fsd(kc)=fsd(kc)/wgt(kc) else fsd(kc)=2.*fsd(kc+1)-fsd(kc+2) endif 3 continue if( iflg.eq.16 ) then do i=1,l if( fav(i).gt.0. ) then fav(i)=min(10.,fav(i)) else fav(i)=max(-10.,fav(i)) endif enddo endif #if (GKS == 1) t1=-1.e10 t2=+1.e10 t3=-1.e10 do 22 k=1,n3 zcr(k)=zcr(k)/zlam t1=amax1(t1,fav(k)) t2=amin1(t2,fav(k)) 22 t3=amax1(t3,fsd(k)) c ... set limits on fsd del=abs(t3)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta slim3=0.0 slim4=4.*delta c ... set limits on avg del=abs(t1-t2)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta c ... set slim1 to largest multiple of delta less than t2 c ... n.b. if this delta doesnt give proper slim2, use 2*delta 45 t=t2/delta+1.e-3+sign(1.e-3,t2) it=int(t) slim1=float(it)*delta if (slim1.gt.t2) slim1=float(it-1)*delta slim2=slim1+4.*delta if (slim2.ge.t1) go to 55 delta=2.*delta go to 45 55 continue call sflush call gstxci(1) call gsplci(1) call set(.1,.9,.1,.9,0.,1.,0.,top,1) ipt1=int(192.8+819.2) call pcsetc('FC - FUNCTION CODE CHARACTER','?') call wrtitl(lhead,iflg,time,1,0) call plchhq(cpux(512),cpuy(ipt1),lhead(1:39),.015,0.,0.) call plchhq(cpux(990),cpuy(512),'z [km] -->',.02,90.,0.) call plchhq(cpux(307),cpuy(50),'mean',.015,0.,0.) call plchhq(cpux(717),cpuy(50),'st. dev.',.015,0.,0.) call gaseti('LTY',1) call set(.1,.45,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.0)',3,6,2,2,20,20,0) call periml(1,10,6,3) call pcsetc('FC - FUNCTION CODE CHARACTER','?') write (lhead,200) slim1,slim2 call plchhq(cpux(257),cpuy(20),lhead(1:26),.015,0.,0.) call set(.1,.45,.1,.9,slim1,slim2,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fav,zcr,n3) call set(.55,.9,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.0)',3,6,2,2,20,20,0) call periml(1,10,6,3) call pcsetc('FC - FUNCTION CODE CHARACTER','?') write (lhead,200) slim3,slim4 call plchhq(cpux(717),cpuy(20),lhead(1:26),.015,0.,0.) call set(.55,.9,.1,.9,slim3,slim4,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(fsd,zcr,n3) call frame #endif 200 format(e11.4,' -->',e11.4) return end #if (VORTPL == 1) subroutine plov(u,v,w,om,th,vrx,vry,vrz) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . om(1-ih:np+ih, 1-ih:mp+ih, l), . th(1-ih:np+ih, 1-ih:mp+ih, l), . vrx(1-ih:np+ih, 1-ih:mp+ih, l), . vry(1-ih:np+ih, 1-ih:mp+ih, l), . vrz(1-ih:np+ih, 1-ih:mp+ih, l) dimension fxz(n,l),fyz(m,l),fxy(n,m),uxz(n,l), . wxz(n,l),vyz(m,l),wyz(m,l),uxy(n,m),vxy(n,m) #if (ANALIZE == 0) common/blank/ pv(1-ih:np+ih, 1-ih:mp+ih, l), . zth(1-ih:np+ih, 1-ih:mp+ih, l), . vx(1-ih:np+ih, 1-ih:mp+ih, l), . vy(1-ih:np+ih, 1-ih:mp+ih, l), . vz(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . zs3(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 9) #else common/blank/ pv(1-ih:np+ih, 1-ih:mp+ih, l), . zth(1-ih:np+ih, 1-ih:mp+ih, l), . vx(1-ih:np+ih, 1-ih:mp+ih, l), . vy(1-ih:np+ih, 1-ih:mp+ih, l), . vz(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . zs3(1-ih:np+ih, 1-ih:mp+ih, l), . scr2(1-ih:np+ih, 1-ih:mp+ih, l, 2) #endif common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) data isx,isy/0,0/ data ivctpl/0/ data izcr0/0/ c ipvpl calculate and plot Ertel potential vorticity c ithpl plot PV on theta surfaces (compute PV first on zbar surfaces, c compute the height of isentropic surfaces next, and interpolate c PV onto them---do not recommend unless theta surfaces are c relatively flat) c inorm compute normalized PV (divide by a norm of the potential c temperature gradient vector) data inorm/1/ data ivxpl/1/,ivypl/1/,ivzpl/1/,ipvpl/0/,ithpl/0/ data ixzpl/1/,iyzpl/1/,ixypl/1/,iprfl/0/,iflxpl/0/,ixyzpl/0/ create vertical frames common/xzfrm/is,ie,t1x,t2x,t3x,ksx,kex,x1z,x2z,x3z common/yzfrm/js,je,t1y,t2y,t3y,ksy,key,y1z,y2z,y3z common/xyfrm/ish,ieh,t1xh,t2xh,t3xh,jsh,jeh,t1yh,t2yh,t3yh common/rat/rat1,rat2,rat3 c pi = acos(-1.) nml=n*m*l nm=n*m if(j3.eq.0) then ivxpl=0 ivzpl=0 iyzpl=0 ixypl=0 ixyzpl=0 isy=0 endif c if(ipvpl.eq.1) call pvort(th,vrx,vry,vrz,n,m,l,ithpl,inorm) contour level density nclv=13 c c contour plots follow if(iprfl.eq.1) then if(ivxpl.eq.1) then do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=vrx(i,j,k) enddo enddo enddo call profil(fxyz,n,m,l,71) endif if(ivypl.eq.1) then do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=vry(i,j,k) enddo enddo enddo call profil(fxyz,n,m,l,72) endif if(ivzpl.eq.1) then do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=vrz(i,j,k) enddo enddo enddo call profil(fxyz,n,m,l,73) endif if(ipvpl.eq.1) then do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=pv(i,j,k) enddo enddo enddo call profil(fxyz,n,m,l,74) endif endif close profiles if(ixzpl.eq.1) then jc=(1+m)/2 j1=jc jm=jc ji=1 do 777 j=j1,jm,ji do 200 k=1,l do 200 i=1,n uxz(i,k)=0.5*(u(i,j,k)+u(i,j+isy,k)) 200 wxz(i,k)=0.5*(w(i,j,k)+w(i,j+isy,k))*(2-ivctpl) . +0.5*(om(i,j,k)+om(i,j+isy,k))*(ivctpl-1) do 1017 k=1,l do 1017 i=1,n xnor0=sqrt(wxz(i,k)**2+uxz(i,k)**2) wxz(i,k)=wxz(i,k)*dx*dzi*rat1 xnort=sqrt(wxz(i,k)**2+uxz(i,k)**2) xcos=uxz(i,k)/(xnort+1.e-15) xsin=wxz(i,k)/(xnort+1.e-15) uxz(i,k)=xnor0*xcos wxz(i,k)=xnor0*xsin 1017 continue if(ivxpl.eq.1) then do k=1,l do i=1,n fxz(i,k)=0.5*(vrx(i,j,k)+vrx(i,j+isy,k)) enddo enddo call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,71,nclv) endif if(ivypl.eq.1) then do k=1,l do i=1,n fxz(i,k)=0.5*(vry(i,j,k)+vry(i,j+isy,k)) enddo enddo call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,72,nclv) endif if(ivzpl.eq.1) then do k=1,l do i=1,n fxz(i,k)=0.5*(vrz(i,j,k)+vrz(i,j+isy,k)) enddo enddo call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,73,nclv) endif if(ipvpl.eq.1) then do k=1,l do i=1,n fxz(i,k)=0.5*(pv(i,j,k)+pv(i,j+isy,k)) enddo enddo call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,74,nclv) endif 777 continue endif close xzplots if(iyzpl.eq.1) then ic=(1+n)/2 i1=ic-ic/2 in=ic+ic/2 ii=ic/2 do 888 i=i1,in,ii do 300 k=1,l do 300 j=1,m vyz(j,k)=0.5*(v(i,j,k)+v(i+isx,j,k)) 300 wyz(j,k)=0.5*(w(i,j,k)+w(i+isx,j,k))*(2-ivctpl) . +0.5*(om(i,j,k)+om(i+isx,j,k))*(ivctpl-1) do 2017 k=1,l do 2017 j=1,m xnor0=sqrt(wyz(j,k)**2+vyz(j,k)**2) wyz(j,k)=wyz(j,k)*dy*dzi*rat2 xnort=sqrt(wyz(j,k)**2+vyz(j,k)**2) xcos=vyz(j,k)/(xnort+1.e-15) xsin=wyz(j,k)/(xnort+1.e-15) vyz(j,k)=xnor0*xcos 2017 wyz(j,k)=xnor0*xsin if(ivxpl.eq.1) then do k=1,l do j=1,m fyz(j,k)=.5*(vrx(i,j,k)+vrx(i+isx,j,k)) enddo enddo call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,71,nclv) endif if(ivypl.eq.1) then do k=1,l do j=1,m fyz(j,k)=.5*(vry(i,j,k)+vry(i+isx,j,k)) enddo enddo call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,72,nclv) endif if(ivzpl.eq.1) then do k=1,l do j=1,m fyz(j,k)=.5*(vrz(i,j,k)+vrz(i+isx,j,k)) enddo enddo call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,73,nclv) endif if(ipvpl.eq.1) then do k=1,l do j=1,m fyz(j,k)=.5*(pv(i,j,k)+pv(i+isx,j,k)) enddo enddo call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,74,nclv) endif 888 continue endif close yzplots if(ixypl.eq.1) then do 998 izcr=0,izcr0 if(izcr.eq.0) then k1=1 kl=1 kk=1 else k1=11 kl=41 kk=10 endif do 999 k=k1,kl,kk if (ivctpl.eq.1) then call inzxy(k,u,uxy,n,m,l,izcr,0,nkug) call inzxy(k,v,vxy,n,m,l,izcr,0,nkug) do 400 j=1,m do 400 i=1,n xnor0=sqrt(uxy(i,j)**2+vxy(i,j)**2) vxy(i,j)=vxy(i,j)*dx*dyi*rat3 xnort=sqrt(uxy(i,j)**2+vxy(i,j)**2) xcos=uxy(i,j)/(xnort+1.e-15) xsin=vxy(i,j)/(xnort+1.e-15) uxy(i,j)=xnor0*xcos 400 vxy(i,j)=xnor0*xsin endif if (ithpl.eq.1) then do i=1,n do j=1,m fxy(i,j)=zth(i,j,k) end do end do call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,77,nclv) end if if (ivxpl.eq.1) then if (ithpl.eq.1) then do i=1,n do j=1,m fxy(i,j)=vx(i,j,k) end do end do else call inzxy(k,vrx,fxy,n,m,l,izcr,1,nkug) end if call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,71,nclv) end if if (ivypl.eq.1) then if (ithpl.eq.1) then do i=1,n do j=1,m fxy(i,j)=vy(i,j,k) end do end do else call inzxy(k,vry,fxy,n,m,l,izcr,1,nkug) end if call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,72,nclv) end if if (ivzpl.eq.1) then if (ithpl.eq.1) then do i=1,n do j=1,m fxy(i,j)=vz(i,j,k) end do end do else call inzxy(k,vrz,fxy,n,m,l,izcr,1,nkug) end if call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,73,nclv) end if if (ipvpl.eq.1) then if (ithpl.eq.1) then do i=1,n do j=1,m fxy(i,j)=pv(i,j,k) end do end do else call inzxy(k,pv,fxy,n,m,l,izcr,1,nkug) end if call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,74,nclv) end if 999 continue 998 continue close xyplot endif if(ixyzpl.eq.1) then if(ipvpl.eq.1.and.ithpl.eq.1) *call pvort(th,vrx,vry,vrz,n,m,l,0,inorm) do i=1,n do j=1,m do k=1,l c zs3(i,j,1)=0. zs3(i,j,k)=0. if(zs(i,j).gt.1.e-3) zs3(i,j,k)=1. enddo enddo enddo if (ivxpl.eq.1) then call inzxy3(vrx,fxyz,n,m,l) call xyzplot(fxyz,zs3,n,m,l,71) end if if (ivypl.eq.1) then call inzxy3(vry,fxyz,n,m,l) call xyzplot(fxyz,zs3,n,m,l,72) end if if (ivzpl.eq.1) then call inzxy3(vrz,fxyz,n,m,l) call xyzplot(fxyz,zs3,n,m,l,73) end if if (ipvpl.eq.1) then call inzxy3(pv,fxyz,n,m,l) call xyzplot(fxyz,zs3,n,m,l,74) end if close xyzplot endif return end subroutine pvort(th,vrx,vry,vrz,n11,n22,n33,ith,inorm) include 'param.nml' include 'msg.inc' parameter (n1=np,n2=mp,n3=l) dimension th(1-ih:np+ih,1-ih:mp+ih,l), . vrx(1-ih:np+ih,1-ih:mp+ih,l), . vry(1-ih:np+ih,1-ih:mp+ih,l), . vrz(1-ih:np+ih,1-ih:mp+ih,l) common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue(1-ih:np+ih,1-ih:mp+ih,l), . ve(1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (ANALIZE == 0) common/blank/ pv(1-ih:np+ih, 1-ih:mp+ih, l), . zth(1-ih:np+ih, 1-ih:mp+ih, l), . thx(1-ih:np+ih, 1-ih:mp+ih, l), . thy(1-ih:np+ih, 1-ih:mp+ih, l), . thz(1-ih:np+ih, 1-ih:mp+ih, l), . thn(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l), . scr9(1-ih:np+ih, 1-ih:mp+ih, l, 9) #else common/blank/ pv(1-ih:np+ih, 1-ih:mp+ih, l), . zth(1-ih:np+ih, 1-ih:mp+ih, l), . thx(1-ih:np+ih, 1-ih:mp+ih, l), . thy(1-ih:np+ih, 1-ih:mp+ih, l), . thz(1-ih:np+ih, 1-ih:mp+ih, l), . thn(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l), . scr2(1-ih:np+ih, 1-ih:mp+ih, l, 2) #endif call update(th,np,mp,l,np,mp,iup) nml=n*m*l dxil=0.5*dxi dyil=0.5*dyi dzil=0.5*dzi eps=1.e-15 calculate potential temperature gradients everywhere #if (POLES == 0) illim = 1 + leftedge iulim = np - rightedge #else illim = 1 iulim = np #endif do k=1,n3 do j=1,n2 do i=illim,iulim thx(i,j,k)=dxil*(th(i+1,j,k)-th(i-1,j,k)) enddo enddo enddo #if (POLES == 0) if (leftedge.eq.1) then do k=1,n3 do j=1,n2 thx(1,j,k)=(1-ibcx)*dxi*(th(2,j,k)-th(1,j,k)) * +ibcx*dxil*(th(2,j,k)-th(-1,j,k)) enddo enddo end if if (rightedge.eq.1) then do k=1,n3 do j=1,n2 thx(n1,j,k)=(1-ibcx)*dxi*(th(n1,j,k)-th(n1-1,j,k)) * +ibcx*dxil*(th(n1+2,j,k)-th(n1-1,j,k)) enddo enddo end if #endif if (j3 .eq. 1) then #if (POLES == 0) jllim = 1 + j3*botedge julim = mp - j3*topedge #else jllim = 1 julim = mp #endif do k=1,n3 do j=jllim,julim do i=1,n1 thy(i,j,k)=dyil*(th(i,j+1,k)-th(i,j-1,k)) enddo enddo enddo #if (POLES == 0) if (botedge.eq.1) then thy(i,1,k)=(1-ibcy)*dyi*(th(i,1+j3,k)-th(i,1,k)) * +ibcy*dyil*(th(i,1+j3,k)-th(i,-j3,k)) end if if (topedge.eq.1) then thy(i,n2,k)=(1-ibcy)*dyi*(th(i,n2,k)-th(i,n2-j3,k)) * +ibcy*dyil*(th(i,n2+2,k)-th(i,n2-j3,k)) end if #endif else do k=1,n3 do j=1,n2 do i=1,n1 thy(i,j,k)=0. enddo enddo enddo end if do i=1,n1 do j=1,n2 do k=2,n3-1 thz(i,j,k)=dzil*(th(i,j,k+1)-th(i,j,k-1)) enddo thz(i,j,1)=dzi*(th(i,j,2)-th(i,j,1)) thz(i,j,l)=dzi*(th(i,j,l)-th(i,j,l-1)) enddo enddo do k=1,n3 do j=1,n2 do i=1,n1 thx(i,j,k)=thx(i,j,k)+c13(i,j)*gmul(k)*thz(i,j,k) thy(i,j,k)=thy(i,j,k)+c23(i,j)*gmul(k)*thz(i,j,k) thz(i,j,k)=gi(i,j)*thz(i,j,k) enddo enddo enddo calculate potential vorticity on zbar-surfaces do k=1,n3 do j=1,n2 do i=1,n1 pv(i,j,k) = dti*(thx(i,j,k)*vrx(i,j,k) + * thy(i,j,k)*vry(i,j,k) + * thz(i,j,k)*vrz(i,j,k) )/ * (rho(i,j,k)*gi(i,j)) enddo enddo enddo calculate the norm of the potential temperature vector if (inorm.eq.1) then do k=1,n3 do j=1,n2 do i=1,n1 thn(i,j,k) = sqrt( thx(i,j,k)*thx(i,j,k) . +thy(i,j,k)*thy(i,j,k) . +thz(i,j,k)*thz(i,j,k)) * /(rho(i,j,k)*gi(i,j)*dt) enddo enddo enddo calculate normalized potential vorticity on zbar-surfaces do k=1,n3 do j=1,n2 do i=1,n1 pv(i,j,k) = pv(i,j,k)/(thn(i,j,k)+eps) enddo enddo enddo end if create interpolated vorticity and pv field on isentropic surfaces construct isentropic sufaces first if (ith .eq. 1) then do kth=1,n3 do j=1,n2 do i=1,n1 if (the(1,1,kth) .le. th(i,j,1)) then zth(i,j,kth)=0. else if (the(1,1,kth) .ge. th(i,j,n3)) then zth(i,j,kth)=zb else do k=2,n3 if (the(1,1,kth) .ge. th(i,j,k-1) .and. * the(1,1,kth) .le. th(i,j,k) ) then zth(i,j,kth) = zcr(k) + * (zcr(k)-zcr(k-1))*(the(1,1,kth)-th(i,j,k))/ * (th(i,j,k)-th(i,j,k-1)+eps) if (zth(i,j,kth) .le. 0) then zth(i,j,kth)=0. else zth(i,j,kth)=zs(i,j)+zth(i,j,kth)/gi(i,j) end if end if end do end if end do end do end do do kth=n3,1,-1 do j=1,n2 do i=1,n1 zbr=zth(i,j,kth) if (zbr .gt. 0.) then brk=zbr*dzi+1. kbr=min0(n3,nint(brk+.5)) kbrm=kbr-1 thx(i,j,kth)=vrx(i,j,kbrm)+ * (vrx(i,j,kbr)-vrx(i,j,kbrm))*(brk-float(kbrm)) thy(i,j,kth)=vry(i,j,kbrm)+ * (vry(i,j,kbr)-vry(i,j,kbrm))*(brk-float(kbrm)) thz(i,j,kth)=vrz(i,j,kbrm)+ * (vrz(i,j,kbr)-vrz(i,j,kbrm))*(brk-float(kbrm)) thn(i,j,kth)=pv(i,j,kbrm)+ * (pv(i,j,kbr)-pv(i,j,kbrm))*(brk-float(kbrm)) else thx(i,j,kth)=0. thy(i,j,kth)=0. thz(i,j,kth)=0. thn(i,j,kth)=0. end if enddo enddo enddo do k=1,n3 do j=1,n2 do i=1,n1 pv(i,j,k)=thn(i,j,k) enddo enddo enddo end if compute some diagnostics for PV pvmx=-1.e15 pvmn= 1.e15 pvav= 0. c do i=1,n c do j=1,m c do k=1,l c pvmx=amax1(pvmx,pv(i,j,k)) c pvmn=amin1(pvmn,pv(i,j,k)) c pvav= pvav+pv(i,j,k) c enddo c enddo c enddo pvmx=globmax(pv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) pvmn=globmin(pv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) pvav=globsum(pv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) pvav=pvav/float(nml) pvsd=0. do i=1,n do j=1,m do k=1,l c pvsd=pvsd+(pv(i,j,k)-pvav)**2 temp(i,j,k)=(pv(i,j,k)-pvav)**2 enddo enddo enddo pvsd=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) pvsd=sqrt(pvsd/float(nml)) if (mype.eq.0) then print 201, pvmx,pvmn,pvav,pvsd 201 format(1x,'pvmx,pvmn,pvav,pvsd:',4e11.4) endif return end subroutine vort(u,v,w,vrx,vry,vrz,iflg) c iflg - flag for vorticity (0) or c perturbation vorticity (1) include 'param.nml' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l), . v(1-ih:np+ih, 1-ih:mp+ih, l), . w(1-ih:np+ih, 1-ih:mp+ih, l), . vrx(1-ih:np+ih, 1-ih:mp+ih, l), . vry(1-ih:np+ih, 1-ih:mp+ih, l), . vrz(1-ih:np+ih, 1-ih:mp+ih, l), . dzil(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue (1-ih:np+ih,1-ih:mp+ih,l), . ve (1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih), + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) #if (ANALIZE == 0) common/blank/ ug(1-ih:np+ih, 1-ih:mp+ih, l), . vg(1-ih:np+ih, 1-ih:mp+ih, l), . wg(1-ih:np+ih, 1-ih:mp+ih, l), . ugc(1-ih:np+ih, 1-ih:mp+ih, l), . vgc(1-ih:np+ih, 1-ih:mp+ih, l), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l), . scr6(1-ih:np+ih, 1-ih:mp+ih, l, 8) #else common/blank/ ug(1-ih:np+ih, 1-ih:mp+ih, l), . vg(1-ih:np+ih, 1-ih:mp+ih, l), . wg(1-ih:np+ih, 1-ih:mp+ih, l), . ugc(1-ih:np+ih, 1-ih:mp+ih, l), . vgc(1-ih:np+ih, 1-ih:mp+ih, l), . tmp1(1-ih:np+ih, 1-ih:mp+ih, l), . tmp2(1-ih:np+ih, 1-ih:mp+ih, l), . tmp3(1-ih:np+ih, 1-ih:mp+ih, l), . scr1(1-ih:np+ih, 1-ih:mp+ih, l) #endif c-------------------------------------------------------- c ---- define metric weighted velocities * dt do k=1,l do j=1,mp do i=1,np ug(i,j,k)=(u(i,j,k)-iflg*ue(i,j,k)) * dt vg(i,j,k)=(v(i,j,k)-iflg*ve(i,j,k)) * dt wg(i,j,k)=w(i,j,k) * dt g110i=(1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1. g220i=gmm(i,j,k) ugc(i,j,k)=ug(i,j,k)*g110i vgc(i,j,k)=vg(i,j,k)*g220i enddo enddo enddo call update(ug,np,mp,l,np,mp,iup) call update(vg,np,mp,l,np,mp,iup) call update(wg,np,mp,l,np,mp,iup) call update(ugc,np,mp,l,np,mp,iup) call update(vgc,np,mp,l,np,mp,iup) c-------------------------------------------------------- c ---- establish special indices and increments do k=1,l dzil(k)=0.5*dzi enddo dzil(1)=ibcz*(0.5*dzi)+(1-ibcz)*dzi dzil(l)=ibcz*(0.5*dzi)+(1-ibcz)*dzi c ---- begin main loop do k=1,l km=ibcz*(k-1+(l+1-k)/l*(l-1))+(1-ibcz)*max0(k-1,1) kp=ibcz*(k+1 -k /l*(l-1))+(1-ibcz)*min0(k+1,l) do j=1,mp #if (POLES == 0) if (botedge.eq.1 .and. j.eq.1) then jm = ibcy*(-1) + (1-ibcy)*1 dyil=ibcy*(0.5*dyi)+(1-ibcy)*dyi else jm = j - 1 dyil=0.5*dyi end if if (topedge.eq.1 .and. j.eq.mp) then jp = ibcy*(mp+2) + (1-ibcy)*mp dyil=ibcy*(0.5*dyi)+(1-ibcy)*dyi else jp = j + 1 dyil=0.5*dyi end if #else jm = j - 1 jp = j + 1 dyil=0.5*dyi #endif do i=1,np #if (POLES == 0) if (leftedge.eq.1 .and. i.eq.1) then im = ibcx*(-1) + (1-ibcx)*1 dxil=ibcx*(0.5*dxi)+(1-ibcx)*dxi else im = i - 1 dxil=0.5*dxi end if if (rightedge.eq.1 .and. i.eq.np) then ip = ibcx*(np+2) + (1-ibcx)*np dxil=ibcx*(0.5*dxi)+(1-ibcx)*dxi else ip = i + 1 dxil=0.5*dxi end if #else im = i - 1 ip = i + 1 dxil=0.5*dxi #endif c ---- establish metric coefficients g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k)*j3 g11=strxx(i,j) g12=stryx(i,j) g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k) g21=strxy(i,j) g22=stryy(i,j) g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k) g33=gi(i,j)*gmus(k) c ---- compute the vorticity *dt vrx(i,j,k)=g220*( dxil *g21*(wg(ip,j,k)-wg(im,j,k)) 1 + dyil *g22*(wg(i,jp,k)-wg(i,jm,k)) 2 + dzil(k)*g23*(wg(i,j,kp)-wg(i,j,km)) 3 - dzil(k)*g33*(vgc(i,j,kp)-vgc(i,j,km)) ) vry(i,j,k)=g110* ( dzil(k)*g33*(ugc(i,j,kp)-ugc(i,j,km)) 2 - ( dxil *g11*(wg(ip,j,k)-wg(im,j,k)) 3 + dyil *g12*(wg(i,jp,k)-wg(i,jm,k)) 4 + dzil(k)*g13*(wg(i,j,kp)-wg(i,j,km)) ) ) vrz(i,j,k)=g110*g220*( 1 (dxil *g11*(vgc(ip,j,k)-vgc(im,j,k)) 1 + dyil *g12*(vgc(i,jp,k)-vgc(i,jm,k)) 2 + dzil(k)*g13*(vgc(i,j,kp)-vgc(i,j,km)) ) . - (dxil *g21*(ugc(ip,j,k)-ugc(im,j,k)) 4 + dyil *g22*(ugc(i,jp,k)-ugc(i,jm,k)) 5 + dzil(k)*g23*(ugc(i,j,kp)-ugc(i,j,km)) ) ) enddo enddo enddo ! end main loop c-------------------------------------------------------- C---------> enforce boundary conditions icyclfrc=0 if(icyclfrc.eq.1) then if(ibcz.eq.0) then do j=1,mp do i=1,np vrx(i,j,1)=vrx(i,j, 2 ) vrx(i,j,l)=vrx(i,j,l-1) vry(i,j,1)=vry(i,j, 2 ) vry(i,j,l)=vry(i,j,l-1) vrz(i,j,1)=vrz(i,j, 2 ) vrz(i,j,l)=vrz(i,j,l-1) enddo enddo endif #if (POLES == 0) if(leftedge.eq.1.and.ibcx.eq.0) then do k=1,l do j=1,mp vrx(1,j,k)=vrx(2,j,k) vry(1,j,k)=vry(2,j,k) vrz(1,j,k)=vrz(2,j,k) enddo enddo endif if(rightedge.eq.1.and.ibcx.eq.0) then do k=1,l do j=1,mp vrx(np,j,k)=vrx(np-1,j,k) vry(np,j,k)=vry(np-1,j,k) vrz(np,j,k)=vrz(np-1,j,k) enddo enddo endif if (j3.eq.1) then if (botedge.eq.1.and.ibcy.eq.0) then do k=1,l do i=1,np vrx(i,1,k)=vrx(i,1+j3,k) vry(i,1,k)=vry(i,1+j3,k) vrz(i,1,k)=vrz(i,1+j3,k) enddo enddo endif if (topedge.eq.1.and.ibcy.eq.0) then do k=1,l do i=1,np vrx(i,mp,k)=vrx(i,mp-j3,k) vry(i,mp,k)=vry(i,mp-j3,k) vrz(i,mp,k)=vrz(i,mp-j3,k) enddo enddo endif endif endif #endif c-------------------------------------------------------- compute vorticity diagnostics nml=n*m*l c ---- standard statistics vrxmx=-1.e15 vrxmn= 1.e15 vrxav= 0. vrymx=-1.e15 vrymn= 1.e15 vryav= 0. vrzmx=-1.e15 vrzmn= 1.e15 vrzav= 0. vrxmx=globmax(vrx,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrxmn=globmin(vrx,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrxav=globsum(vrx,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrymx=globmax(vry,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrymn=globmin(vry,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vryav=globsum(vry,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrzmx=globmax(vrz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrzmn=globmin(vrz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrzav=globsum(vrz,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrxav=vrxav/float(nml) vryav=vryav/float(nml) vrzav=vrzav/float(nml) vrxsd=0. vrysd=0. vrzsd=0. do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=(vrx(i,j,k)-vrzav)**2 tmp2(i,j,k)=(vry(i,j,k)-vryav)**2 tmp3(i,j,k)=(vrz(i,j,k)-vrzav)**2 enddo enddo enddo vrxsd=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrysd=globsum(tmp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrzsd=globsum(tmp3,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrxsd=sqrt(vrxsd/float(nml)) vrysd=sqrt(vrysd/float(nml)) vrzsd=sqrt(vrzsd/float(nml)) print 201, vrxmx,vrxmn,vrxav,vrxsd 201 format(3x,'vrxmx,vrxmn,vrxav,vrxsd:',2x,4(1x,e11.4)) print 202, vrymx,vrymn,vryav,vrysd 202 format(3x,'vrymx,vrymn,vryav,vrysd:',2x,4(1x,e11.4)) print 203, vrzmx,vrzmn,vrzav,vrzsd 203 format(3x,'vrzmx,vrzmn,vrzav,vrzsd:',2x,4(1x,e11.4)) c-------------------------------------------------------- c ---- divergence of solenoidal vorticity * dt do k=1,l do j=1,mp do i=1,np g110=1./((1-icylind)*gmm(i,j,k)*cosa(i,j)+icylind*1.) g220=1./gmm(i,j,k) g11=strxx(i,j)*g110 g12=stryx(i,j)*g110 g13=(s13(i,j)*gmul(k)-h13(i,j))*gmus(k)*g110 g21=strxy(i,j)*g220 g22=stryy(i,j)*g220 g23=(s23(i,j)*gmul(k)-h23(i,j))*gmus(k)*g220 g33=gi(i,j)*gmus(k) ug(i,j,k)=g11*vrx(i,j,k)+g21*vry(i,j,k) vg(i,j,k)=g12*vrx(i,j,k)+g22*vry(i,j,k) wg(i,j,k)=g13*vrx(i,j,k)+g23*vry(i,j,k)+g33*vrz(i,j,k) dnmi=1./(stryy(i,j)*strxx(i,j)-stryx(i,j)*strxy(i,j)) tmp3(i,j,k)=((1-icylind)*gmm(i,j,k)**2*cosa(i,j) . +icylind*gmm(i,j,k))/(gi(i,j)*gmus(k))*dnmi enddo enddo enddo call rhsdiv(ug,vg,wg,tmp3,ugc,0) ! tmp3 is Jacobian nml=n*m*l vrdvmx=-1.e15 vrdvmn= 1.e15 vrdvav= 0. vrdvmx=globmax(ugc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrdvmn=globmin(ugc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrdvav=globsum(ugc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrdvav=vrdvav/float(nml) vrdvsd=0. do k=1,l do j=1,mp do i=1,np tmp1(i,j,k)=(ugc(i,j,k)-vrdvav)**2 enddo enddo enddo vrdvsd=globsum(tmp1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) vrdvsd=sqrt(vrdvsd/float(nml)) print 204, vrdvmx,vrdvmn,vrdvav,vrdvsd 204 format(1x,'vrdvmx,vrdvmn,vrdvav,vrdvsd:',4(1x,e11.4)) return end #endif /* VORTPL == 1 */ subroutine reystress(f,w,n1,n2,n3,iflg,lipps) include 'param.nml' include 'msg.inc' real f(1-ih:np+ih, 1-ih:mp+ih, l) real w(1-ih:np+ih, 1-ih:mp+ih, l) real frey(1-ih:np+ih, 1-ih:mp+ih, l) character*80 lhead dimension fav(l),wav(l),fwav(l),reys(l),reysd(l), 1 zcr(l),wgt(l),ar(l),rho(l),reysdiv(l),ff(n,l),ffu(n,l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/dragc/ dragx(nth),dragy(nth),drgnorm, itd, idrag common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/skew/ w2(l) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . wz(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l), . fwz(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 11) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fz(1-ih:np+ih, 1-ih:mp+ih, l), . wz(1-ih:np+ih, 1-ih:mp+ih, l), . fw(1-ih:np+ih, 1-ih:mp+ih, l), . fwz(1-ih:np+ih, 1-ih:mp+ih, l), . scr3(1-ih:np+ih, 1-ih:mp+ih, l, 4) #endif common/srprint/ itblpri nsq=1 izbar=0 xnorm=1. cpr print *,'***********************iflg=',iflg if(iflg.eq.8.or.iflg.eq.81.or.iflg.eq.82 . .or.iflg.eq.91) then izbar=0 nsq=2 endif zlam=1.e3 ntp=n3 top=(ntp-1)*dz/zlam #if (POLES == 0) il=1 ir=n1-ibcx jl=1 jr=n2-ibcy #else il=1 ir=n1 jl=1 jr=n2 #endif do 1 kc=1,n3 1 zcr(kc)=(kc-1)*dz call density profile call rhprof(rho,zcr,n3,lipps) create f*w product (for izbar=1 only) if (izbar .eq. 1) then do k=1,n3 do i=il,ir do j=jl,jr fw(i,j,k)=f(i,j,k)*w(i,j,k) enddo enddo enddo call interz(fw,fwz,fwav,wgt,n1,n2,n3) endif create interpolated fields call interz( f, fz, fav,wgt,n1,n2,n3) call interz( w, wz, wav,wgt,n1,n2,n3) compute fluxes cnorm=1. if(iflg.eq.1 .or. iflg.eq.2) cnorm=cnorm*drgnorm ip=0 do 3 kc=n3,1,-1 reys(kc)=0. if (izbar .eq. 1) then do i=il,ir do j=jl,jr reys(kc) = reys(kc) + * (fwz(i,j,kc)-fav(kc)*wav(kc))*rho(kc) enddo enddo endif if (izbar .eq. 0) then do i=il,ir do j=jl,jr frey(i,j,kc)=(fz(i,j,kc)-fav(kc))**nsq * *(wz(i,j,kc)-wav(kc))*rho(kc) reys(kc) = reys(kc) + frey(i,j,kc) enddo enddo endif cdf if (wgt(kc).eq.float(ir*jr)) then cdf reys(kc)=reys(kc)*dx*dy/cnorm if (wgt(kc).gt.0.) then reys(kc)=reys(kc)/wgt(kc) ip=ip+1 else reys(kc)=2.*reys(kc+1)-reys(kc+2) endif 3 continue if(iflg.eq.9) then do k=1,n3 w2(k)=reys(k) enddo return endif if(iflg.eq.3.and.inorm.eq.1) then iz=1 reymn=1.e30 do k=2,n3 if(reys(k).lt.reys(k-1).and.reys(k).lt.reymn) then iz=k reymn=reys(k) endif enddo zi=(iz-1)*dz wstr=(g/th00*zi*hf00)**(1./3.) tstr=hf00/amax1(wstr,1.e-15) qstr=qf00/amax1(wstr,1.e-15) print 777, zi,wstr,tstr,qstr 777 format(2x,'zi, w*, th*, q*:',4e11.4) endif compute standard deviation of Reynolds stress do 4 kc=n3,1,-1 reysd(kc)=0. if (izbar .eq. 1) then do i=il,ir do j=jl,jr reysd(kc) = reysd(kc) + * ( (fwz(i,j,kc)-fav(kc)*wav(kc))*rho(kc)*dx*dy/cnorm ccc * ((fwz(i,j,kc)-fav(kc)*wav(kc))*rho(kc) * -reys(kc))**2 enddo enddo endif if (izbar .eq. 0) then do i=il,ir do j=jl,jr reysd(kc) = reysd(kc) + * ((fz(i,j,kc)-fav(kc))**nsq*(wz(i,j,kc)-wav(kc)) * *rho(kc)*dx*dy/cnorm - reys(kc) )**2 ccc * *rho(kc)-reys(kc))**2 enddo enddo endif if (wgt(kc).gt.0.) then cdf if (wgt(kc).eq.float(ir*jr)) then reysd(kc)=reysd(kc)/wgt(kc) else reysd(kc)=2.*reysd(kc+1)-reysd(kc+2) endif 4 continue if(inorm.eq.1) then zlam=zi top=(ntp-1)*dz/zlam if(iflg.eq.3.or.iflg.eq.31.or.iflg.eq.32) xnorm=1./(wstr*tstr) if(iflg.eq.4.or.iflg.eq.41.or.iflg.eq.42) xnorm=1./wstr**3 if(iflg.eq.8.or.iflg.eq.81.or.iflg.eq.82) xnorm=1./wstr**3 if(iflg.eq.1.or.iflg.eq.2) xnorm=1./wstr**2 if(iflg.eq.5.or.iflg.eq.6) xnorm=1./qstr**2 do k=1,n3 reys(k)= reys(k)*xnorm reysd(k)=reysd(k)*xnorm*xnorm enddo endif if(iflg.eq.91) then do k=1,n3 reys(k)= reys(k)/(sqrt(amax1(1.e-10,w2(k)))**3) reysd(k)=reysd(k)/(sqrt(amax1(1.e-10,w2(k)))**3) enddo endif #if (GKS == 1) t1=-1.e10 t2=+1.e10 t3=-1.e10 t4=-1.e10 t5=+1.e10 do k=1,n3 zcr(k)=zcr(k)/zlam t1=amax1(t1,reys(k)) t2=amin1(t2,reys(k)) t3=amax1(t3,reysd(k)) t4=amax1(t4,reysdiv(k)) t5=amin1(t5,reysdiv(k)) enddo c ... set limits on reysd del=abs(t3)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta slim3=0.0 slim4=4.*delta c ... set limits on avg del=abs(t1-t2)/4. if (del.lt.1.e-10) del=1.e-10 c ... set delta to smallest 2**n .ge. del t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**it if (delta.lt.del) delta=2.*delta c ... set slim1 to largest multiple of delta less than t2 c ... n.b. if this delta doesnt give proper slim2, use 2*delta 45 t=t2/delta+1.e-3+sign(1.e-3,t2) it=int(t) slim1=float(it)*delta if (slim1.gt.t2) slim1=float(it-1)*delta slim2=slim1+4.*delta if (slim2.ge.t1) go to 55 delta=2.*delta go to 45 55 continue c print *,'reys',reys c print *,'reysdiv',reysdiv c overwrite min max for reys profiles special Nils c slim1=-1.e-3 c slim2=1.e-3 c slim3=-0.05 c slim4=0.05 call set(.1,.9,.1,.9,0.,1.,0.,top,1) ipt1=int(192.8+819.2) call wrtitl(lhead,iflg,time,1,1) call plchhq(cpux(512),cpuy(ipt1),lhead(1:43),0.015,0.,0.) if(inorm.eq.0) then call plchhq(cpux(990),cpuy(512),'z [cm] -->',0.02,90.,0.) else call plchhq(cpux(990),cpuy(512),'z/zi -->',0.02,90.,0.) endif call plchhq(cpux(307),cpuy(50),'mean',0.015,0.,0.) call plchhq(cpux(717),cpuy(50),'st. dev.',0.015,0.,0.) is=n3-ip+1 call set(.1,.45,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.0)',3,6,2,2,20,20,0) call periml(1,10,6,3) write (lhead,200) slim1,slim2 call plchhq(cpux(257),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.1,.45,.1,.9,slim1,slim2,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(reys(is),zcr(is),ip) call set(.55,.9,.1,.9,0.,1.,0.,top,1) call labmod('(f3.1)','(f6.0)',3,6,2,2,20,20,0) call periml(1,10,6,3) write (lhead,200) slim3,slim4 call plchhq(cpux(717),cpuy(20),lhead(1:26),0.015,0.,0.) call set(.55,.9,.1,.9,slim3,slim4,0.,top,1) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(reysd(is),zcr(is),ip) call frame #endif if(itblpri.eq.1) then 770 format(4x,e14.7) if(iflg.eq.3) then print 701 701 format(2x,' *** *** ') print 770, (reys(k),k=1,l) endif if(iflg.eq.8) then print 703 703 format(2x,' *** *** ') print 770, (reys(k),k=1,l) endif endif 200 format(e11.4,' -->',e11.4) return end subroutine inzxy(kc,f,fiz,n1,n2,n3,izcr,ispvl,nkug) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l) dimension fiz(n1,n2) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common /smospv/ spval,jswt,ioffp c nkug = 0 nm=n1*n2 jswt=1 if(izcr.eq.0) then ioffp=0 spval=0.0 do i=1,n do j=1,m fiz(i,j)=f(i,j,kc) enddo enddo else ioffp=1 C# spval=1234567890. zcr=(kc-1)*dz do i=1,n do j=1,m zbr=(zcr-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if (kbr.ge.2) then fiz(i,j)=f(i,j,kbrm)+ * (f(i,j,kbr )-f(i,j,kbrm))*(brk-float(kbrm)) else C# fiz(i,j)=spval*ispvl constant for underground points used in interpolations nkug = 123456*ispvl spval=nkug fiz(i,j)=spval endif enddo enddo endif return end subroutine inzxy3(f,fiz,n1,n2,n3) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . fiz(1-ih:np+ih, 1-ih:mp+ih, l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) c nm=n1*n2 do 100 k=1,n3 zcr=(k-1)*dz do i=1,n do j=1,m zbr=(zcr-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if (kbr.ge.2) then fiz(i,j,k)=f(i,j,kbrm) . +(f(i,j,kbr )-f(i,j,kbrm))*(brk-float(kbrm)) else fiz(i,j,k)=0. endif enddo enddo 100 continue return end subroutine interz(f,fz,fav,wgt,n1,n2,n3) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . fz(1-ih:np+ih, 1-ih:mp+ih, l) dimension fav(n3),wgt(n3),zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly,irdbc #if (POLES == 0) il=1 ir=n1-ibcx jl=1 jr=n2-ibcy #else il=1 ir=n1 jl=1 jr=n2 #endif do 1 kc=1,n3 zcr(kc)=(kc-1)*dz 1 continue do 2 kc=n3,1,-1 fav(kc)=0. wgt(kc)=0. do j=jl,jr do i=il,ir zbr=(zcr(kc)-zs(i,j))*gi(i,j) brk=zbr*dzi+1. kbr=min0(n3, nint(brk+.5)) kbrm=kbr-1 if (kbr.ge.2) then fz(i,j,kc)=f(i,j,kbrm)+ * (f(i,j,kbr )-f(i,j,kbrm))*(brk-float(kbrm)) fav(kc)=fav(kc) + fz(i,j,kc) wgt(kc)=wgt(kc) + 1. else fz(i,j,kc)=0. endif enddo enddo if (wgt(kc).gt.0.) then fav(kc)=fav(kc)/wgt(kc) else fav(kc)=2.*fav(kc+1)-fav(kc+2) endif 2 continue return end subroutine filtplt(fl,fxyz,df,hx,hy,hz,pz) include 'param.nml' include 'msg.inc' dimension fl(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . df(1-ih:np+ih, 1-ih:mp+ih, l), . hx(1-ih:np+ih, 1-ih:mp+ih, l), . hy(1-ih:np+ih, 1-ih:mp+ih, l), . hz(1-ih:np+ih, 1-ih:mp+ih, l), . pz(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 nml=n*m*l icase=1 if(icase.eq.1) then itrz=16 df3=0.125/(dxi**2+j3*dyi**2+dzi**2) do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=1 df(i,j,k)=df3 enddo enddo enddo do it=1,itrz call lapdf(fl,fxyz,df,fxyz,hx,hy,hz,pz,0) do i=1,n do j=1,m do k=1,l fl(i,j,k)=fl(i,j,k)+fxyz(i,j,k) fxyz(i,j,k)=1 enddo enddo enddo enddo c go to 200 else itrh=16 dfh=0.25/(dxi**2+j3*dyi**2) prd= (dz/dx)**2 do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=prd df(i,j,k)=dfh enddo enddo enddo do it=1,itrh call lapdf(fl,fxyz,df,fxyz,hx,hy,hz,pz,0) do i=1,n do j=1,m do k=1,l fl(i,j,k)=fl(i,j,k)+fxyz(i,j,k) fxyz(i,j,k)=prd enddo enddo enddo enddo endif c 200 continue return end subroutine xzplot(jc,isy,f,u,w,n1,n3,ivctpl,iflg,nclv) include 'param.nml' include 'msg.inc' parameter (nl2=n*l*2) dimension f(n1,n3),u(n1,n3),w(n1,n3),work(nl2) character*80 lhead common /xzfrm/ is,ie,t1x,t2x,t3x,ks,ke,t1z,t2z,t3z common /smolab/ iswt,ilab, ioffm common /smospv/ spval,jswt,ioffp common/vplt/ iflv,ivu1,ivu2,ivrt common /vec2/ big,ix0,ix1,incx,iz0,iz1,incz common/litarr/ litarfl common /str03/ arowl,uvmsg,displ,dispc,cstop, 1 inita,initb,iterp,iterc,igflg,imsg,icyc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),hp(2000),zct,itc common /plzsmax/zsmx,mintop c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0,angle common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) dimension xp(n) data vecmn,vecmx,lenv/1.e-3,0.,0/ common /plot1/ xzcol(3,21),yzcol(3,21),xycol(3,22) common /plot2/ zmin(22),zmax(22),izval(22),ihlg(3,22),ihcg(3,22) data ism /0/ do i=1,2000 tp(i)=0. hp(i)=1. enddo CTEST print *,'xzplot iflg :',iflg jswt=1 ioffp=0 spval=0. ilab=0 if(iflg.eq.9.or.iflg.eq.0) ilab=1 ioffm=1 iswt=1 iflv=1 ivrt=0 itc=1 zct=1. + float(n3-1) litarfl=1 c ix0=4 c ix1=4 iz0=1 iz1=0 incx=3 ! density of vector in x direction incz=2 ! density of vector in z direction inita=4 initb=4 c scales for plot zlam=1.e3 ntp=n3-ke nbt=1+ks top=(ntp-1)*dz/zlam bot=(nbt-1)*dz/zlam botzb=(nbt-1)*dz/zb topzb=(ntp-1)*dz/zb*0. if(isphere.eq.1) then c i1=int(102.4+409.6) c ipt1=int(192.8+819.2) c ipt2=int(192.8+819.2)-50 xm0=0. xm1=360. else xml=1.e-2 xm0=-((n1-1-2*is)*0.5*dx/xml) xm1=+((n1-1-2*ie)*0.5*dx/xml) c xm0=-((icc-1-is)*dx/xml) c xm1=+((n1-icc-ie)*dx/xml) end if cccccccccccccccccccccccccccccc c contour plots follow cccccccccccccccccccccccccccccc create topography for mapping purposes c if(zsmx.gt.mintop) then zb2=.5/zb do i=1+is,n1-ie tp(i-is)=(zs(i,jc)+zs(i,jc+isy))*zb2-botzb hp(i-is)=(zh(i,jc)+zh(i,jc+isy))*zb2-topzb end do c endif if(iflg.eq.41) then iflagc=17 !v else if (iflg.eq.31) then iflagc=12 !qia -> qr else if (iflg.eq.32) then iflagc=12 !qib -> qr else if (iflg.eq.71) then iflagc=18 !vortx*dt else if (iflg.eq.72) then iflagc=19 !vorty*dt else if (iflg.eq.73) then iflagc=20 !vortz*dt else if (iflg.eq.74) then iflagc=21 !pv else if (iflg.eq.17) then iflagc=10 !chemical A else if (iflg.eq.18) then iflagc=11 !chemical B else if (iflg.eq.19) then iflagc=12 !chemical C else iflagc=iflg endif #if (COLORPL == 1) color plot create values for color map ipal =xzcol(1,iflagc) !colorpalete nclev=xzcol(2,iflagc) !number of isolines ilabl=xzcol(3,iflagc) !number of line labels zmin1=zmin(iflagc) !minimum values zmax1=zmax(iflagc) !maximum values izval1=izval(iflagc) !flag for min, max values ihlg1=ihlg(1,iflagc) !high/low labels ihcg1=ihcg(1,iflagc) !hachuring flags call sflush vps=-(t2x-t1x)/(t2z-t1z) !vps=-1.5 - sample value c plot color isolines, labels call colorpl(f(1+is,1+ks),n1,n1-(is+ie),n3,n3-(ks+ke),ism,3, . iflg,vps,nclev,ipal,ilabl,zmin1,zmax1,izval1,ihlg1,ihcg1) #else if(isphere.eq.1) then t1z=0.1 t3z=1.*(33./71.) t2z=t1z+.8*t3z end if call set(t1x,t2x,t1z,t2z,xm0,xm1,bot,top,1) iprint=0 if(iprint.eq.1) then print*,'t1x,t2x,t1z,t2z =',t1x,t2x,t1z,t2z print*,'xm0,xm1,bot,top =',xm0,xm1,bot,top end if create minimum(cmn), maximum(cmx) and contour density(cnt) izval1=izval(iflagc) if (izval1.eq.1) then cmn=zmin(iflagc) cmx=zmax(iflagc) nclv=xzcol(2,iflagc) cnt=(cmx-cmn)/float(nclv) else c nclv=xzcol(2,iflagc) call contin(f,cmn,cmx,cnt,nclv,n,l) c if(iflg.eq.6) cnt=0.05 endif #endif call getset (xvpl,xvpr,yvpb,yvpt,xwdl,xwdr,ywdb,ywdt,lnlg) call set (xvpl,xvpr,yvpb,yvpt,xm0,xm1,bot,top,lnlg) call gstxci(1) call gsplci(1) if (ivctpl.eq.1) call velvct(u(1+is,1+ks),n1,w(1+is,1+ks), . n1,n1-(is+ie),n3-(ks+ke),vecmn,vecmx,-1,lenv) if (ivctpl.eq.2) call strmln(u(1+is,1+ks),w(1+is,1+ks),work, . n1,n1-(is+ie),n3-(ks+ke),-1,ier) #if (COLORPL == 0) c plot bw isolines if (cmx.ge.cnt) then ct=cnt if(cmn.gt.ct) ct=cmn call conrec(f(1+is,1+ks),n1,n1-(is+ie),n3-(ks+ke),ct,cmx,cnt, . -1,-1,-682) end if if (cmn.le.-cnt) then do k=1,n3 do i=1,n1 f(i,k)=-f(i,k) end do end do ct=cnt if (cmx.lt.-ct) ct=-cmx cmnn=-cmn call conrec(f(1+is,1+ks),n1,n1-(is+ie),n3-(ks+ke),ct,cmnn,cnt, . -1,-1,682) end if #endif if((zsmx.gt.mintop).and.(zsmx.gt.bot)) then zlam2=.5/zlam dxxml=dx/xml if(isphere.eq.1) then pi=acos(-1.) dxa=dx/rds dxxml=dxa*180./pi endif do i=1+is,n1-ie tp(i-is)=(zs(i,jc)+zs(i,jc+isy))*zlam2 c tp(i-is)=max(bot,tp(i-is)) hp(i-is)=(zh(i,jc)+zh(i,jc+isy))*zlam2 c hp(i-is)=min(top,hp(i-is)) xp(i-is)=(i-(1+is))*dxxml+xm0 end do call setusv('LW',2000) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(xp,tp,n1-(is+ie)) call curved(xp,hp,n1-(is+ie)) call setusv('LW',1000) endif call gaseti('LTY',1) call labmod('(f6.0)','(f6.0)',6,6,1,1,20,20,0) call gridal (6,6,4,8,1,1,5,0.,0.) x2=float(n1-(is+ie)) y2=float(ntp) call set (xvpl,xvpr,yvpb,yvpt,1.,x2,1.,y2,lnlg) c call set(t1x,t2x,t1z,t2z,1.,x2,1.,y2,1) xc=(1.+x2)/2. yc=(1.+y2)/2. c xyl=xvpl-.125*(xvpr-xvpl) c yxl=yvpb-.125*(yvpt-yvpb) xyl=xvpl-.08 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') if(isphere.eq.1) then call plchhq(xc,cfuy(yxl),'x (deg)',.015, 0.,0.) else call plchhq(xc,cfuy(yxl),'x (cm)',.015, 0.,0.) c call plchhq(xc,cfuy(yxl),'x/Pi',.015, 0.,0.) c call plchhq(cfux(xyl),yc,'z/z\B1\c\N',.015,90.,0.) end if c call plchhq(cfux(xyl),yc,'z (cm)',.015,90.,0.) call plchhq(cfux(xyl),yc,'z (km)',.015,90.,0.) call wrtitl(lhead,iflg,time,jc,2) call plchhq(xc,cfuy(ypl),lhead(1:45),0.0125,0.,0.) #if (COLORPL == 0) ypld=0.93 write (lhead,200) cmx,cmn,cnt call plchhq(xc,cfuy(ypld),lhead(1:45),0.0125,0.,0.) #endif c call bndary call frame 200 format('cmx,cmn,cnt:', 3e11.4) return end subroutine yzplot(ic,isx,f,u,w,n2,n3,ivctpl,iflg,nclv) include 'param.nml' include 'msg.inc' parameter (ml2=m*l*2) dimension f(n2,n3),u(n2,n3),w(n2,n3),work(ml2) character*80 lhead common /yzfrm/ js,je,t1y,t2y,t3y,ks,ke,t1z,t2z,t3z common /smolab/ iswt,ilab, ioffm common /smospv/ spval,jswt,ioffp common/vplt/ iflv,ivu1,ivu2,ivrt common /vec2/ big,iy0,iy1,incy,iz0,iz1,incz common /str03/ arowl,uvmsg,displ,dispc,cstop, 1 inita,initb,iterp,iterc,igflg,imsg,icyc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),hp(2000),zct,itc c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0,angle common /plzsmax/zsmx,mintop common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) common/sphere/ rds,rdsi,sina(np,mp),tnga(np,mp), . cosa(1-ih:np+ih,1-ih:mp+ih), . gmm(1-ih:np+ih,1-ih:mp+ih,l) dimension xp(m) data vecmn,vecmx,lenv/1.e-3,0.,0/ common /plot1/ xzcol(3,21),yzcol(3,21),xycol(3,22) common /plot2/ zmin(22),zmax(22),izval(22),ihlg(3,22),ihcg(3,22) data ism /1/ iflv=1 ivrt=0 do i=1,2000 tp(i)=0. hp(i)=1. enddo itc=1 zct=1. + float(n3-1) iswt=1 ilab=0 litarfl=1 if(iflg.eq.9.or.iflg.eq.0) ilab=1 ioffm=1 jswt=1 ioffp=0 spval=0. c iy0=4 c iy1=4 incy=2 c iz0=1 c iz1=0 incz=2 inita=4 initb=4 c zlam=1.e3 ntp=n3-ke nbt=1+ks top=(ntp-1)*dz/zlam bot=(nbt-1)*dz/zlam botzb=(nbt-1)*dz/zb topzb=(ntp-1)*dz/zb*0. if(isphere.eq.1) then c i1=int(102.4+409.6) c ipt1=int(192.8+819.2) c ipt2=int(192.8+819.2)-50 xm0=-90.+(1-0.5)*180./float(m) xm1=-90.+(m-0.5)*180./float(m) c xm0=-90. c xm1= 90. else xml=1.e-2 xm0=ycr(ic,1)/xml xm1=ycr(ic,m)/xml end if ccccccccccccccccccccccccccccccccc c contour plots follow ccccccccccccccccccccccccccccccccc create topography for mapping purposes c if(zsmx.gt.mintop) then zb2=.5/zb do j=1+js,n2-je tp(j-js)=(zs(ic,j)+zs(ic+isx,j))*zb2-botzb hp(j-js)=(zh(ic,j)+zh(ic+isx,j))*zb2-topzb end do c endif if(iflg.eq.41) then iflagc=17 !v else if (iflg.eq.31) then iflagc=12 !qia -> qr else if (iflg.eq.32) then iflagc=12 !qib -> qr else if (iflg.eq.71) then iflagc=18 !vortx*dt else if (iflg.eq.72) then iflagc=19 !vorty*dt else if (iflg.eq.73) then iflagc=20 !vortz*dt else if (iflg.eq.74) then iflagc=21 !pv else if (iflg.eq.17) then iflagc=10 !chemical A else if (iflg.eq.18) then iflagc=11 !chemical B else if (iflg.eq.19) then iflagc=12 !chemical C else iflagc=iflg endif c--------------------------------------------------------------- #if (COLORPL == 1) color plot create value for color map ipal =yzcol(1,iflagc) nclev=yzcol(2,iflagc) ilabl=yzcol(3,iflagc) zmin1=zmin(iflagc) zmax1=zmax(iflagc) izval1=izval(iflagc) ihlg1=ihlg(1,iflagc) ihcg1=ihcg(1,iflagc) vps=-(t2y-t1y)/(t2z-t1z) !vps=-1.5 call sflush call colorpl(f(1+js,1+ks),n2,n2-(js+je),n3,n3-(ke+ks),ism,3, . iflg,vps,nclev,ipal,ilabl,zmin1,zmax1,izval1,ihlg1,ihcg1) #else call set(t1y,t2y,t1z,t2z,xm0,xm1,bot,top,1) c call gslwsc(0.75) create minimum(cmn), maximum(cmx) and contour density(cnt) izval1=izval(iflagc) if (izval1.eq.1) then cmn=zmin(iflagc) cmx=zmax(iflagc) nclv=yzcol(2,iflagc) cnt=(cmx-cmn)/float(nclv) else call contin(f,cmn,cmx,cnt,nclv,m,l) endif #endif c--------------------------------------------------------------- call getset (xvpl,xvpr,yvpb,yvpt,xwdl,xwdr,ywdb,ywdt,lnlg) call set (xvpl,xvpr,yvpb,yvpt,xm0,xm1,bot,top,lnlg) iprint=0 if(iprint.eq.1) then c print*,'xvpl,xvpr,yvpb,yvpt',xvpl,xvpr,yvpb,yvpt c print*,'xwdl,xwdr,ywdb,ywdt',xwdl,xwdr,ywdb,ywdt print*,'xm0,xm1,bot,top,lnlg',xm0,xm1,bot,top,lnlg end if call gstxci(1) call gsplci(1) if (ivctpl.eq.1) call velvct(u(1+js,1),n2,w(1+js,1), . n2,n2-(js+je),n3-(ke+ks),vecmn,vecmx,-1,lenv) if (ivctpl.eq.2) call strmln(u(1+js,1),w(1+js,1),work, . n2,n2-(js+je),n3-(ke+ks),-1,ier) c--------------------------------------------------------------- #if (COLORPL == 0) if (cmx.ge.cnt) then ct=cnt if (cmn.gt.ct) ct=cmn call conrec(f(1+js,1),n2,n2-(js+je),n3-(ke+ks),ct,cmx,cnt, . -1,-1,-682) end if if (cmn.le.-cnt) then do k=1,n3 do j=1,n2 f(j,k)=-f(j,k) end do end do ct=cnt if (cmx.lt.-ct) ct=-cmx cmnn=-cmn call conrec(f(1+js,1),n2,n2-(js+je),n3-(ke+ks),ct,cmnn,cnt, . -1,-1,682) end if #endif c--------------------------------------------------------------- c print*,'B:plotyz' c print*,'zsmx,mintop,bot,zlam',zsmx,mintop,bot,zlam if((zsmx.gt.mintop).and.(zsmx.gt.bot)) then zlam2=.5/zlam dyxml=dy/xml if(isphere.eq.1) then pi=acos(-1.) dya=dy/rds dyxml=dya*180./pi endif do j=1+js,n2-je tp(j-js)=(zs(ic,j)+zs(ic+isx,j))*zlam2 tp(j-js)=max(bot,tp(j-js)) hp(j-js)=(zh(ic,j)+zh(ic+isx,j))*zlam2 hp(j-js)=min(top,hp(j-js)) c xp(j-js)=0.5*(ycr(ic,j)+ycr(ic+isx,j))/xml xp(j-is)=(j-(1+js))*dyxml+xm0 end do call setusv('LW',2000) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(xp,tp,n2-(js+je)) call curved(xp,hp,n2-(js+je)) call setusv('LW',1000) endif call gaseti('LTY',1) call labmod('(f6.0)','(f6.0)',6,6,1,1,20,20,0) call gridal (3,6,4,8,1,1,5,0.,0.) x2=float(n2-(js+je)) y2=float(ntp) call set (xvpl,xvpr,yvpb,yvpt,1.,x2,1.,y2,lnlg) c call set(t1y,t2y,t1z,t2z,1.,x2,1.,y2,1) xc=(1.+x2)/2. yc=(1.+y2)/2. xyl=xvpl-.08 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') if(isphere.eq.1) then call plchhq(xc,cfuy(yxl),'y (deg)' ,0.015, 0.,0.) else call plchhq(xc,cfuy(yxl),'y (cm)' ,0.015, 0.,0.) c call plchhq(xc,cfuy(yxl),'y/Pi',0.015, 0.,0.) c call plchhq(cfux(xyl),yc,'z/z\B1\c\N',.015,90.,0.) end if call plchhq(cfux(xyl),yc,'z (km)' ,0.015,90.,0.) c call plchhq(cfux(xyl),yc,'z/Pi' ,0.015,90.,0.) call wrtitl(lhead,iflg,time,ic,3) call plchhq(xc,cfuy(ypl),lhead(1:45),0.0125,0.,0.) c call plchhq(cpux(512),cpuy(ipt1),lhead(1:45),0.0125,0.,0.) #if (COLORPL == 0) ypld=0.93 write (lhead,200) cmx,cmn,cnt call plchhq(xc,cfuy(ypld),lhead(1:45),0.0125,0.,0.) #endif call frame 200 format('cmx,cmn,cnt:', 3e11.4) return end subroutine xyplot(kc,f,u,v,n1,n2,ivctpl,iflg,nclv) include 'param.nml' include 'msg.inc' parameter (nm2=n*m*2) dimension f(n1,n2),u(n1,n2),v(n1,n2),work(nm2) character*80 lhead common /xyfrm/ is,ie,t1x,t2x,t3x,js,je,t1y,t2y,t3y common /smolab/ iswt,ilab, ioffm common /smospv/ spval,jswt,ioffp common/vplt/ iflv,ivu1,ivu2,ivrt common /vec2/ big,ix0,ix1,incx,iy0,iy1,incy common/litarr/ litarfl common /str03/ arowl,uvmsg,displ,dispc,cstop, 1 inita,initb,iterp,iterc,igflg,imsg,icyc common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),hp(2000),zct,itc c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0,angle common /plzsmax/zsmx,mintop common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(1-ih:np+ih,1-ih:mp+ih), + zhd(1-ih:np+ih,1-ih:mp+ih), + strxd(1-ih:np+ih,1-ih:mp+ih), + stryd(1-ih:np+ih,1-ih:mp+ih),tt,tend, + strxx(1-ih:np+ih,1-ih:mp+ih), + strxy(1-ih:np+ih,1-ih:mp+ih), + stryx(1-ih:np+ih,1-ih:mp+ih), + stryy(1-ih:np+ih,1-ih:mp+ih), + xcr(1-ih:np+ih,1-ih:mp+ih), + ycr(1-ih:np+ih,1-ih:mp+ih), + xr1(mp),xr2(mp),xc1(mp),xc2(mp), + yr1(np),yr2(np),yc1(np),yc2(np) data vecmn,vecmx,lenv/1.e-3,0.,0/ common /plot1/ xzcol(3,21),yzcol(3,21),xycol(3,22) common /plot2/ zmin(22),zmax(22),izval(22),ihlg(3,22),ihcg(3,22) data ism /0/ dimension zsp(n,m),zhp(n,m),xp(n) jswt=1 spval=0. ioffp=0 iflv=1 ivrt=0 do i=1,2000 tp(i)=0. hp(i)=1. enddo do j=1,n2 do i=1,n1 zsp(i,j)=zs(i,j) zhp(i,j)=zh(i,j) enddo enddo iswt=1 ilab=0 if(iflg.eq.9.or.iflg.eq.0) ilab=1 ioffm=1 itc=0 zct=1. + float(n2-1) litarfl=1 imp=3*itc c ix0=4 c ix1=4 c iy0=4 c iy1=4 incx=3 incy=2 inita=4 initb=4 c if(isphere.eq.1) then c i1=int(102.4+409.6) c ipt1=int(192.8+819.2) c ipt2=int(192.8+819.2)-50 xm0=0. xm1=360. ym0=-90.+(1-0.5)*180./float(m) ym1=-90.+(m-0.5)*180./float(m) else xml=1.e-2 yml=1.e-2 xm0=-((n1-1-2*is)*0.5*dx/xml)*0. xm1=+((n1-1-2*ie)*0.5*dx/xml)*2. ym0=-((n2-1-2*js)*0.5*dy/yml)*0. ym1=+((n2-1-2*je)*0.5*dy/yml)*2. endif ntp=n2-je nbt=1+js ym=(m-j3)*dy top=(ntp-1)*dy/yml bot=(nbt-1)*dy/yml botym=(nbt-1)*dy/ym topym=(ntp-1)*dy/ym*0. cccccccccccccccccccccccccccccccc c contour plots follow cccccccccccccccccccccccccccccccc create coastline for mapping purposes c yb2=.5/ym c do i=1+is,n1-ie c tp(i-is)=(ycr(i,1)+ycr(i,1+isy))*yb2-botym c hp(i-is)=(ycr(i,m)+ycr(i,m+isy))*yb2-topym c end do if(iflg.eq.41) then iflagc=17 !v else if (iflg.eq.31) then iflagc=12 !qia -> qr else if (iflg.eq.32) then iflagc=12 !qib -> qr else if (iflg.eq.71) then iflagc=18 !vortx*dt else if (iflg.eq.72) then iflagc=19 !vorty*dt else if (iflg.eq.73) then iflagc=20 !vortz*dt else if (iflg.eq.74) then iflagc=21 !pv else if (iflg.eq.77) then iflagc=22 !isentropic surface else if (iflg.eq.17) then iflagc=10 !chemical A else if (iflg.eq.18) then iflagc=11 !chemical B else if (iflg.eq.19) then iflagc=12 !chemical C else iflagc=iflg endif #if (COLORPL == 1) color plot create value for color map ipal =xycol(1,iflagc) nclev=xycol(2,iflagc) ilabl=xycol(3,iflagc) zmin1=zmin(iflagc) zmax1=zmax(iflagc) izval1=izval(iflagc) ihlg1=ihlg(1,iflagc) ihcg1=ihcg(1,iflagc) vps=-(t2x-t1x)/(t2y-t1y) call sflush call colorpl(f(1+is,1+js),n1,n1-(is+ie),n2,n2-(js+je),ism,imp, . iflg,vps,nclev,ipal,ilabl,zmin1,zmax1,izval1, . ihlg1,ihcg1) #else contour plot call set(t1x,t2x,t1y,t2y,xm0,xm1,ym0,ym1,1) create minimum(cmn), maximum(cmx) and contour density(cnt) izval1=izval(iflagc) if (izval1.eq.1) then cmn=zmin(iflagc) cmx=zmax(iflagc) nclv=xycol(2,iflagc) cnt=(cmx-cmn)/float(nclv) else call contin(f,cmn,cmx,cnt,nclv,n,m) endif #endif call getset (xvpl,xvpr,yvpb,yvpt,xwdl,xwdr,ywdb,ywdt,lnlg) call set (xvpl,xvpr,yvpb,yvpt,xm0,xm1,ym0,ym1,lnlg) call gstxci(1) call gsplci(1) if(amp.gt.0.) then cgr0=0. cgrt=amp cgri=amp*.25 call setusv('LW',2000) call conrec(zsp(1+is,1+js),n1,n1-(is+ie),n2-(js+je), . cgr0,cgrt,cgri,-1,-1,-682) c call conrec(zsp(1+is,1+js),n1,n1-(is+ie),n2-(js+je), c . .1,.1,.1,-1,-1,682) call setusv('LW',1000) endif if (ivctpl.eq.1) call velvct(u(1+is,1+js),n1,v(1+is,1+js),n1, . n1-(is+ie),n2-(js+je),vecmn,vecmx,-1,lenv) if (ivctpl.eq.2) call strmln(u(1+is,1+js),v(1+is,1+js),work,n1, . n1-(is+ie),n2-(js+je),-1,ier) #if (COLORPL == 0) if (cmx.ge.cnt) then ct=cnt if(cmn.gt.ct) ct=cmn call conrec(f(1+is,1+js),n1,n1-(is+ie),n2-(js+je),ct,cmx,cnt, . -1,-1,-682) end if if (cmn.le.-cnt) then do j=1,n2 do i=1,n1 f(i,j)=-f(i,j) end do end do ct=cnt if (cmx.lt.-ct) ct=-cmx cmnn=-cmn call conrec(f(1+is,1+js),n1,n1-(is+ie),n2-(js+je),ct,cmnn,cnt, . -1,-1,682) end if #endif if(itc.eq.1.and.icylind.eq.0) then yml2=.5/yml dxxml=dx/xml do i=1+is,n1-ie tp(i-is)=(ycr(i,1)+ycr(i+is,1))*yml2 hp(i-is)=(ycr(i,m)+ycr(i+is,m))*yml2 xp(i-is)=(i-(1+is))*dxxml+xm0 end do call setusv('LW',2000) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(xp,tp,n1-(is+ie)) call curved(xp,hp,n1-(is+ie)) call setusv('LW',1000) endif call gaseti('LTY',1) call labmod('(f6.0)','(f6.0)',6,6,1,1,20,20,0) call gridal (6,6,3,6,1,1,5,0.,0.) x2=float(n1-(is+ie)) y2=float(n2-(js+je)) call set (xvpl,xvpr,yvpb,yvpt,1.,x2,1.,y2,lnlg) c call set(t1x,t2x,t1y,t2y,1.,x2,1.,y2,1) xc=(1.+x2)/2. yc=(1.+y2)/2. xyl=xvpl-.08 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') if(isphere.eq.1) then call plchhq(xc,cfuy(yxl),'x (deg) ',0.015, 0.,0.) call plchhq(cfux(xyl),yc,'y (deg) ',0.015,90.,0.) else call plchhq(xc,cfuy(yxl),'x (cm) ',0.015, 0.,0.) call plchhq(cfux(xyl),yc,'y (cm) ',0.015,90.,0.) c call plchhq(xc,cfuy(yxl),'x/Pi',0.015, 0.,0.) c call plchhq(cfux(xyl),yc,'y/Pi',0.015,90.,0.) end if call wrtitl(lhead,iflg,time,kc,4) call plchhq(xc,cfuy(ypl),lhead(1:45),0.0125,0.,0.) c call plchhq(cpux(512),cpuy(ipt1),lhead(1:45),0.0125,0.,0.) #if (COLORPL == 0) ypld=0.93 write (lhead,200) cmx,cmn,cnt 200 format('cmx,cmn,cnt:', 3e11.4) call plchhq(xc,cfuy(ypld),lhead(1:45),0.0125,0.,0.) #endif call frame return end subroutine spplot(kc,f,n1,m1,iflg,nclv) include 'param.nml' dimension f(n1,m1) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 C data alat,alon,angl/0.,-60.,0./ data alat,alon,angl/60.,-60.,0./ call contin(f,cmn,cmx,cnt,nclv,n,m) call finplt(f,m1,n1,kc,alat,alon,angl, . 0.,iflg,cmn,cmx,cnt,nclv,time) return end subroutine finplt(z,nlat,nlonp2,kc,alat,alon,angl, . rot,iflg,cmn,cmx,cnt,nclv,time) include 'param.nml' parameter (lrwk=10000,liwk=10000, nwrk=1000,isiz=100) parameter (ncra=1000, nra=10) parameter (ICA1=10*n,ICA2=10*m) integer icra(ICA1,ICA2) integer iwrk(liwk), iama(2*liwk) real rwrk(lrwk) real xwrk(nwrk),ywrk(nwrk),iarea(isiz),igrp(isiz) real xcra(ncra), ycra(ncra), iara(nra), igra(nra) real z(nlonp2,nlat), ztrue(nlonp2,nlat) real zplt(200*200) real rlat1(2),rlat2(2),rlon1(2),rlon2(2) character*80 lhead c ipt1=int(192.8+819.2)-10 call set(0.1,0.9,0.1,0.9,0.,1.,0.,1.,1) c call wrtitl(lhead,iflg,time,kc,4) c call wtstr(cpux(512),cpuy(ipt1),lhead(1:45),2,0,0) write (lhead,200) cmx,cmn,cnt 200 format('cmx,cmn,cnt:', 3e11.4) call wtstr(cpux(512),cpuy(20),lhead(1:45),2,0,0) C++++++++++++++++++++++++++++++++++++++++++++++++++ c-------------------------------------------------- c construct the plotting array c-------------------------------------------------- call conplt (z, zplt, nlonp2, nlat) call supmap(-2,0.,-90.,0.,0.,0.,0.,0.,1,-1000,0,0,ier) C++++++++++++++++++++++++++++++++++++++++++++++++++ CREATE GRID AND MAPA ON THE SPHERE C call mapint C LMAP=50000 C call arinam (MAP,LMAP) C call mapbla (MAP) C call mapgrm (MAP, XWRK, YWRK, NWRK, IAREA, IGRP, ISIZ, mask) C call frame C++++++++++++++++++++++++++++++++++++++++++++++++++ CDEFINE GRID INCREMENT in [deg] call mapsti ('GR - GRID INCREMENT', 0) C++++++++++++++++++++++++++++++++++++++++++++++++++ CDEFINE OUTLINE DATASET FOR CONTOURS C NO - no outlines C CO - continental outlines (by default) C US - US state outlines C PS - continental + US state + international political C PO - continental + international political call mapstc ('OU - OUTLINE DATASET', 'NO') C++++++++++++++++++++++++++++++++++++++++++++++++++ CDEFINE MAP LINE COLORS FOR SPECIFIED PARTS OF MAPA COLOR 1 - WHITE COLOR 2 - RED (BLUE) COLOR 3 - GREEN COLOR 4 - BLUE (RED) COLOR 5 - MAGNETA COLOR 6 - YELLOW COLOR 7 - BLACK call mapsti ('C1 - COLOR INDEX 1 - PERIMETER',1) call mapsti ('C2 - COLOR INDEX 2 - GRID',4) call mapsti ('C3 - COLOR INDEX 3 - LABELS',6) call mapsti ('C4 - COLOR INDEX 4 - LIMB LINE',1) call mapsti ('C5 - COLOR INDEX 5 - CONTINENTAL OUTLINES',5) call mapsti ('C6 - COLOR INDEX 6 - US STATE OUTLINES',6) call mapsti ('C7 - COLOR INDEX 7 - COUNTRY OUTLINES',7) C++++++++++++++++++++++++++++++++++++++++++++++++++ CDEFINE SATELITE VIEW: central point of view C alon - longitude [deg] C alat - latitude [deg] (0 .. 180) C angl - kat skretu [deg] call maproj ('SV - SATELITE VIEW', alat, alon, angl) C++++++++++++++++++++++++++++++++++++++++++++++++++ CSETING LIMITS FOR THE PROJECTION: call mapset C MA - maximum useful area specified by rlat1,rlat2,rlon1,rlon2 C CO - see manual (page 91) C LI - see manual (page 91) C AN - see manual (page 91) C PO - see manual (page 91) rlat1(1)=-90. rlat1(2)=0. rlat2(1)=90. rlat2(2)=0. rlon1(1)=-180. rlon1(2)=0. rlon2(1)=0. rlon2(2)=0. call mapset ('MA', rlat1, rlat2, rlon1, rlon2) C++++++++++++++++++++++++++++++++++++++++++++++++++ COMBINE MAPINT + MAPGRD + MAPLBL + MAPLOT |--> MAPDRW C MAPROJ,MAPSET,MAPPOS must be before MAPDRW call mapdrw C call frame C++++++++++++++++++++++++++++++++++++++++++++++++++ CPLOT ARRAY DATA ON THE SPHERE CONTOUR LEVEL SELECTION CLS: C CLS=0 - NCL,CLV will not be changed C CLS=-n - generate n contour levels from min to max value C CLS=+n - see manual (page 397) CONTOUR INTERVAL SPECIFIER CIS: C see describtion of CLS, when CLS>0, CIS is used C CIS<=0 see describtion of CIT and LIT c call cpseti('CLS - CONTOUR LEVEL SELECTION',+26) call cpseti('CLS - CONTOUR LEVEL SELECTION',0) call cpsetr('CMN - min',cmn) call cpsetr('CMX - max',cmx) call cpsetr('CIS - interval',cnt) call cpseti('MAP - mapping',1) call cpsetr('XC1 - left edge',-180.) call cpsetr('XCM - right edge',180.) call cpsetr('YC1 - bot edge',-90.) call cpsetr('YCN - top edge',90.) call cpsetr('ORV - outofrange val',1.e12) call cpseti('SET - turn off set',0) c call cprect(zplt, nlonp2, nlonp2-1, nlat+2, rwrk,lrwk,iwrk,liwk) c c call cppkcl(zplt,rwrk,iwrk) call cpcldr(zplt, rwrk, iwrk) call frame return end subroutine conplt (z, zplt, nlonp2, nlat) real z(nlonp2,nlat), zplt(nlonp2, nlat+2) do 20 j = 1,nlat do 10 i = 1,nlonp2 zplt(i,j+1) = z(i,j) 10 continue 20 continue avgn = 0 avgs = 0 do 30 i = 1,nlonp2-2 avgn = avgn + z(i,nlat) avgs = avgs + z(i,1) 30 continue avgn = avgn/(nlonp2-2) avgs = avgs/(nlonp2-2) c do 40 i = 1,nlonp2 zplt(i,1) = avgs zplt(i,nlat+2) = avgn 40 continue c if (avgs + avgn .ne. 0.) then c write (6,*) ' conplt, avgs, avgn ', avgs, avgn c do 111 i = 1,nlonp2-2 c write (6,*) 'i, s, n ', z(i,1), z(i,nlat) c 111 continue c endif return end subroutine xyzplot(f,zs3,n1,n2,n3,iflg) include 'param.nml' include 'msg.inc' C parameter (nm2=n*m*2) dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . zs3(1-ih:np+ih, 1-ih:mp+ih, l) C dimension work(nm2) character*80 lhead return end subroutine wrtitl(lhead,iflg,time,ijk,iplf) character*80 lhead if(iplf.eq.0) then if(iflg.eq.1) write (lhead,1) time if(iflg.eq.2) write (lhead,2) time if(iflg.eq.3) write (lhead,3) time if(iflg.eq.4) write (lhead,4) time if(iflg.eq.41) write (lhead,41) time if(iflg.eq.5) write (lhead,5) time if(iflg.eq.6) write (lhead,6) time if(iflg.eq.9) write (lhead,9) time if(iflg.eq.10) write (lhead,10) time if(iflg.eq.11) write (lhead,11) time if(iflg.eq.12) write (lhead,12) time if(iflg.eq.13) write (lhead,13) time if(iflg.eq.14) write (lhead,14) time if(iflg.eq.15) write (lhead,15) time if(iflg.eq.16) write (lhead,16) time if(iflg.eq.17) write (lhead,17) time if(iflg.eq.18) write (lhead,18) time if(iflg.eq.19) write (lhead,19) time if(iflg.eq.31) write (lhead,31) time if(iflg.eq.32) write (lhead,32) time if(iflg.eq.71) write (lhead,71) time if(iflg.eq.72) write (lhead,72) time if(iflg.eq.73) write (lhead,73) time if(iflg.eq.74) write (lhead,74) time 1 format(' at time= ',f9.2) 2 format(' [K] at time= ',f9.2) 3 format(' at time= ',f9.2) 4 format(' [m/s] at time= ',f9.2) 41 format(' [m/s] at time= ',f9.2) c 4 format(' at time= ',f9.2) c 41 format(' at time= ',f9.2) 5 format(' at time= ',f9.2) 6 format(' [m/s] at time= ',f9.2) 9 format(' at time= ',f9.2) 10 format(' [g/kg] at time= ',f9.2) 11 format(' [g/kg] at time= ',f9.2) 12 format(' [g/kg] at time= ',f9.2) 31 format(' [g/kg] at time= ',f9.2) 32 format(' [g/kg] at time= ',f9.2) 13 format(' at time= ',f9.2) 14 format(' at time= ',f9.2) 15 format(' at time= ',f9.2) 16 format(' at time= ',f9.2) 17 format(' at time= ',f9.2) 18 format(' at time= ',f9.2) 19 format(' at time= ',f9.2) 71 format('vortx*dt at time= ',f9.2) 72 format('vorty*dt at time= ',f9.2) 73 format('vortz*dt at time= ',f9.2) 74 format('PV at time= ',f9.2) endif if(iplf.eq.1) then if(iflg.eq. 1) write (lhead, 101) time if(iflg.eq. 2) write (lhead, 102) time if(iflg.eq. 3) write (lhead, 103) time if(iflg.eq.31) write (lhead,1031) time if(iflg.eq.32) write (lhead,1032) time if(iflg.eq. 4) write (lhead, 104) time if(iflg.eq.41) write (lhead,1041) time if(iflg.eq.42) write (lhead,1042) time if(iflg.eq. 5) write (lhead, 105) time if(iflg.eq. 6) write (lhead, 106) time if(iflg.eq.71) write (lhead, 171) time if(iflg.eq.72) write (lhead, 172) time if(iflg.eq.73) write (lhead, 173) time if(iflg.eq.74) write (lhead, 174) time if(iflg.eq. 8) write (lhead, 108) time if(iflg.eq.81) write (lhead,1081) time if(iflg.eq.82) write (lhead,1082) time if(iflg.eq.91) write (lhead,1091) time 101 format(' )*(w-)> at time= ',f9.2) 102 format(' )*(w-)> at time= ',f9.2) 103 format(' )*(w-)> at time= ',f9.2) 1031 format(' )*(u-)> at time= ',f9.2) 1032 format(' )*(v-)> at time= ',f9.2) 104 format(' )*(w-)> at time= ',f9.2) 1041 format(' )*(u-)> at time= ',f9.2) 1042 format(' )*(v-)> at time= ',f9.2) 108 format(')**2*(w-)> at time= ',f9.2) 1081 format(')**2*(w-)> at time= ',f9.2) 1082 format(')**2*(w-)> at time= ',f9.2) 1091 format('skewness at time= ',f9.2) 105 format(' )*(w-)> at time= ',f9.2) 106 format(' )*(w-)> at time= ',f9.2) 171 format(')*(w-)> at time=',f9.2) 172 format(')*(w-)> at time=',f9.2) 173 format(')*(w-)> at time=',f9.2) 174 format(')*(w-)> at time=',f9.2) endif if(iplf.eq.2) then jc=ijk if(iflg.eq.1) write (lhead,201) time,jc if(iflg.eq.2) write (lhead,202) time,jc if(iflg.eq.3) write (lhead,203) time,jc if(iflg.eq.4) write (lhead,204) time,jc if(iflg.eq.41) write (lhead,2041) time,jc if(iflg.eq.5) write (lhead,205) time,jc if(iflg.eq.6) write (lhead,206) time,jc if(iflg.eq.9) write (lhead,209) time,jc if(iflg.eq.10) write (lhead,210) time,jc if(iflg.eq.11) write (lhead,211) time,jc if(iflg.eq.12) write (lhead,212) time,jc if(iflg.eq.13) write (lhead,213) time,jc if(iflg.eq.14) write (lhead,214) time,jc if(iflg.eq.15) write (lhead,215) time,jc if(iflg.eq.16) write (lhead,216) time,jc if(iflg.eq.17) write (lhead,217) time,jc if(iflg.eq.18) write (lhead,218) time,jc if(iflg.eq.19) write (lhead,219) time,jc if(iflg.eq.31) write (lhead,231) time,jc if(iflg.eq.32) write (lhead,232) time,jc if(iflg.eq.71) write (lhead,271) time,jc if(iflg.eq.72) write (lhead,272) time,jc if(iflg.eq.73) write (lhead,273) time,jc if(iflg.eq.74) write (lhead,274) time,jc 201 format('theta perturbation at time= ',f9.2,' j=',i4) c 202 format('isentropes [K] at time= ',f9.2,' j=',i4) 202 format('log isentropes [K] at time= ',f9.2,' j=',i4) 203 format('press perturbation at time= ',f9.2,' j=',i4) 204 format('u [m/s] at time= ',f9.2,' j=',i4) 2041 format('v [m/s] at time= ',f9.2,' j=',i4) c 204 format('u perturbation at time= ',f9.2,' j=',i4) c2041 format('v perturbation at time= ',f9.2,' j=',i4) 205 format('omega at time= ',f9.2,' j=',i4) 206 format('w [m/s] at time= ',f9.2,' j=',i4) 209 format('div(rho*v)*dt/rho at time= ',f9.2,' j=',i4) 210 format('qv [g/kg] at time= ',f9.2,' j=',i4) 211 format('qc [g/kg] at time= ',f9.2,' j=',i4) 212 format('qr [g/kg] at time= ',f9.2,' j=',i4) 231 format('qia [g/kg] at time= ',f9.2,' j=',i4) 232 format('qib [g/kg] at time= ',f9.2,' j=',i4) 213 format('rh at time= ',f9.2,' j=',i4) 214 format('thetav at time= ',f9.2,' j=',i4) 215 format('Km*dt/Dx**2 at time= ',f9.2,' j=',i4) 216 format('Ri at time= ',f9.2,' j=',i4) 217 format('chemical A at time= ',f9.2,' j=',i4) 218 format('chemical B at time= ',f9.2,' j=',i4) 219 format('chemical C at time= ',f9.2,' j=',i4) 271 format('vortx*dt at time= ',f9.2,' j=',i4) 272 format('vorty*dt at time= ',f9.2,' j=',i4) 273 format('vortz*dt at time= ',f9.2,' j=',i4) 274 format('pv at time= ',f9.2,' j=',i4) endif if(iplf.eq.3) then ic=ijk if(iflg.eq.1) write (lhead,301) time,ic if(iflg.eq.2) write (lhead,302) time,ic if(iflg.eq.3) write (lhead,303) time,ic if(iflg.eq.4) write (lhead,304) time,ic if(iflg.eq.41) write (lhead,3041) time,ic if(iflg.eq.5) write (lhead,305) time,ic if(iflg.eq.6) write (lhead,306) time,ic if(iflg.eq.9) write (lhead,309) time,ic if(iflg.eq.10) write (lhead,310) time,ic if(iflg.eq.11) write (lhead,311) time,ic if(iflg.eq.12) write (lhead,312) time,ic if(iflg.eq.13) write (lhead,313) time,ic if(iflg.eq.14) write (lhead,314) time,ic if(iflg.eq.15) write (lhead,315) time,ic if(iflg.eq.16) write (lhead,316) time,ic if(iflg.eq.17) write (lhead,317) time,ic if(iflg.eq.18) write (lhead,318) time,ic if(iflg.eq.19) write (lhead,319) time,ic if(iflg.eq.31) write (lhead,331) time,ic if(iflg.eq.32) write (lhead,332) time,ic if(iflg.eq.71) write (lhead,371) time,ic if(iflg.eq.72) write (lhead,372) time,ic if(iflg.eq.73) write (lhead,373) time,ic if(iflg.eq.74) write (lhead,374) time,ic 301 format('theta perturbation at time= ',f9.2,' i=',i4) c 302 format('isentropes [K] at time= ',f9.2,' i=',i4) 302 format('log isentropes [K] at time= ',f9.2,' i=',i4) 303 format('press perturbation at time= ',f9.2,' i=',i4) 304 format('u [m/s] at time= ',f9.2,' i=',i4) 3041 format('v [m/s] at time= ',f9.2,' i=',i4) c 304 format('u perturbation at time= ',f9.2,' i=',i4) c3041 format('v perturbation at time= ',f9.2,' i=',i4) 305 format('omega at time= ',f9.2,' i=',i4) 306 format('w [m/s] at time= ',f9.2,' i=',i4) 309 format('div(rho*v)*dt/rho at time= ',f9.2,' i=',i4) 310 format('qv [g/kg] at time= ',f9.2,' i=',i4) 311 format('qc [g/kg] at time= ',f9.2,' i=',i4) 312 format('qr [g/kg] at time= ',f9.2,' i=',i4) 331 format('qia [g/kg] at time= ',f9.2,' i=',i4) 332 format('qib [g/kg] at time= ',f9.2,' i=',i4) 313 format('rh at time= ',f9.2,' i=',i4) 314 format('thetav at time= ',f9.2,' i=',i4) 315 format('Km*dt/Dx**2 at time= ',f9.2,' i=',i4) 316 format('Ri at time= ',f9.2,' i=',i4) 317 format('chemical A at time= ',f9.2,' i=',i4) 318 format('chemical B at time= ',f9.2,' i=',i4) 319 format('chemical C at time= ',f9.2,' i=',i4) 371 format('vortx*dt at time= ',f9.2,' i=',i4) 372 format('vorty*dt at time= ',f9.2,' i=',i4) 373 format('vortz*dt at time= ',f9.2,' i=',i4) 374 format('pv at time= ',f9.2,' i=',i4) endif if(iplf.eq.4) then kc=ijk if(iflg.eq.1) write (lhead,401) time,kc if(iflg.eq.2) write (lhead,402) time,kc if(iflg.eq.3) write (lhead,403) time,kc if(iflg.eq.4) write (lhead,404) time,kc if(iflg.eq.41) write (lhead,4041) time,kc if(iflg.eq.5) write (lhead,405) time,kc if(iflg.eq.6) write (lhead,406) time,kc if(iflg.eq.9) write (lhead,409) time,kc if(iflg.eq.10) write (lhead,410) time,kc if(iflg.eq.11) write (lhead,411) time,kc if(iflg.eq.12) write (lhead,412) time,kc if(iflg.eq.13) write (lhead,413) time,kc if(iflg.eq.14) write (lhead,414) time,kc if(iflg.eq.15) write (lhead,415) time,kc if(iflg.eq.16) write (lhead,416) time,kc if(iflg.eq.17) write (lhead,417) time,kc if(iflg.eq.18) write (lhead,418) time,kc if(iflg.eq.19) write (lhead,419) time,kc if(iflg.eq.31) write (lhead,431) time,kc if(iflg.eq.32) write (lhead,432) time,kc if(iflg.eq.71) write (lhead,471) time,kc if(iflg.eq.72) write (lhead,472) time,kc if(iflg.eq.73) write (lhead,473) time,kc if(iflg.eq.74) write (lhead,474) time,kc if(iflg.eq.77) write (lhead,477) time,kc 401 format('theta perturbation at time= ',f9.2,' k=',i4) c 402 format('isentropes [K] at time= ',f9.2,' k=',i4) 402 format('log isentropes [K] at time= ',f9.2,' k=',i4) 403 format('press perturbation at time= ',f9.2,' k=',i4) 404 format('u [m/s] at time= ',f9.2,' k=',i4) 4041 format('v [m/s] at time= ',f9.2,' k=',i4) c 404 format('u perturbation at time= ',f9.2,' k=',i4) c4041 format('v perturbation at time= ',f9.2,' k=',i4) 405 format('omega at time= ',f9.2,' k=',i4) 406 format('w [m/s] at time= ',f9.2,' k=',i4) 409 format('div(rho*v)*dt/rho at time= ',f9.2,' k=',i4) 410 format('qv [g/kg] at time= ',f9.2,' k=',i4) 411 format('qc [g/kg] at time= ',f9.2,' k=',i4) 412 format('qr [g/kg] at time= ',f9.2,' k=',i4) 431 format('qia [g/kg] at time= ',f9.2,' k=',i4) 432 format('qib [g/kg] at time= ',f9.2,' k=',i4) 413 format('rh at time= ',f9.2,' k=',i4) 414 format('thetav at time= ',f9.2,' k=',i4) 415 format('Km*dt/Dx**2 at time= ',f9.2,' k=',i4) 416 format('Ri at time= ',f9.2,' k=',i4) 417 format('chemical A at time= ',f9.2,' k=',i4) 418 format('chemical B at time= ',f9.2,' k=',i4) 419 format('chemical C at time= ',f9.2,' k=',i4) 471 format('vortx*dt at time= ',f9.2,' k=',i4) 472 format('vorty*dt at time= ',f9.2,' k=',i4) 473 format('vortz*dt at time= ',f9.2,' k=',i4) 474 format('pv at time= ',f9.2,' k=',i4) 477 format('isentropic sufaces at time= ',f9.2,' k=',i4) endif if(iplf.eq.5) then if(iflg.eq.16) write (lhead,516) time 516 format('Ri in 3D at time= ',f9.2) endif CTEST print *,lhead return end subroutine contin(f,cmin,cmax,delta,nlev,n,m) dimension f(n,m) common /smospv/ spval,jswt,ioffp nm=n*m cmin=1.e-11 cmax=1.e-11 delta=1.e-10 cmx=-1.e15 cmn= 1.e15 if(ioffp.eq.0) then do i=1,nm cmx=amax1(cmx,f(i,1)) cmn=amin1(cmn,f(i,1)) enddo else do i=1,nm if(f(i,1).ne.spval) then cmx=amax1(cmx,f(i,1)) cmn=amin1(cmn,f(i,1)) endif enddo endif del=(cmx-cmn)/float(nlev) if(del.lt.1.e-10) return t=alog(del)/alog(2.) t=t+sign(1.e-3,t) it=int(t) delta=2.**(it) if(delta.lt.del) delta=2.*delta t=cmn/delta+sign(1.e-3,cmn) it=int(t) cmin=float(it)*delta if(cmin.le.cmn) cmin=float(it+1)*delta t=cmx/delta+sign(1.e-3,cmx) it=int(t) cmax=float(it)*delta if(cmax.ge.cmx) cmax=float(it-1)*delta cmax=cmax*(1.+sign(1.e-7,cmax)) delta=(cmax-cmin)/float(nlev) CTEST print *,'cmin, cmax, delta:',cmin,cmax,delta,nlev return end subroutine plothise(f,npl,ndm) include 'param.nml' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 real f(ndm,2),tm(nth) character*80,lhead C common// tm(nth) dtmn=dt/60. do k=1,ndm tm(k)=(k-1)*dtmn enddo fmax=-1.e15 fmin= 1.e15 do k=1,npl fmin=amin1(fmin,f(k,1),f(k,2)) fmax=amax1(fmax,f(k,1),f(k,2)) enddo tmax=(npl-1)*dtmn tmin=0. i1=int(102.4+409.6) ipt1=int(192.8+819.2) ipt1=ipt1-50 #if (GKS == 1) call set (.2,.95,.2,.8,tmin,tmax,fmin,fmax,1) call gaseti('LTY',1) call labmod('(f10.2)','(e8.2)',0,0,2,2,20,20,0) call periml(5,1,5,2) write (lhead,100) call plchhq(cpux(512),cpuy(ipt1),lhead(1:40),0.015,0.,0.) call plchhq(cpux(i1),cpuy(60),'time(min) ',0.015,0.,0.) call plchhq(cpux(22),cpuy(i1),'ekn/tke',0.015,90.,0.) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(tm,f(1,1),npl) call dashdc('$''$''$''$''$''$''$''',10,12) call curved(tm,f(1,2),npl) call frame #endif 100 format('history of global and ') return end subroutine plotdrag(f1,f2,ntd) include 'param.nml' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 real f1(nth),f2(nth),fx(nth),fy(nth),tm(nth) character*80,lhead C common// fx(nth),fy(nth),tm(nth) dtmn=dt/60. do k=2,ntd-1 tm(k)=float(k)*dtmn fx(k)=(f1(k-1)+2.*f1(k)+f1(k+1))*.25 fy(k)=(f2(k-1)+2.*f2(k)+f2(k+1))*.25 enddo tm(1)=dtmn fx(1)=f1(1) fy(1)=f2(1) tm(ntd)=float(ntd)*dtmn fx(ntd)=f1(ntd) fy(ntd)=f2(ntd) fxmax=-1.e15 fxmin= 1.e15 fymax=-1.e15 fymin= 1.e15 do k=1,ntd fxmin=amin1(fxmin,fx(k)) fxmax=amax1(fxmax,fx(k)) fymin=amin1(fymin,fy(k)) fymax=amax1(fymax,fy(k)) enddo c tmax=ntd*dtmn c tmin=0. tmax=nth*dtmn tmin=dtmn #if (GKS == 1) CTEST print *,'fxmin,fxmax:',fxmin,fxmax CTEST print *,'fymin,fymax:',fymin,fymax if(fxmin.eq.fxmax) goto 98 i1=int(102.4+409.6) ipt1=int(192.8+819.2) ipt1=ipt1-50 call set (.2,.95,.2,.8,tmin,tmax,fxmin,fxmax,1) call labmod('(f10.2)','(e8.2)',0,0,2,2,20,20,0) call periml(5,1,5,2) write (lhead,100) call plchhq(cpux(512),cpuy(ipt1),lhead(1:40),0.015,0.,0.) call plchhq(cpux(i1),cpuy(60),'time(min) ',0.015,0.,0.) call plchhq(cpux(22),cpuy(i1),'drgx/drgnorm',0.015,90.,0.) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(tm,fx,ntd) call frame 98 if(fymin.eq.fymax) goto 99 if(j3.eq.1)then call set (.2,.95,.2,.8,tmin,tmax,fymin,fymax,1) call labmod('(f10.2)','(e8.2)',0,0,2,2,20,20,0) call periml(5,1,5,2) write (lhead,101) call plchhq(cpux(512),cpuy(ipt1),lhead(1:40),0.015,0.,0.) call plchhq(cpux(i1),cpuy(60),'time(min) ',0.015,0.,0.) call plchhq(cpux(22),cpuy(i1),'drgy/drgnorm',0.015,90.,0.) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(tm,fy,ntd) call frame endif 99 continue #endif 100 format('mountain wave drag - x component') 101 format('mountain wave drag - y component') return end #endif #if (V5D == 1) subroutine vis5d_out(u,v,w,ox,oy,oz,th,p,div, 1 qv,qc,qr,qia,qib,tke,rhf,inr) include 'param.nml' include 'msg.inc' include 'vrtstr.mds' include 'param.v5d' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . w(1-ih:np+ih,1-ih:mp+ih,l), . ox(1-ih:np+ih,1-ih:mp+ih,l), . oy(1-ih:np+ih,1-ih:mp+ih,l), . oz(1-ih:np+ih,1-ih:mp+ih,l), . th(1-ih:np+ih,1-ih:mp+ih,l), . p(1-ih:np+ih,1-ih:mp+ih,l), . div(1-ih:np+ih,1-ih:mp+ih,l), . rhf(1-ih:np+ih,1-ih:mp+ih,l), . qv(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . qr(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . tke(1-ih:nkvp+ih,1-ih:mkvp+ih,lkv), . qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic) #if (ANALIZE == 0) common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz0(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 13) #else common/blank/ ri(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz0(1-ih:np+ih, 1-ih:mp+ih, l), . fxyz(1-ih:np+ih, 1-ih:mp+ih, l), . scr6(1-ih:np+ih, 1-ih:mp+ih, l, 6) #endif common/profl/th0(1-ih:np+ih,1-ih:mp+ih,l), . rho(1-ih:np+ih,1-ih:mp+ih,l), . the(1-ih:np+ih,1-ih:mp+ih,l), . ue (1-ih:np+ih,1-ih:mp+ih,l), . ve (1-ih:np+ih,1-ih:mp+ih,l), . zcr(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,ee0,hlat common/sgscnst/ ceps,cL,cm,cs,prndt common/stresd/ diagstr(8),ivis,irid,itstr integer v5dcreate,v5dclose C 5-D grid limits, must match those in v5d.h!!! integer NVARS, NTIMES, NROWS, NCOLUMNS, NLEVELS C--------------- C Missing values C--------------- real*4 MISSING integer IMISSING parameter (MISSING=1.0E35) parameter (IMISSING=-987654) C------------------- C Rest declarations C------------------- parameter (NVARS=30) parameter (NTIMES=1) parameter (NROWS=500) parameter (NCOLUMNS=500) parameter (NLEVELS=200) integer nr, nc, nl(NVARS) integer numtimes integer numvars character*10 varnamec character*10 varname(NVARS) integer dates(1) integer times(1) integer compressmode integer projection real*4 proj_args(100) integer vertical real*4 vert_args(NLEVELS) c-------------- c Local varlues c-------------- character*13 outname character*3 outn data nl/NVARS*0.0/ data varname/NVARS*' '/ data proj_args/100*0.0/ data vert_args/NLEVELS*0.0/ #include "vrtstr.fnc" ibupl=1 ithpl=1 iprpl=1 iuvpl=1 ivvpl=1 ioxpl=1 ioypl=1 iozpl=1 iwvpl=1 idvpl=1 iripl=1 iqvpl=0 iqcpl=0 iqrpl=0 irhpl=0 ithvpl=0 ikmpl=1 iqial=0 iqibl=0 nml=n*m*l nm=n*m if(j3.eq.0) then ivvpl=0 endif iqvpl=iqvpl*moist iqcpl=iqcpl*moist iqrpl=iqrpl*moist irhpl=irhpl*moist ithvpl=ithvpl*moist iqial=(iqial*moist)*iceab iqibl=(iqibl*moist)*iceab ikmpl=ikmpl*itke iripl=iripl*irid c------------------------------- c ivar is an total output fields INVARS=ibupl+ithpl+iprpl+iuvpl+ivvpl+iwvpl+ioxpl+ioypl+iozpl+ 1 idvpl+iripl+iqvpl+iqcpl+iqrpl+irhpl+ithvpl+ikmpl+ 2 iqial+iqibl c---------------------------------- cnumber of time steps and variables numtimes=1 numvars=INVARS c------------------------------- create output file name outname(1:1)='a' if (inr.lt.10) then write (outn(1:1), '(I1)') 0 write (outn(2:2), '(I1)') 0 write (outn(3:3), '(I1)') inr else if (inr.lt.100) then write (outn(1:1), '(I1)') 0 write (outn(2:3), '(I2)') inr else if (inr.lt.1000) then write (outn(1:3), '(I3)') inr else outn(1:3)='99Q' endif outname(2:4)=outn(1:3) outname(5:13)='outpt.v5d' c--------------------------------------------------------- cinitialize actual time in each time step in format HHMMSS itime_0=int(time) sec_0=time-float(itime_0) if(sec_0.gt.0) then isec=int(sec_0*60) elseif(sec_0.lt.0) then isec=int((100-sec_0)*60) else isec=0 endif ihours=int(time/60) imint_0=ihours*60 mint_0=float(imint_0) if(mint_0.gt.time) then ihours=ihours-1 imint=60-int(mint_0-time) elseif(mint_0.lt.time) then imint=int(time-mint_0) else imint=0 endif itimes=ihours*10000+imint*100+isec data (dates(i),i=1,NTIMES) / 97130 / do i=1,NTIMES times(i)=itimes enddo c--------------------------------------------------------- cinitialize compress mode (1, 2 or 4 bytes per grid point) data compressmode / 1 / c------------------------------------------- cnumber of rows(nr), columns(nc), levels(nl) convert axis left iconv=1, right conv=-1 if(j3.eq.0) then nr=2 nc=nd else if(abs(iconv).eq.1) then nr=md nc=nd else nr=nd nc=md endif endif do i=1,INVARS nl(i)=ld enddo ast=float(idiv) cprojection mode projection=0 if(projection.eq.0) then ! Generic rectilinear C This is a linear, regularly-spaced coordinate system with no implied units. C This system is useful when your data is not related to Earth cooredinates C N/S coordinates increase upward, E/W coordinates increase to the left. C C proj_args(1) = NorthBound: Northern boundary of 3-D box C proj_args(2) = WestBound : Western boundary of 3-D box C proj_args(3) = RowInc : Increment between grid columns C proj_args(4) = ColInc : Increment between grid rows ddy=ast*dy ddx=ast*dx if(j3.eq.1) then if(iconv.eq.1) then proj_args(1)=(md-1)*ddy proj_args(2)=-(nd-1)*ddx proj_args(3)=ddy proj_args(4)=ddx else if(iconv.eq.-1) then proj_args(1)=(md-1)*ddy proj_args(2)=-(nd-1)*ddx proj_args(3)=ddy proj_args(4)=ddx else if(iconv.eq.0) then proj_args(1)=(nd-1)*ddx proj_args(2)=-(md-1)*ddy proj_args(3)=ddx proj_args(4)=ddy endif endif if(j3.eq.0) then C Vis5D accept only 2D fileds so in 2D create two equal surfaces C with very small (almost unvisible) distace in Y direction (or X C direction if the surfaces are rotated) - usually dx is efficient proj_args(1)=0. proj_args(2)=0. ! (nn1-1)*ddx proj_args(3)=ddx proj_args(4)=ddx endif endif if(projection.eq.1) then ! Cylindrical equidistant C This is the rectangular latitude/longitude coordinate system. C latitude increases to the North (upward in the graphical display) C longitude increases to the West (leftward in the graphical display; positive west latitude). C C proj_args(1) = NorthBound: Northern boundary of 3-D box in deg of latitude [-90S,90N] C proj_args(1) = WestBound : Western boundary of 3-D box in deg of longitude [-180E,180W] C proj_args(1) = RowInc : Increment between grid rows in deg of latitude [> 0] C proj_args(1) = ColInc : Increment between grid columns in deg of longitude [> 0] ! Torino orography between 7E-9E 44N-46N, iconv must be =1 ! ! proj_args(1)= 46. ! proj_args(2)=-7. ! proj_args(3)=(9.-7.)/float(nd-1) ! proj_args(4)=(46-44.)/float(md-1) ! ! Oklahoma City ! ! proj_args(1)=35.5 ! 35.4719 ! proj_args(2)=97.5 ! 97.5221 ! proj_args(3)=0.000045 ! proj_args(4)=0.000048 proj_args(1)=rlatc proj_args(2)=rlonc*(-1.) proj_args(3)=dlatc proj_args(4)=dlonc endif if(projection.eq.2) then ! Lambert conformal/Polar Stereo C This is a conic projection defined by the following six parameters. C C Lat1, Lat2: First and second standard latitudes in the range [-90S,90N]. C Define where the imaginary cone intersects the sphere of the Earth. C Must have the same sign, Lat1 must be greater than or equal to Lat2. C PoleRow, PoleCol: indicate the position of the north or south pole with respect to C 3-D grid coordinate system. These values may be outside the 3-D grid. C If Lat1 and Lat2 >0, north pole is assumed, else, south pole is assumed. C CentLon: Central longitude: indicates which longitude is parallel to 3-D grid columns. C ColInc: Increment between grid columns at the central longit and standard latit [km] C This parameter controls the scale of the projection. endif if(projection.eq.3) then ! Rotated equidistant C An aximuthal stereographic projection defined by five parameters: C C CentLat, CentLon: Latitude and longitude of the center of projection. C The apex of the imaginary cone will be over this coordinate. C CentRow, CentCol: Row and column of the center of projection. C The grid row and column indicated will be at center of the projection. C These values may be outside the 3-D box. C ColInc: Increment (spacing) between grid columns in km at center of the projection. C This parameter controls the scale of the projection. endif c--------------------------------------------------------- cvertical coordinate system c------------------------- vertical=2 if(vertical.eq.0) then ! Equally spaced, generic units vert_args(1)=0. vert_args(2)=ast*dz endif if(vertical.eq.1) then ! Equally spaced, kilometers zlam=1000. vert_args(1)=0. vert_args(2)=ast*dz/zlam endif if(vertical.eq.2) then ! Unequally spaced, kilometers C This is a linear vertical coordinate system in which grid levels C can be unequally spaced. The coordinate system is defined by an C array of N height parameters where N is the number of levels in C the 3-D grids. If the number of grid levels is different for each C variable, N is the maximum number of grid levels. C C Height(1): Height of first (bottom) grid level in km C Height(2): Height of second grid level in km C ... ... C Height(N): Height of Nth (top) grid level in km C C Note: Note that the Height values must increase with N. C C Height(1) = 0.0 C Height(2) = 0.1 C Height(3) = 0.2 C Height(4) = 0.3 C Height(5) = 0.4 C Height(6) = 0.6 C Height(7) = 0.8 C Height(8) = 1.0 C Height(9) = 1.3 C Height(10) = 1.6 C C It is also possible to display the vertical axis on a logarithmic C scale. This is done with the -log command line option when you C start vis5d. In this case, the vertical axis is logarithmic C with respect to height but linear with respect to pressure. The C relationship between height (H) and pressure (P) is: C C P = 1012.5 * exp[ H / -7.2 ] C H = -7.2 * Ln[ P / 1012.5 ] C C The constants 1012.5 and -7.2 are just defaults which can C be overriden when you specify the -log option. do k=1,l vert_args(k)=zstr(k) enddo endif if(vertical.eq.3) then ! Unequally spaced, milibars C This is a linear vertical coordinate system in which grid levels can C be unequally spaced. The coordinate system is defined by an array C of N pressure parameters where N is the number of levels in the 3-D C grids. If the number of grid levels is different for each variable, C N is the maximum number of grid levels. C C Pressure(1): Pressure of first (bottom) grid level in km C Pressure(2): Pressure of second grid level in km C ... ... C Pressure(N): Pressure of Nth (top) grid level in km C C Note: Note that the Pressure values must decrease with N. C C For the purposes of calculating wind trajectories, Vis5D assumes C the relationship between height (H) and pressure (P) is: C C P = 1012.5 * exp[ H / -7.2 ] C H = -7.2 * Ln[ P / 1012.5 ] endif c---------------------- create name of variable i=1 if(ibupl.eq.1) then varname(i)='bouyancy ' i=i+1 endif if(ithpl.eq.1) then varname(i)='T ' i=i+1 endif if(iprpl.eq.1) then varname(i)='p_rho' i=i+1 endif if(iuvsf.eq.0) then if(iuvpl.eq.1) then varname(i)='U' i=i+1 endif if(ivvpl.eq.1) then varname(i)='V' i=i+1 endif else if(iuvpl.eq.1) then varname(i)='V' i=i+1 endif if(ivvpl.eq.1) then varname(i)='U' i=i+1 endif endif if(iwvpl.eq.1) then varname(i)='W' i=i+1 endif if(ioxpl.eq.1) then varname(i)='ox' i=i+1 endif if(ioypl.eq.1) then varname(i)='oy' i=i+1 endif if(iozpl.eq.1) then varname(i)='oz' i=i+1 endif if(idvpl.eq.1) then varname(i)='divergence' i=i+1 endif if(iqvpl.eq.1) then varname(i)='Q_v' i=i+1 endif if(iqcpl.eq.1) then varname(i)='Q_c' i=i+1 endif if(iqrpl.eq.1) then varname(i)='Q_r' i=i+1 endif if(iqial.eq.1) then varname(i)='ice_A' i=i+1 endif if(iqibl.eq.1) then varname(i)='ice_B' i=i+1 endif if(irhpl.eq.1) then varname(i)='R_h' i=i+1 endif if(ithvpl.eq.1) then varname(i)='th_virt' i=i+1 endif if(ikmpl.eq.1) then varname(i)='TKE' i=i+1 endif if(iripl.eq.1) then varname(i)='R_i' i=i+1 endif if((i-1).ne.INVARS) 1 print *,'NUMBER OF FILES:',i,' INVAR:',INVARS c-------------------------------------------------------------- c Create the v5d file. c------------------------- if(mype.eq.0) then print *,'v5dcreate: outname: ', outname print *,'v5dcreate: numtimes:', numtimes print *,'v5dcreate: numvars :', numvars print *,'v5dcreate: nr :', nr print *,'v5dcreate: nc :', nc print *,'v5dcreate: nl :', nl print *,'v5dcreate: varname :', varname print *,'v5dcreate: times :', times print *,'v5dcreate: dates :', dates print *,'v5dcreate: compress:', compressmode print *,'v5dcreate: project :', projection print *,'v5dcreate: proj_arg:', proj_args(1:4) print *,'v5dcreate: vertical:', vertical print *,'v5dcreate: vert_arg:', vert_args(1:2) no = v5dcreate( outname, numtimes, numvars, nr, nc, nl, * varname, times, dates, compressmode, * projection, proj_args, vertical, vert_args ) if (no .eq. 0) then print *,'CREATE OF THE OUPUT FIELDS is FAILED' else print *,'CREATE OF THE OUPUT FIELDS is DONE' endif endif c----------------------------------------------------------------- c YOU MAY CALL v5dsetlowlev OR v5dsetunits HERE. SEE README FILE. c----------------------- maxnl = nl(1) do i=1,numvars if (nl(i) .gt. maxnl) then maxnl = nl(i) endif enddo ! if(mype.eq.0) then ! do i=1,numvars ! if(ibupl .eq.1) call v5dsetunits(i, " " ) ! if(ithpl .eq.1) call v5dsetunits(i, "K" ) ! if(iprpl .eq.1) call v5dsetunits(i, "bar/dt" ) ! if(iuvpl .eq.1) call v5dsetunits(i, "m/s" ) ! if(ivvpl .eq.1) call v5dsetunits(i, "m/s" ) ! if(iwvpl .eq.1) call v5dsetunits(i, "m/s" ) ! if(ioxpl .eq.1) call v5dsetunits(i, "m/s" ) ! if(ioypl .eq.1) call v5dsetunits(i, "m/s" ) ! if(iozpl .eq.1) call v5dsetunits(i, "m/s" ) ! if(idvpl .eq.1) call v5dsetunits(i, " " ) ! if(iqvpl .eq.1) call v5dsetunits(i, "g/kg" ) ! if(iqcpl .eq.1) call v5dsetunits(i, "g/kg" ) ! if(iqrpl .eq.1) call v5dsetunits(i, "g/kg" ) ! if(iqial .eq.1) call v5dsetunits(i, "g/kg" ) ! if(iqibl .eq.1) call v5dsetunits(i, "g/kg" ) ! if(irhpl .eq.1) call v5dsetunits(i, " " ) ! if(ithvpl.eq.1) call v5dsetunits(i, "K" ) ! if(ikmpl .eq.1) call v5dsetunits(i, " " ) ! if(iripl .eq.1) call v5dsetunits(i, " " ) ! enddo ! endif c-------------------------------- check if compute topografy needed sumtopo=0. do j=1,mp do i=1,np sumtopo=sumtopo+zs(i,j) enddo enddo sumtopo=globsum(sumtopo,1,1,1,1,1,1,1,1,1,1,1,1) itrans=0 if(sumtopo.gt.1.) itrans=1 ! if(mype.eq.0) print *,'sumtopo:',sumtopo,itrans c-------------------------------------------------------------- c write the 3-D grid to the v5d file c-------------------------------------------------------------- do it=1,numtimes iv=1 c------------------------ c B o u y a n c y c------------------------ if(ibupl.eq.1) then do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)= (th(i,j,k)+the(i,j,k))/the(i,j,k)-1. enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Potential temperature c------------------------ if(ithpl.eq.1) then do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)=th(i,j,k)+the(i,j,k) enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Presure perturbation c------------------------ if(iprpl.eq.1) then do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)= p(i,j,k)*rho(i,j,k)*2.*dti enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c U - v e l o c i t y c------------------------ if(iuvpl.eq.1) then if(itrans.eq.1) then call transform(u,fxyz0,100) ! call transform(u,fxyz0,2) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(u ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c V - v e l o c i t y c------------------------ if(ivvpl.eq.1) then if(itrans.eq.1) then call transform(v,fxyz0,100) ! call transform(v,fxyz0,3) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(v ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c W - v e l o c i t y c------------------------ if(iwvpl.eq.1) then if(itrans.eq.1) then call transform(w,fxyz0,100) ! call transform(w,fxyz0,4) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(w ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Omega X - v e l o c i t y c------------------------ if(ioxpl.eq.1) then if(itrans.eq.1) then call transform(ox,fxyz0,100) ! call transform(ox,fxyz0,42) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(ox ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Omega Y - v e l o c i t y c------------------------ if(ioypl.eq.1) then if(itrans.eq.1) then call transform(oy,fxyz0,100) ! call transform(oy,fxyz0,43) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(oy ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Omega Z - v e l o c i t y c------------------------ if(iozpl.eq.1) then if(itrans.eq.1) then call transform(oz,fxyz0,100) ! call transform(oz,fxyz0,41) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(oz ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c D i v e r g e n c e c------------------------ if(idvpl.eq.1) then do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)= div(i,j,k)*dt enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c-------------------------- c Water vapour mixong ratio c-------------------------- if(iqvpl.eq.1) then do k=1,lms do j=1,mmsp do i=1,nmsp fxyz(i,j,k)=qv(i,j,k)*1.e3 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Cloud water mixing ratio c------------------------ if(iqcpl.eq.1) then do k=1,lms do j=1,mmsp do i=1,nmsp fxyz(i,j,k)=qc(i,j,k)*1.e3 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------- c Rain water mixing ratio c------------------------- if(iqrpl.eq.1) then do k=1,lms do j=1,mmsp do i=1,nmsp fxyz(i,j,k)=qr(i,j,k)*1.e3 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------- c Ice A mixing ratio c------------------------- if(iqial.eq.1) then do k=1,lic do j=1,micp do i=1,nicp fxyz(i,j,k)=qia(i,j,k)*1.e3 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------- c Ice B mixing ratio c------------------------- if(iqibl.eq.1) then do k=1,lic do j=1,micp do i=1,nicp fxyz(i,j,k)=qib(i,j,k)*1.e3 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c Relative - humidity c------------------------ if(irhpl.eq.1) then do k=1,lms do j=1,mmsp do i=1,nmsp fxyz(i,j,k)=rhf(i,j,k) enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c T h e t a - virtual c------------------------ if(ithvpl.eq.1) then epsb=rv/rg-1. if(moist.eq.1) then do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)=th(i,j,k)+epsb*qv(i,j,k)*th0(i,j,k) enddo enddo enddo else do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)=th(i,j,k) enddo enddo enddo endif if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c T K E c------------------------ if(ikmpl.eq.1) then ccc if(j3.eq.1) deltl=(dx*dy*dz)**(1./3.) if(j3.eq.1) deltl=(dx+dy+dz)/3. if(j3.eq.0) deltl=sqrt(dx*dz) deltc=sqrt(dx**2+j3*dy**2+dz**2) do k=1,lkv do j=1,mkvp do i=1,nkvp coef=cm*amin1(cL*amax1(float(k-1),1.)*dz/gi(i,j),deltl) fxyz(i,j,k)=coef*tke(i,j,k)*dt/deltc**2 ! fxyz(i,j,k)=tke(i,j,k)**2 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(fxyz,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c R i c h a r d s o n c------------------------ if(iripl.eq.1) then if(itrans.eq.1) then call transform(ri,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,varname(iv)) else call v5dwrite0(ri ,iconv,iv,it,varname(iv)) endif iv=iv+1 endif c------------------------ c E n d c------------------------ enddo c------------------------------------------------------------- c close the v5d file and exit c-------------------------------- if(mype.eq.0) then no = v5dclose() if (no .eq. 0) then print *,'V5D_FILE NOT SAVED __ SAVING FAILED' endif endif return end subroutine v5dwrite0(f,iconv0,IV,IT,varname) include 'param.nml' include 'msg.inc' include 'param.v5d' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension f(1-ih:np+ih, 1-ih:mp+ih, l) integer v5dwrite character*10 varname #if (PARALLEL == 0) real*4 fxyz(np,mp,l) real*4 fyxz(mp,np,l) if(iconv.eq.1) then do k=1,l do j=1,mp do i=1,np fyxz(j,i,k)=f(i,j,k) enddo enddo enddo ierr = v5dwrite( IT, IV, fyxz ) else if(iconv.eq.-1) then do k=1,l do j=1,mp do i=1,np fyxz(m-j+1,i,k)=f(i,j,k) enddo enddo enddo ierr = v5dwrite( IT, IV, fyxz ) do k=1,l do j=1,mp do i=1,np fxyz(i,j,k)=f(i,j,k) enddo enddo enddo ierr = v5dwrite( IT, IV, fxyz ) endif if (ierr.eq.0) then print *,'WRITE ',varname,' FAILED' endif #else call mybarrier() if(mype.eq.0) then if(iconv.eq.0) then call v5dcollect0(f,iconv0,IV,IT,nd,md,varname) else call v5dcollect0(f,iconv0,IV,IT,md,nd,varname) endif else call v5dcollectk(f) endif #endif return end #if (PARALLEL > 0) subroutine v5dcollect0(datarr,iconv0,IV,IT,n1,n2,varname) c c This subroutine writes the data to the history file. c include 'param.nml' include 'msg.inc' include 'param.v5d' #include "msg.lnk" #include "msg.lnp" ! common/blocktempv/tmparray(np,mp,l) dimension tmparray(np,mp,ld) dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) real*4 temp(n1,n2,ld) character*10 varname iproc=0 npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 ! do k=1,ld ! do j=1,n2 ! do i=1,n1 ! temp(i,j,k)=-9.9999999999999 ! end do ! end do ! end do if(iconv.eq.0) then do k=ld1,ld2 do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) . temp(ia-nd1+1,ja-md1+1,k-ld1+1)=datarr(i,j,k) end do end do end do else if (iconv.eq. 1) then do k=ld1,ld2 do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) . temp(ja-md1+1,ia-nd1+1,k-ld1+1)=datarr(i,j,k) end do end do end do else if (iconv.eq.-1) then do k=ld1,ld2 do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) then temp(md2-(ja-md1+1)+1,ia-nd1+1,k-ld1+1)=datarr(i,j,k) endif end do end do end do endif #if (PARALLEL > 0) nmlp=np*mp*ld do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 2) fsg=float(iproc) call MPI_Send(fsg,1,DC_TYPE,iproc,iproc,MPI_COMM_EULAG,ierr) call MPI_Recv(tmparray, nmlp, DC_TYPE, iproc, 1000+iproc, . MPI_COMM_EULAG, status, ierr) #endif npos1 = mod((iproc+nprocx), nprocx) + 1 mpos1 = iproc/nprocx + 1 if(iconv.eq.0) then do k=1,ld do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) . temp(ia-nd1+1,ja-md1+1,k)=tmparray(i,j,k) end do end do end do else if (iconv.eq. 1) then do k=1,ld do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) . temp(ja-md1+1,ia-nd1+1,k)=tmparray(i,j,k) end do end do end do else if (iconv.eq.-1) then do k=1,ld do j=1,mp do i=1,np ia=(npos1-1)*np + i ja=(mpos1-1)*mp + j if(ia.ge.nd1.and.ja.ge.md1.and. . ia.le.nd2.and.ja.le.md2) then temp(md2-(ja-md1+1)+1,ia-nd1+1,k)=tmparray(i,j,k) endif end do end do end do endif end do #endif fsum=0. fmin=1.e40 fmax=-1.e40 do k=1,ld do j=1,n2 do i=1,n1 fsum=fsum+temp(i,j,k) fval=temp(i,j,k) fmin=min(fmin,fval) fmax=max(fmax,fval) end do end do end do fsum=fsum/float(n1*n2*ld) ierr = v5dwrite( IT, IV, temp ) if (ierr.ne.0) then print *,'WRITE ',varname,' FAILED ',ierr,fmin,fmax,fsum else print *,'WRITE ',varname,' SUCCES ',ierr,fmin,fmax,fsum endif return end subroutine v5dcollectk(datarr) c c This subroutine send data to PE0 to write them to the history file c include 'param.nml' include 'msg.inc' include 'param.v5d' #include "msg.lnk" #include "msg.lnp" ! common/blocktempv/ tmparray(np,mp,l) dimension tmparray(np,mp,ld) dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) nmlp=np*mp*ld ilim=np jlim=mp do k=ld1,ld2 do j=1,jlim do i=1,ilim tmparray(i,j,k-ld1+1)=datarr(i,j,k) end do end do end do #if (PARALLEL == 2) call MPI_Recv(fsg,1,DC_TYPE,0,mype,MPI_COMM_EULAG,status,ierr) call MPI_Send(tmparray, nmlp, DC_TYPE, 0, 1000+mype, . MPI_COMM_EULAG, ierr) #endif return end #endif #endif C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine transform(f,ff,iflg) include 'param.nml' include 'msg.inc' parameter(n1=np,n2=mp,n3=l) dimension f(1-ih:np+ih, 1-ih:mp+ih, l), . ff(1-ih:np+ih, 1-ih:mp+ih, l), . zrcp(1-ih:np+ih, 1-ih:mp+ih, l) dimension z(n3) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/gora/ xml1,yml1,amp,xml0,yml0,angle common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . zh(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmus(l), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih), . h13(1-ih:np+ih,1-ih:mp+ih), . h23(1-ih:np+ih,1-ih:mp+ih) data igros/1/ if(iflg.eq.100) then tlo=1.0E35 else if((iflg.eq.2).or.(iflg.eq.3).or.(iflg.eq.4))then ! u,v,w tlo=0. else if((iflg.eq.41).or.(iflg.eq.42).or.(iflg.eq.43))then ! ox,oy,oz tlo=0. else if((iflg.eq.5).or.(iflg.eq.6))then tlo=-999999.0000 else call continl(f,cmn,cmx,n1,n2,n3) tlo=cmn-(cmx-cmn)/255 endif do 12 k=1,l 12 z(k)=(k-1)*dz c if(igros.eq.0) then c do 1 i=1,np c do 1 j=1,mp c do 1 k=1,l c 1 zrcp(i,j,k)=z(k)*((z(l)-zs(i,j))/z(l))+zs(i,j) c do 13 j=1,mp c do 13 i=1,np c zzs=zs(i,j) c do 13 kk=1,l c zzr=z(kk) c if(zzr.lt.zzs) then c ff(i,j,kk)=tlo c else c kkk=kk c cmin= 1.e15 c do 14 k0=1,l c roznic=abs(zzr-zrcp(i,j,k0)) c cmin=amin1(cmin,roznic) c 14 if(cmin.eq.roznic) kkk=k0 c ff(i,j,kk)=f(i,j,kkk) c endif c 13 continue c endif if(igros.eq.1) then do j=1,mp do i=1,np zzs=zs(i,j) do kk=1,l zzr=z(kk) if(zzr.ge.zzs) then kkk=int((zzr-zs(i,j))*(l-1)/((l-1)*dz-zs(i,j))+0.5)+1 ff(i,j,kk)=f(i,j,kkk) else ff(i,j,kk)=tlo endif enddo enddo enddo endif itest=1 if(itest.eq.1) then fmin= 1.e36 fmax=-1.e36 do j=1,mp do i=1,np do k=1,l fmin=min(fmin, f(i,j,k)) fmax=max(fmax, f(i,j,k)) enddo enddo enddo fmin=globmin(fmin,1,1,1,1,1,1,1,1,1,1,1,1) fmax=globmax(fmax,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) print *,'fminmax2:',fmin,fmax,fsum endif itest=1 if(itest.eq.1) then fmin= 1.e36 fmax=-1.e36 fsum=0. rmin= 1.e36 rmax=-1.e36 rsum=0. do j=1,mp do i=1,np do k=1,l fmin=min(fmin, f(i,j,k)) fmax=max(fmax, f(i,j,k)) fsum=fsum + f(i,j,k) rmin=min(rmin,ff(i,j,k)) rmax=max(rmax,min(1.0E35,ff(i,j,k))) rsum=rsum + ff(i,j,k) enddo enddo enddo fmin=globmin(fmin,1,1,1,1,1,1,1,1,1,1,1,1) fmax=globmax(fmax,1,1,1,1,1,1,1,1,1,1,1,1) fsum=globsum(fsum,1,1,1,1,1,1,1,1,1,1,1,1) rmin=globmin(rmin,1,1,1,1,1,1,1,1,1,1,1,1) rmax=globmax(rmax,1,1,1,1,1,1,1,1,1,1,1,1) rsum=globsum(rsum,1,1,1,1,1,1,1,1,1,1,1,1) if(mype.eq.0) print *,'fminmaxf:',fmin,fmax,fsum if(mype.eq.0) print *,'fminmaxr:',rmin,rmax,rsum endif return end subroutine continl(f,cmn,cmx,n1,n2,n3) include 'param.nml' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l) cmx=-1.e10 cmn= 1.e10 do k=1,n3 do j=1,n2 do i=1,n1 cmx=amax1(cmx,f(i,j,k)) cmn=amin1(cmn,f(i,j,k)) enddo enddo enddo return end #if (GKS == 1) c include '/home/rd/naw/Model/conrec_UB.gks' c include '/home/rd/naw/Model/velvct_UB.gks' include 'conrec.gks' #include "velvct.gks" #if (SPCTPL == 1) cinclude(/users/andii/model/graphics/cfftpack.f) include 'cfftpack.f' #endif #if (COLORPL == 1) cinclude(/users/andii/model/graphics/colorpl.gks) include 'colorpl.gks' #endif #endif