############################################################################### # # # /_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/# # / / # # / _/_/_/_/_/ _/_/ _/_/ _/_/ _/_/_/_/ _/_/_/_/ / # # / _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/ / # # / _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ / # # / _/_/_/_/ _/_/ _/_/ _/_/ _/_/_/_/_/_/ _/_/ _/_/_/ / # # / _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ / # # / _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ / # # / _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ _/_/ / # # / _/_/_/_/_/ _/_/_/_/ _/_/_/_/_/ _/_/ _/_/ _/_/_/_/ / # # / / # #/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/ # # # ############################################################################## # Smolarkiewicz Piotr | Mesoscale and Microscale Meteorology Division (MMM) # # Grabowski Wojciech | National Center for Atmospheric Research (NCAR) # # Wyszogrodzki Andrzej | PO Box 3000, Boulder, Colorado 80307-3000, USA. # # Anderson Bill | e-mail: smolar@ncar.ucar.edu # # | phone: (303)-497-8972 # # | fax: (303)-497-8181 # # ### IMPLEMENTED FAST STEVEN THOMAS TRANSPONSE # ############################################################################# # # EXECUTES JOB ON: Cray T3D,T3E,PVP(vector/parallel); SGI O2K; # # HP/Convex Exemplar 2K # # Fujitsu VPP700, NEC SX-4B/2A # # WORKSTATION: SGI,SUN,DEC Alpha,PC Linux # ############################################################################## # Fujitsu VPP700 (at ECMWF) # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # #define WORKS 1 #QSUB -s /bin/csh -eo -q normal ############################################################################## # C R A Y -- P V P (ouray,paiute) # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ##QSUB -s /bin/csh -la 1cpus -eo -q econ -lt 88000 -lT 88200 -lM 45Mw ############################################################################## # C R A Y -- T 3 D (antero) # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ##QSUB -q mpp ##QSUB -lT 28800 ##QSUB -lM 8Mw ##QSUB -l mpp_p=4 ##QSUB -l mpp_t=480:00 ############################################################################## # C R A Y -- T 3 E (mcurie.nersc.gov;pierre.nersc.gov) # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ##QSUB -lT 1900 ##QSUB -lM 8Mw ##QSUB -l mpp_p=64 ##QSUB -l mpp_t=30:00 ############################################################################## # S G I - O R I G I N 2 0 0 0 (ute) # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Pipe Tot. Limits # # Queue CPU Run WallClock Time of Day Memory # # Name # # ------ --- --- -------- ----------------- -------- # # ia 16 -- 30 min always .25 GW # # share_16 16 1 6 hour 08:00-18:00 (MDT) .25 GW # # ded_16 16 1 6 hour 08:00-18:00 (MDT) .25 GW # # ded_32 32 1 6 hour 08:00-18:00 (MDT) .50 GW # # ded_64 64 1 6 hour 18:00-08:00 (MDT) 1.0 GW # # res_64 64 1 6 hour reserved for specific project 1.0 GW # # spec 128 1 unlimit by special perm 1.9 GW # # Access to the whole machine can be scheduled with the Supercomputer # # Systems Group (ssg@ncar). We provide such dedicated access between # # 0600-0830 Mon-Thu and 0600-1400 Fridays (holidays excluded). # # For more details, "www.scd.ucar.edu/docs/ute/queues.html#queues" # # or contact SCD Consulting office (303) 497-1278 or "consult1@ucar.edu" # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # -lmpp_p = npes + 4 # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ##QSUB -q spec -lM 256Mw -eo -l mpp_p=132 ##QSUB -q ded_32 -lM 256Mw -eo -l mpp_p=36 ############################################################################## # H P / C O N V E X (sioux) # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # Pipe Tot. Limits # # Queue CPU Run WallClock Time of Day Complex Memory # # Name # # ------ --- --- -------- ----------------- ------------ --------- # # -q spec 64 1 unlimit Aranged with SCD sc64(complex) 6.9 GMax # # -q nd 64 1 unlimit Aranged with SCD sc64(complex) 6.9 GMax # # -q ded_32 32 1 6 hour 7 x 24 sc32(complex) 3.6 GMax # # -q ded_16 16 1 6 hour 7 x 24 sc16(complex) 1.7 G # # -q share 16 1 6 hour Everyday 2000-0800 system(complex) 1.6 G # # Interactive 1-16 256 unlimit 7 x 24 1.6 G # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ##@$-q ded_32 -lt 10000 -lT 10300 -lM 256Mw -eo ############################################################################## # N E C -- P V P (mistral.icm.edu.pl) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ##@$ -q sx4_256mb_24h ##sx4_512mb_120h;sx4_512mb_24h;sx4_256mb_24h ##sx4_256mb_12h ;sx4_1gb_24h ############################################################################## # WORKSTATION SGI,SUN,DEC Alpha,PC Linux # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # You need UNIX (Linux) operational system with csh # # Check which FORTRAN compiler is in your system and set correct options # # Make "csh job.name" # ############################################################################## ############################################################################## #### S E T csh E N V I R O N M E N T F O R Y O U R J O B #### ############################################################################## # Type executing machine : # # # # MACHINE PVP - executes on Crays PVP (Y-MP,C90,J90 etc.) # # MACHINE T3D - executes on Cray T3D # # MACHINE T3E - executes on Cray T3E # # MACHINE VP7 - executes on Fujitsu Vpp 700 # # MACHINE NEC - executes on NEC SX-4B/2A # # MACHINE O2K - executes on SGI Origin 2000 # # MACHINE HP - executes on HP/Convex Exemplar 2000 # # MACHINE WRK - executes on workstation SGI,SUN,DEC Alpha,PC Linux # # MACHINE IBM - executes on IBM # -------------------------------------------------------------------------- # # Exchange data in subroutines: update/2/lag/lr/bt; glob/sum/max/min # # # # MESSG ONE - One processor in the spirit of message passing - All MACHINEs # # MESSG MPI - Message Passing Interface - MPI (Cray PVP,T3D,T3E;HP;SGI O2KIBM) # # MESSG SCH - Cray's Shared Memory routines - SHMEM (Cray T3D,T3E;SGI O2K) # # # # -------------------------------------------------------------------------- # # Type number of executing processors for your job : # # # # NPE N - Nr of processors for message passing code # # NCPUS N - Nr of processors for multitasking (NPE 1,MACHINE PVP; O2K; HP)# # -------------------------------------------------------------------------- # # Type lenght of floating point (real) word : # # On Cray PVP,MPP it is only 8 byte long folating point word # # # # WORD 4 - on SGI O2K, HP, workstations - 4 byte long floating point # # WORD 8 - on SGI O2K, HP, workstations - 8 byte long floating point # ############################################################################## # Postprocessing analysis: # # # # ANALIZ 0 - Run full job # # ANALIZ 1 - Analysis run only; Requires history tape # # -------------------------------------------------------------------------- # # Graphics Outputs (when nonparallel options are present ONE = 1) # # # # NCARG 1 - Plot with Ncar Graphics output - 0 - no plot # # COLOR 1 - Color Plot with Ncar Graphics output - 0 - black/white plot # # TURBL 1 - Turbulence Statistic (Ncar Graphics) - 0 - no plot # # SPCTR 1 - Spectra Plot (Ncar Graphics) - 0 - no plot # # VORTX 1 - Votrex Plot (Ncar Graphics) - 0 - no plot # # VIS5D 1 - Output with format for vis5d program - 0 - no plot # ############################################################################## setenv MACHINE WRK setenv MESSG ONE setenv NPE 1 setenv NCPUS 1 setenv WORD 4 setenv ANALIZ 0 setenv NCARG 0 setenv PLOTR 0 setenv COLOR 0 setenv SPCTR 0 setenv TURBL 0 setenv VORTX 0 setenv VIS5D 0 #setenv JNAME eulag_mpiF_16Y.nod #setenv JNAMED eulag_mpiF16Y.nod #setenv TMPDIR $SCRATCH/$JNAMED if ($MACHINE == VP7) then setenv VPP_Q vpp700.normal setenv VPP_t 950 setenv VPP_T 980 setenv VPP_M 256Mb setenv VPPTMPDIR /vpp700/rdx_data0c/andii/$JNAMED setenv OLDTAPE 0 setenv TOPOTAPE 0 endif setenv PERFM 0 ############################################################################# #### Change working directory #### ############################################################################# #WORKDIRSTART setenv WORKDIR $PWD #WORKDIREND if(! -d $WORKDIR) then mkdir -p -m 777 $WORKDIR || true endif cd $WORKDIR ############################################################################# #### Assign correct data format on Crays #### ############################################################################# #assign -b 96 -a itape fort.9 #assign -b 96 -a jtape fort.10 #When you want read from (write to) HP (IEEE) format on Crays MPP #Dont forget change ioptw=0,ioptr=0 #assign -R fort.9;assign -F f77 fort.9 #assign -R fort.10;assign -F f77 fort.10 #When you want read from (write to) HP (IEEE) format on Crays PVP #Dont forget change ioptw=0,ioptr=0 #assign -R fort.9;assign -F f77 -N ieee_64 fort.9 #assign -R fort.10;assign -F f77 -N ieee_64 fort.10 ############################################################################# #### Read data from Mass Storage System #### ############################################################################# #msread fort.10 /ANDII/HPTAUM800b/ftn10 #cp fort.9 fort.10 #HP fortran files have names "ftn10", ftn09" - oposite to #Cray fortran file names "fort.10", "fort.9" ############################################################################# #### #### #### S T A N D A R D D E F I N I T I O N S #### #### #### ############################################################################# goto DEFAULT_SETUP RETURN_FROM_DEFAULT: rm -f param.icw rm -f param.ior rm -f param.misc rm -f param.nml rm -f msg.inc rm -f msg.lnk rm -f a.out rm -f param.sds rm -f ztr.dat rm -f zrh.dat rm -f zuv.dat cat > param.sds << '\eof' c super droplets (SDs): only in cloudy volumes... c nppg - the number of SDs per gridbox c parameter(nppg=4) parameter(nppg=20) parameter(npp=(n-1)*(m-1)*(l-1)*nppg) '\eof' cat > aerosol1size.inc << '\eof' PARAMETER(nca=1,ncap=nca+1) common /drops/ conc(nca),qcc(nca),radc(nca) REAL rad0,mas0,mas0s,rho_a COMMON /aerosol1/ rad0(nca),mas0(nca),mas0s(ncap),rho_a COMMON /aerosol2/ iter(nca,nca),frac(nca,nca) COMMON /aerosol3/ s_activ(nca),r_activ(nca) common /chemistry/ rho_w,amol_w,rho_s,amol_s,vanhof common /kinetic/ alpha_c,alpha_t,delta_v,delta_t '\eof' cat > param.icw << '\eof' c +++param.icw+++ controls treatement of lateral open boundaries c icw=0 "overspecified" c icw=1 "correct" parameter (icw=1) '\eof' cat > param.ior << '\eof' c +++param.ior+++ c--> ior=order of SL remapping accuracy/2;only even order schemes are considered parameter (ior=1) c--> ihlag is a SL halo size; ihlag .ge. max(C, ior + 1, 3) parameter (ihlag=3) '\eof' cat > param.misc << '\eof' c +++param.misc+++ parameter (ivs0=0) ! Viscous/Inviscid model parameter (itke0=1,itke=ivs0*itke0) ! Smagorinsky/TKE SGS model parameter(nke=(n-1)*itke+1,mke=(m-1)*itke+1,lke=(l-2)*itke+2) parameter(nkv=(n-1)*ivs0+1,mkv=(m-1)*ivs0+1,lkv=(l-2)*ivs0+2) c--> itraj0=0 adams-bashf., itraj0=1 runge-kutta parameter(itraj=0) parameter(nts=(n-1)*itraj+1,mts=(m-1)*itraj+1,lts=(l-1)*itraj+1) '\eof' cat > param.rad << '\eof' integer nrad,mrad,lrad,np,mp,nprocx,nprocy parameter (nrad=64,mrad=64,lrad=100) ! must be the same as in param.nml '\eof' cat > param.nml << '\eof' c +++param.nml+++ c--> +++ Dont Forget Set Correct Values for "nth" and "nt" +++ c startdim parameter (n=64,m=64,l=64,nth=9600) c enddim parameter (lagr=0,ieul=1-lagr) ! Lagrangian/Eulerian model c--> moist=0, ice=0, iceab=0 - dry thermodynamics c--> MOISTMOD == 1 - simple parametrization c--> moist=1, ice=0, iceab=0 - moist warm-rain bulk thermodynamics c--> moist=1, ice=1, iceab=0 - moist warm-rain+ice bulk thermodynamcs c--> MOISTMOD == 2 - advanced parametrization, ice A, ice B c--> moist=1, ice=0, iceab=0 - moist warm-rain bulk thermodynamics c--> moist=1, ice=0, iceab=1 - moist warm-rain+ice bulk thermodynamcs parameter (moist=1,ice=0,iceab=0) parameter(nms=(n-1)*moist+1,mms=(m-1)*moist+1,lms=(l-1)*moist+1) parameter(nic=(n-1)*iceab+1,mic=(m-1)*iceab+1,lic=(l-1)*iceab+1) parameter (nv=n,mv=m,lv=l,itwo=0) parameter(impd=1) '\eof' if ($MACHINE == T3E || $MACHINE == T3D) then cat > msg.inc << '\eof' c +++msg.inc+++ intrinsic my_pe '\eof' else cat > msg.inc << '\eof' c +++msg.inc+++ '\eof' endif if ($NPE == 1) then cat >> msg.inc << '\eof' C DONT CHANGE THIS TWO VALUES ! parameter (nprocx=1, nprocy=1) '\eof' cat >> param.rad << '\eof' parameter (nprocx=1, nprocy=1) ! DONT CHANGE THIS TWO VALUES '\eof' else cat >> msg.inc << '\eof' C THIS VALUES YOU NEED CHANGE parameter (nprocx=11, nprocy=7) '\eof' cat >> param.rad << '\eof' parameter (nprocx=11, nprocy=7) ! CHANGE THIS VALUES '\eof' endif cat >> param.rad << '\eof' parameter (np=nrad/nprocx, mp=mrad/nprocy) '\eof' cat >> msg.inc << '\eof' c ih is halo width parameter (ih=3) c parameter (nproc=nprocx*nprocy) parameter (np=n/nprocx, mp=m/nprocy) c dimensions for moist msg arrays parameter (nmsp=np*moist + 1*(1-moist), . mmsp=mp*moist + 1*(1-moist)) c dimensions for ice A, ice B msg arrays parameter (nicp=np*iceab + 1*(1-iceab), . micp=mp*iceab + 1*(1-iceab)) c dimension for tke msg arrays parameter (nkep=np*itke + 1*(1-itke), . mkep=mp*itke + 1*(1-itke)) c dimension for tkv msg arrays parameter (nkvp=np*ivs0 + 1*(1-ivs0), . mkvp=mp*ivs0 + 1*(1-ivs0)) c dimension for traj msg arrays parameter (ntsp=np*itraj + 1*(1-itraj), . mtsp=mp*itraj + 1*(1-itraj)) integer middle,rightedge,leftedge,botedge,topedge,npos,mpos integer perightabove,perightbelow,peleftbelow,peleftabove integer peleft,peright,peabove,pebelow,mype common /msg/ middle,rightedge,leftedge,botedge,topedge,npos,mpos, . perightabove,perightbelow,peleftbelow,peleftabove, . peleft,peright,peabove,pebelow,mype,mysize '\eof' cat > msg.lnk << '\eof' #if (PARALLEL == 2) #if (HP > 0) include '/opt/mpi/include/mpif.h' #endif #if (CRAYT3D == 1) c include '/opt/ctl/mpt/mpt/include/mpif.h' include '/usr/local/MPI/t3d/include/mpif.h' #endif #if (CRAYT3E == 1) include '/opt/ctl/mpt/mpt/include/mpif.h' #endif #if (SGI_O2K > 0) include 'mpif.h' #endif #if (FUJI_VPP > 0) include 'mpif.h' #endif #if (IBM > 0) include 'mpif.h' #endif #if (CRAYPVP == 1) include '/opt/ctl/mpt/mpt/include/mpif.h' #endif integer status(MPI_STATUS_SIZE),size,rank,ierr * DC_TYPE : the data type of the data in communication (4 or 8 bytes) integer DC_TYPE common /t23comm/ $ dc_type #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) include '/usr/include/mpp/shmem.fh' #else include 'mpp/shmem.fh' #endif #endif '\eof' cat > msg.lnp << '\eof' #if (PARALLEL == 1) #if (SGI_O2K > 0) #if (PVM_IO == 1) include '/usr/array/PVM/include/fpvm3.h' #endif #else #if (PVM_IO == 1) include '/opt/ctl/mpt/mpt/include/fpvm3.h' #endif #endif #endif '\eof' ############################################################################# #### #### ## D O N T C H A N G E N O T H I N G A F T E R T H I S L I N E ## #### #### ############################################################################# # # # DEFAULT SETUP FOR SOME OPTIONS - DONT CHANGE NOTHING # # # ############################################################################# goto DEFAULT_SET_DONE DEFAULT_SETUP: if ($MACHINE == HP) then setenv MESSG MPI if ($WORD == 8) then setenv VIS5D 0 endif endif if ($MACHINE == PVP) then setenv WORD 8 endif if ($MACHINE == T3D) then setenv MESSG SCH setenv WORD 8 setenv NCARG 0 setenv VIS5D 0 endif if ($MACHINE == T3E) then setenv WORD 8 setenv NCARG 0 setenv VIS5D 0 endif if ($MACHINE == VP7) then setenv NCARG_VP7 0 setenv COLOR_VP7 0 setenv PLOTR_VP7 0 setenv SPCTR_VP7 0 setenv TURBL_VP7 0 setenv VORTX_VP7 0 setenv VIS5D_VP7 0 if ($NCARG == 1) then setenv NCARG_VP7 1 if ($COLOR == 1) then setenv COLOR_VP7 1 endif if ($PLOTR == 1) then setenv PLOTR_VP7 1 endif if ($SPCTR == 1) then setenv SPCTR_VP7 1 endif if ($TURBL == 1) then setenv TURBL_VP7 1 endif if ($VORTX == 1) then setenv VORTX_VP7 1 endif endif if ($VIS5D == 1) then setenv VIS5D_VP7 1 endif setenv NCARG 0 setenv COLOR 0 setenv PLOTR 0 setenv SPCTR 0 setenv TURBL 0 setenv VORTX 0 setenv VIS5D 0 endif if ($MACHINE == NEC) then setenv WORD 8 setenv NCARG 0 endif if ($MACHINE == O2K) then if ($MESSG == MPI) then setenv VIS5D 0 setenv NCARG 0 endif if ($MESSG == SCH) then setenv VIS5D 0 setenv NCARG 0 endif if ($WORD == 8) then setenv VIS5D 0 echo 'VIS5D dont work with double precision' endif if ($MESSG == ONE) then if ($NCARG > 0) then setenv WORD 4 endif endif endif if ($MACHINE == WRK) then setenv MESSG ONE setenv NPE 1 setenv NCPUS 1 if ($WORD == 8) then echo 'VIS5D dont work with double precision' echo 'NCARG dont work with double precision' setenv NCARG 0 setenv VIS5D 0 endif endif if ($NPE == 1) then setenv MESSG ONE endif if ($MESSG == ONE) then setenv NPE 1 else setenv NCARG 0 setenv PLOTR 0 setenv COLOR 0 setenv SPCTR 0 setenv TURBL 0 setenv VORTX 0 setenv VIS5D 0 endif if ($NCARG == 0) then setenv PLOTR 0 setenv COLOR 0 setenv SPCTR 0 setenv TURBL 0 setenv VORTX 0 endif if ($PLOTR == 0) then setenv SPCTR 0 endif goto RETURN_FROM_DEFAULT DEFAULT_SET_DONE: ############################################################################# # # # P R I N T O U T S O M E D E F A U L T O P T I O N S # # # ############################################################################# setenv cwd pwd echo XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX echo XXXXXX_WORKING_DIRECTORY_______XX $cwd echo XXXXXX_Executable_Machine______XX $MACHINE echo XXXXXX_Messages_protocol_______XX $MESSG if ($MACHINE == HP) then echo XXXXXX_Nr_multitask_processors_XX $NCPUS else if ($NCPUS > 1) then echo XXXXXX_Nr_multitask_processors_XX $NCPUS endif endif if ($NPE > 1) then echo XXXXXX_Number_MPP_processors___XX $NPE endif echo XXXXXX_Floating_Point_Word_____XX $WORD echo XXXXXX_Analize_run_from_tape___XX $ANALIZ echo XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX echo XXXXXX___NcarGraphics_Output___XX $NCARG if ($NCARG == 1) then echo XXXXXX_NcarGraphicsPlot________XX$PLOTR echo XXXXXX_NcarGraphicsColorPlot___XX $COLOR echo XXXXXX_NcarGraphicsColorPlot___XX$COLOR echo XXXXXX_NcarGraphicsVorticity___XX$VORTX echo XXXXXX_NcarGraphicsTurbulStat__XX$TURBL echo XXXXXX_NcarGraphicsSpectral____XX$SPCTR endif echo XXXXXX_Vis5dGraphics_Output_is_XX$VIS5D echo XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ############################################################################# # # # DEFAULT SETUP FOR PRECOMPILER DIRECTIVES - DONT CHANGE NOTHING # # # ############################################################################# # PRECOMPILATOR 'PARALLEL' OPTION ## UPDATE's ## GLOB's ## I/O's # # PARALLEL 0 -- All machines (1 PE's) ## ---- ## ---- ## ---- # # PARALLEL 1 -- Cray T3D,T3E ## SHMEM ## SHMEM ## PVM # # PARALLEL 2 -- Cray PVP,T3E;HP;FUJI;SGI ## MPI ## MPI ## MPI # ############################################################################# rm -f src.F touch src.F ########################## if ($MESSG == SCH) then cat >> src.F << '\eof' #define PARALLEL 1 #define PVM_IO 0 '\eof' endif if ($MESSG == MPI) then cat >> src.F << '\eof' #define PARALLEL 2 #define PVM_IO 0 '\eof' endif if ($MESSG == ONE) then cat >> src.F << '\eof' #define PARALLEL 0 #define PVM_IO 0 '\eof' endif ######################### ### ANALYSING OLD TAPE ## ######################### if ($ANALIZ == 2) then cat >> src.F << '\eof' #define ANALIZE 2 '\eof' else if ($ANALIZ == 1) then cat >> src.F << '\eof' #define ANALIZE 1 '\eof' else cat >> src.F << '\eof' #define ANALIZE 0 '\eof' endif ########################## ### GRAPHICS SECTION ### ########################## if ($MESSG == ONE) then if ($MACHINE == T3D || $MACHINE == T3E) then cat >> src.F << '\eof' #define GKS 0 #define V5D 0 '\eof' else if ($VIS5D == 1) then cat >> src.F << '\eof' #define V5D 1 '\eof' else cat >> src.F << '\eof' #define V5D 0 '\eof' endif if ($NCARG == 1) then cat >> src.F << '\eof' #define GKS 1 '\eof' else cat >> src.F << '\eof' #define GKS 0 '\eof' endif endif else cat >> src.F << '\eof' #define GKS 0 #define V5D 0 '\eof' endif ######################### if ($PLOTR == 1) then cat >> src.F << '\eof' #define PLOTPL 1 '\eof' else cat >> src.F << '\eof' #define PLOTPL 0 '\eof' endif ######################### if ($COLOR == 1) then cat >> src.F << '\eof' #define COLORPL 1 '\eof' else cat >> src.F << '\eof' #define COLORPL 0 '\eof' endif ######################### if ($TURBL == 1) then cat >> src.F << '\eof' #define TURBPL 1 '\eof' else cat >> src.F << '\eof' #define TURBPL 0 '\eof' endif ######################### if ($SPCTR == 1) then cat >> src.F << '\eof' #define SPCTPL 1 '\eof' else cat >> src.F << '\eof' #define SPCTPL 0 '\eof' endif ######################### if ($VORTX == 1) then cat >> src.F << '\eof' #define VORTPL 1 '\eof' else cat >> src.F << '\eof' #define VORTPL 0 '\eof' endif ######################### ### MACHINE SETUP ### ######################### if ($MACHINE == T3D) then cat >> src.F << '\eof' #define CRAYPVP 0 #define CRAYT3D 1 #define CRAYT3E 0 #define SGI_O2K 0 #define HP 0 #define WORKS 0 #define FUJI_VPP 0 '\eof' endif ######################### if ($MACHINE == PVP) then cat >> src.F << '\eof' #define CRAYPVP 1 #define CRAYT3D 0 #define CRAYT3E 0 #define SGI_O2K 0 #define HP 0 #define WORKS 0 #define FUJI_VPP 0 '\eof' endif ######################### if ($MACHINE == T3E) then cat >> src.F << '\eof' #define CRAYPVP 0 #define CRAYT3D 0 #define CRAYT3E 1 #define SGI_O2K 0 #define HP 0 #define WORKS 0 #define FUJI_VPP 0 '\eof' endif ######################### if ($MACHINE == O2K) then cat >> src.F << '\eof' #define CRAYPVP 0 #define CRAYT3D 0 #define CRAYT3E 0 #define HP 0 #define WORKS 0 #define FUJI_VPP 0 '\eof' if ($WORD == 4) then cat >> src.F << '\eof' #define SGI_O2K 1 '\eof' endif if ($WORD == 8) then cat >> src.F << '\eof' #define SGI_O2K 2 '\eof' endif endif ######################### if ($MACHINE == HP) then cat >> src.F << '\eof' #define CRAYPVP 0 #define CRAYT3D 0 #define CRAYT3E 0 #define SGI_O2K 0 #define WORKS 0 #define FUJI_VPP 0 '\eof' if ($WORD == 4) then cat >> src.F << '\eof' #define HP 1 '\eof' endif if ($WORD == 8) then cat >> src.F << '\eof' #define HP 2 '\eof' endif endif ######################### if ($MACHINE == WRK || $MACHINE == NEC) then cat >> src.F << '\eof' #define CRAYPVP 0 #define CRAYT3D 0 #define CRAYT3E 0 #define SGI_O2K 0 #define HP 0 #define WORKS 1 #define FUJI_VPP 0 '\eof' endif ######################### if ($MACHINE == VP7) then cat >> src.F << '\eof' #define CRAYPVP 0 #define CRAYT3D 0 #define CRAYT3E 0 #define SGI_O2K 0 #define HP 0 #define WORKS 0 '\eof' if ($WORD == 4) then cat >> src.F << '\eof' #define FUJI_VPP 1 '\eof' endif if ($WORD == 8) then cat >> src.F << '\eof' #define FUJI_VPP 2 '\eof' endif endif if ($MACHINE == IBM) then cat >> src.F << '\eof' #define CRAYPVP 0 #define CRAYT3D 0 #define CRAYT3E 0 #define SGI_O2K 0 #define WORKS 0 #define FUJI_VPP 0 #define HP 0 '\eof' if ($WORD == 4) then cat >> src.F << '\eof' #define IBM 1 '\eof' endif if ($WORD == 8) then cat >> src.F << '\eof' #define IBM 2 '\eof' endif endif ######################################################################### ## C O M P O S E S O U R C E C O D E F O R C O M P I L E R ## ######################################################################### cat src.F cat >> src.F << '\eof' #define CAPEPL 0 #define SEMILAG 0 #define MOISTMOD 1 #define J3DIM 1 program anelas c.....7..0.........0.........0.........0.........0.........0.........012 c this code solves 3-d nonhydrostatic, anelastic equations of motion in the c terrain-following system of coordinates; see, e.g., gal-chen & c somerville, c 1975, j. comput. phys., 17, 209-228, for the terrain-following coordinate c transformation, and durran, 1989, j. atmos sci., 47, 1819-1820, and the c references therein for the discussion of the anelastic approximation. c c equations are solved using: (lagr=1) c semi-lagrangian approximations discussed in c smolarkiewicz & pudykiewicz, 1992, j. atmos. sci., 49, 2082--2096; c smolarkiewicz & grell, 1992, j. comput. phys., 101, 431--440, and c smolarkiewicz & rasch, 1991, j. atmos. sci., 48, 793-810 c or alternatively, (lagr=0) c eulerian forward-in-time differencing for fluids discussed in c smolarkiewicz 1991, Mon. Wea. Rev., 119, 2505--2510 and c smolarkiewicz & margolin 1993, Mon. Wea. Rev., 121, 1847--1859. c which in turn employs mpdata algorithms discussed in papers referenced c in smolarkiewicz and margolin 1993. c elliptic solver employs the generalized conjugate residual method c discussed in eisenstat at al. 1983, SIAM J. Numer. Anal., 20, 345--357, c and in some details in smolarkiewicz and margolin, 1993, LANL report c c c set grid sizes with parameter statements include 'param.nml' include 'param.ior' include 'param.misc' include 'msg.inc' include 'param.sds' include 'aerosol1size.inc' parameter (nml0=n*m*l,nm=n*m,ml=m*l) call for MPI include files #if (PARALLEL == 2) #if (HP > 0) include '/opt/mpi/include/mpif.h' #endif #if (CRAYT3D == 1) c include '/opt/ctl/mpt/mpt/include/mpif.h' include '/usr/local/MPI/t3d/include/mpif.h' #endif #if (CRAYT3E == 1) include '/opt/ctl/mpt/mpt/include/mpif.h' #endif #if (SGI_O2K > 0) include 'mpif.h' #endif #if (CRAYPVP == 1) include '/opt/ctl/mpt/mpt/include/mpif.h' #endif real*8 timeval,timestart,timeit,timeit0,timeend #endif real globmax,globmin,globsum ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create basic setups c---> lxyz=1 dx,dy,dz are Lx,Ly,Lz, respectively c---> lxyz=0 dx,dy,dz are appropriate grid increments data lxyz/0/ common/stresd/ ivis,irid,itstr,noutp,diagstr(8) common/strese/ diagste(12) data diagstr/8*0./,diagste/12*0./ c igrid=0 for A grid (faster); igrid=1 for B grid (more accurate) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 data igrid/0/ check that parameter nth=nt+1 data dx,dy,dz,dt,nt,noutp,nkg,nv5d,nstor/1.,1.,1.,0.2, . 1000,10,10,3000000,10/ ! 200 sec cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create history of the job (obsluga tasmy) c iwrite=0/1: no/create history tape; c irst=0/1: (no restart)/(restart run) from tape parameter(iwrite=1, iwrite0=1, irst=0) #if (HP > 0 || SGI_O2K > 1) integer CRAYOPEN,CRAYCLOSE #endif common/hpcray/ ifcw,ifcr,ioptw,ioptr data ioptw,ioptr/0,0/ C--> ioptr = 0 read data from HP/Convex format C--> on Cray set correct assign options C--> ioptr = 1 read data from Cray MPP (T3D,T3E) format C--> ioptr = 2 read data from Cray PVP (C90,J90,Y-MP) format C--> ioptw = 0 write data to HP/Convex format C--> on Cray set correct assign options C--> ioptw = 1 write data to Cray MPP (T3D,T3E) format C--> ioptw = 2 write data to Cray PVP (C90,J90,Y-MP) format c nfil: number of files generated if iwrite=1 parameter (nfil=2,nfilm=nfil-1) c nrestr-restart file from the history tape data nrestr/nfil/ c dtfil: dt in every file; ntfil: number of dt in every file dimension dtfil(nfil),ntfil(nfil) data dtfil/nfil*2./, ntfil/0,nfilm*6/ common/zinver/ iinav,iqcav ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc create model bounaries 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) parameter(irelx=0,irely=0,icyx=1,icyy=1,icyz=1) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/davies/ zab,towx,towy,towz,nrx,nry,relx(n),rely(m), 1 iab,iabth,iabqw c --- iab,iabth,iabqw are absorber flags for velocity, theta, water data iab,iabth,iabqw/0,0,0/ c --- zab is base of sponge in vertical c --- towx,towy,towz are absorber time scales in x,y,z c --- nrx,nry are number of points in absorber in x,y data zab,towz,nrx,nry,towx,towy/17.e3,300.,20,20,1.e10,1.e10/ data relx/n*0./,rely/m*0./ constants for pressure solver; itp_,epp_ are max number of iterations and constraint of accuracy max|1/rho*div(rho*v)*dt| latent heats: data hlatv,hlats /2.47e6,2.84e6/ #if (MOISTMOD > 0) #if (MOISTMOD == 1) common/rainc/ rac,qctr,rc c data rac,qctr,rc/1.e-3, 2.5e-3, 2.2/ data rac,qctr,rc/1.e-3, 2.5e-1, 2.2/ ! no rain ccreate parametrs for general precip formulation: c common/rain_p0/ ar,br,cr,dr,er,alphr,betr,gamb1r,gambd1r,anor c common/rain_p1/ dconc,ddisp c common/snow_p0/ as,bs,cs,ds,es,alphs,bets,gamb1s,gambd1s,anos c common/temp_p/ tup,tdn cC common/latent/hlatv,hlats c--> mass, terminal velocity, diameter data ar,br,cr,dr /5.2e2,3.,130.,0.5/ !! corrected data as,bs,cs,ds /2.5e-2,2.,4.,0.25/ c--> collection ef., alpha, beta data er,alphr,betr /0.8, 1., 2./ data es,alphs,bets /0.2, .3, 3./ c--> No data anor,anos /2*1.e7/ c--> latent heats: c data hlatv,hlats /2.53e6,2.84e6/ c--> cloud droplet concentration (per cc) and spectral dispersion c--> calculated as ddisp=0.146-5.964e-2*alog(dconc/2000.) data dconc,ddisp /200.,0.283/ ! dconc must be between 50 and 2000 c--> limiting temperatures c data tup,tdn /273.,258./ data tup,tdn /27.,25./ ! water only... c--> gammas: data gamb1r,gambd1r /6.0,11.7/ data gamb1s,gambd1s /2.0,2.56/ #endif #if (MOISTMOD == 2) common/rain2/ iberry,dconc,ddisp,rac,qctr,an0,colef c--> iberry=0 - Kessler autoconversion with rac and qctr c--> as rate and threshold values c--> iberry=1 - Berry's autoconversion formula with droplet c--> concentration dconc and dispersion coef. ddisp c--> NOTE: ddisp prescribed below will be overwritten c--> by an estimate from dconc based on observations data iberry /1/ c--> parameters needed for the Kessler parameterization: data rac,qctr /1.e-3,1.e-3/ c--> parametrs needed for the Berry parameterization: data dconc,ddisp /200.,.1/ ! ddisp will be calculated c--> n0 in Marshall-Palmer distribution, collection efficincy data an0,colef/ 1.e7, .8/ create graupel constants: c--> n0 in graupel MP distribution, graupel density common/graupel/ an0g,gden data an0g,gden /4.e6,4.e2/ #endif c--> large-scale data to drive cloud model: common /forc1/ uxnu(l),uynu(l) c--> forc2: advective effects for theta (K/sec) qv (kg/kg/sec) common /forc2/ dthls(l),dqvls(l) c--> forc3: sea surface potential temperature (K) and water vapor c--> mixing ratio (kg/kg), exchange coeficient set in blkdata common /forc3/ thsrf,qvsrf,coeth,coeqv data thsrf,qvsrf/300.,15.e-3/ c--> forc4: varying in time profiles of theta and qv: c--> units are K and kg/kg common /forc4/ thobs(l),qvobs(l) dimension haver1(l),haver2(l) common/radflux/ upsw1(1-ih:np+ih,1-ih:mp+ih,l), . dnsw1(1-ih:np+ih,1-ih:mp+ih,l), . uplw1(1-ih:np+ih,1-ih:mp+ih,l), . dnlw1(1-ih:np+ih,1-ih:mp+ih,l) common/ccmrst/ first logical first common /thqvbt/vthflx(1-ih:np+ih, 1-ih:mp+ih,l), . vqvflx(1-ih:np+ih, 1-ih:mp+ih,l), . sthflx(1-ih:np+ih, 1-ih:mp+ih,l), . sqvflx(1-ih:np+ih, 1-ih:mp+ih,l), . ceterm(1-ih:np+ih, 1-ih:mp+ih,l), . dsterm(1-ih:np+ih, 1-ih:mp+ih,l), . fmterm(1-ih:np+ih, 1-ih:mp+ih,l), . thlsf(l),qvlsf(l), . radlwh(1-ih:np+ih, 1-ih:mp+ih,l), . radswh(1-ih:np+ih, 1-ih:mp+ih,l) #endif cccccccccccccccccc close moist model cccccccccccccccccc c create blank common common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), . scr1(1-ih:np+ih,1-ih:mp+ih,l), . scr2(1-ih:np+ih,1-ih:mp+ih,l), . scr3(1-ih:np+ih,1-ih:mp+ih,l), . scr4(1-ih:np+ih,1-ih:mp+ih,l), . scr5(1-ih:np+ih,1-ih:mp+ih,l), . scr6(1-ih:np+ih,1-ih:mp+ih,l), . scr7(1-ih:np+ih,1-ih:mp+ih,l), . scr8(1-ih:np+ih,1-ih:mp+ih,l), . scr9(1-ih:np+ih,1-ih:mp+ih,l) dimension ularge(np,mp,l), . vlarge(np,mp,l), . wlarge(np,mp,l), #if (MOISTMOD > 0) . qclarge(np,mp,l), . qvlarge(np,mp,l), #endif . tlarge(np,mp,l), . rlarge(np,mp,l), . blarge(np,mp,l) dimension wlar(l) dimension temp2(1-ih:np+ih, 1-ih:mp+ih, l) common /stevens_etal/ divls,ff0,ff1,kappa,alpha_z,z_inv common /init_stv/ pre1(l),tme1(l),the1(l),qve1(l) 1 ,qce1(l),ue1(l),ve1(l) ccc SDs: function used in critical radius calculation: fun(rr,rrae)=a_over_3b*(rr**3-rrae**3) - rr**2 funp(rr)=3.*a_over_3b*rr**2 - 2.*rr c--------------------------------------------- check some possible errors in setup definition c--------------------------------------------- c print *,'+++ START PROGRAM' 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 (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 #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 c------------------------------------------------- continue execution - make some initial definitions c------------------------------------------------- #if (PARALLEL == 1) #if (SGI_O2K > 0) call start_pes(0) #endif #endif #if (PARALLEL == 2) call MPI_Init(ierr) #endif c-->-->-->-->-->-->-->-->-->-->-->-->-->-->-->-->-->--> c--> set geometry information for each processor, i.e., c--> where it is, who its neighbors are, etc. call geomset() c-->-->-->-->-->-->-->-->--> c--> test updates routines c call test c call testreal c-->-->-->-->-->-->-->--> c--> start initial time if (mype.eq.0) then print *,'*** STARTING TIME ***' call timefun() end if C#if (PARALLEL == 2) C if (mype.eq.0) then C timestart = MPI_Wtime() C end if C#endif j3=1 if(m.eq.1) j3=0 c-->-->-->-->-->-->-->--> c--> run NCARGraphics #if (GKS == 1) call opngks call gsclip(0) call ncargdef #endif c------------------------------------------------- c start computing c------------------------------------------------- c open (unit=1, file='CONTROL.dat', status='old') c READ (1, NML=CON) c close(1) if (mype.eq.0) then print *,'U00 :',U00 print *,'V00 :',V00 print *,'U0Z :',U0Z print *,'V0Z :',V0Z print *,'HB1 :',HB1 print *,'HB2 :',HB2 print *,'ST :',ST print *,'STS :',STS print *,'HT :',HT print *,'HS :',HS print *,'HF00:',HF00 print *,'QF00:',QF00 print *,'CDRG:',CDRG end if compute some relevant constants constants for computational grid if(lxyz.eq.1) then dx=dx/float(n-1) dy=dy/float(m-j3) dz=dz/float(l-1) endif dy=dy*j3+float(1-j3) dxi=1./dx dyi=1./dy*j3 dzi=1./dz dti=1./dt dzil=.5*dzi gc1=dt*dxi gc2=dt*dyi gc3=dt*dzi constants for reference state and lateral boundary conditions pi=acos(-1.) fcor1=0. fcor2=icorio*fcr0*cos(pi/180.*ang) fcor3=icorio*fcr0*sin(pi/180.*ang) ibcx=icyx ibcy=icyy*j3 ibcz=icyz if(ibcz.eq.1) igrid=0 irlx=irelx irly=irely*j3 constants for thermodynamics bv=sqrt(st*g) c cp=3.5*rg cp=1005. cap=rg/cp constant for drag c drgnorm=0.25*acos(-1.)*rh00*sqrt(g*st)*abs(u00)*amp*amp c if(j3.eq.1) drgnorm=drgnorm*xml drgnorm=1. if(drgnorm.eq.0) drgnorm=1. irid=max0(irid0,ivis) #if (MOISTMOD == 2) CONSTANTS AND TABLES FOR MOIST MODEL: create tables for water vapor saturation data call h2ovapor create Berry's warmrain parameters: if(iberry.eq.1) then ccc warmrain Berry's parameterization: cc check consistency if(dconc.lt.50..or.dconc.gt.2000.) then if(mype.eq.0) then print*,' *** inconsistent droplet concentration. stop.' endif stop 'dconc' endif cc calculate relative dispersion for Berry's autoconversion: ddisp=0.146-5.964e-2*alog(dconc/2000.) if(mype.eq.0) then print 2075,an0,dconc,ddisp 2075 format(1x,' N0 in raindrop distr.: ',e15.3/ 1 1x,' Berry parameters of cloud droplet spectrum:'/ 1 1x,' droplet conc., relative disp.: ',2f12.4) endif else if(mype.eq.0) then print 2076,an0,rac,qctr 2076 format(1x,' N0 in raindrop distr.: ',e15.3/ 1 1x,' Kessler formulation parameters (rate and threshold): ' 1 ,2e15.3) endif endif ccc initialize ice variables if appropriate: if(iceab.eq.1) call init_ice #endif conditions of the initial state *********************************** do 1 i=1,n 1 x(i)=(i-1)*dx-((n+1)*.5-1)*dx do 2 j=1,m 2 y(j)=(j-1)*dy-((m+1)*.5-1)*dy do 3 k=1,l z(k)=(k-1)*dz-((l+1)*.5-1)*dz*ibcz 3 continue zb=z(l) ccc initial CCN calls: call micro_set if (mype.eq.0) then call header(lipps,icorio,nt,nstor,itkes) end if #if (ANALIZE == 0) #if (HP > 0 || SGI_O2K > 1) if((iwrite.eq.1).or.(iwrite0.eq.1)) then if (mype.eq.0) then if(ioptw.gt.0) then ifcw = CRAYOPEN ("./fort.out", 1, o'644') endif endif endif #endif compute coordinate transformation related matrices call topo(x,y,n,m) call metryc(x,y,z,n,m,l) compute base state, environmental, and absorber profiles chose from either idealized profiles or real sounding: ccc start from idealized profiles: c call tinit_i(z,x,y,n,m,tau,lipps) ccc start from sounding (real data): call tinit_r(z,tau,lipps) check if reference density nonnegative; if yes increase th00 call rhngck(rho,n,m,l) check if reference conditional instability may occur c if(moist.eq.1) call cndinst create boundary values for velocity do j=1,mp do i=1,np ob(i,j,1)=0. ob(i,j,2)=0. end do end do call update(ue,np,mp,l,np,mp) if (leftedge.eq.1) then do i=1,l do j=1,mp ub(j,i,1)=ue(1,j,i) ub(j,i,2)=ue(0,j,i) end do end do end if if (rightedge.eq.1) then do i=1,l do j=1,mp ub(j,i,1)=ue(np+1,j,i) ub(j,i,2)=ue(np,j,i) end do end do end if call update(ve,np,mp,l,np,mp) if (botedge.eq.1) then do k=1,l do i=1,np vb(i,k,1)=ve(i,1,k) vb(i,k,2)=ve(i,0,k) end do end do end if if (topedge.eq.1) then do k=1,l do i=1,np vb(i,k,1)=ve(i,mp+1,k) vb(i,k,2)=ve(i,mp,k) end do end do end if call vbcad(rho,n,m,l) compute inital fields do k=1,l pre(k)=0.9e5 enddo if(irst.eq.0) then ccc open and read fields from tape: open(10,file='../input.dp.dat',form='unformatted',status='old') read(10) (((u(i,j,k,0),i=1,n),j=1,m),k=1,l) read(10) (((v(i,j,k,0),i=1,n),j=1,m),k=1,l) read(10) (((w(i,j,k,0),i=1,n),j=1,m),k=1,l) read(10) (((th(i,j,k),i=1,n),j=1,m),k=1,l) read(10) (((qv(i,j,k),i=1,n),j=1,m),k=1,l) cccccccccccccccccccccccccc amx=-1.e10 amn= 1.e10 do i=1,n do j=1,m do k=1,l amx=max(amx,th(i,j,k)) amn=min(amn,th(i,j,k)) enddo enddo enddo print*,'--th min max: ',amn,amx amx=-1.e10 amn= 1.e10 do i=1,n do j=1,m do k=1,l amx=max(amx,qv(i,j,k)) amn=min(amn,qv(i,j,k)) enddo enddo enddo print*,'--qv in min max: ',amn,amx c adjust qv to 97% RH: do i=1,n do j=1,m do k=1,l thi=1./th(i,j,k) ess=ee0*exp(hlat/rv * (1./t00 - thi)) qvs=rg/rv*ess/(pre(k)-ess) qv(i,j,k)=.97*qvs enddo enddo enddo amx=-1.e10 amn= 1.e10 do i=1,n do j=1,m do k=1,l amx=max(amx,qv(i,j,k)) amn=min(amn,qv(i,j,k)) enddo enddo enddo print*,'--qv adjust min max: ',amn,amx do i=1,n do j=1,m do k=1,l thi=1./th(i,j,k) ess=ee0*exp(hlat/rv * (1./t00 - thi)) qvs=rg/rv*ess/(pre(k)-ess) sup(i,j,k)=qv(i,j,k)/qvs-1. enddo enddo enddo call extr11(sup,nml0,an,ax) print*,' sup min max: ',an,ax cc surface tension, vapor diffusivity, thermal conductivity: cc HERE we assume that temp and pre variability is not important temp=th(1,1,1) sigma=76.1-0.155*(temp-273.16) sigma=sigma*1.e-3 ! in N/m difvp=2.11 * (temp/273.16)**1.94 * 101325./pre(1) difvp=difvp*1.e-5 ! in m**2/s tcond=1.5e-11*temp**3 - 4.8e-8*temp**2 + 1.0e-4*temp - 3.9e-4 tcond=tcond ! in W/mK print*,'-- sigma,difvp,tcond: ',sigma,difvp,tcond ccc set initial condition: print*,'--- nca= ',nca rho_w=1.e3 do ic=1,nca cc s_active and r_activ: rs0=rad0(ic) sm0=mas0(ic) aaa=2*sigma/(rv*rho_w*temp) bbb=vanhof*sm0*amol_w/amol_s/(4./3.*pi*rho_w) a_over_3b = sqrt(aaa/3./bbb) c print*,aaa,bbb cc drop: r_dr= 1./a_over_3b ! initial drop size... term1=aaa/r_dr r3=max(0.001*rs0**3, r_dr**3 - rs0**3) term2=bbb/r3 s_eq=exp(term1-term2) - 1. do it=1,5 r_dr=r_dr - fun(r_dr,rs0)/funp(r_dr) term1=aaa/r_dr r3=max(0.001*rs0**3, r_dr**3 - rs0**3) term2=bbb/r3 s_eq=exp(term1-term2) - 1. enddo c print*,' ' print 103,ic,rs0*1.e6,r_dr*1.e6,s_eq*1.e2 103 format(1x,i4,3e14.4,' ic,r0,ract,sact ') r_activ(ic)=r_dr s_activ(ic)=s_eq ccc eqlibrium with assumed initial RH: r_dr=r_activ(ic) supers=sup(1,1,1) ! only for S=const do it=1,15 ccc=alog(1.+supers) fun11=r_dr*(r_dr**3-rs0**3)*ccc - aaa*(r_dr**3-rs0**3) 1 + bbb*r_dr fun11p=(4.*r_dr**3-rs0**3)*ccc - 3.*aaa*r_dr**2 + bbb r_dr=r_dr - fun11/fun11p term1=aaa/r_dr r3=r_dr**3 - rs0**3 term2=bbb/r3 s_eq=exp(term1-term2) - 1. enddo print 104,supers*1.e2,rs0*1.e6,r_activ(ic)*1.e6, 1 s_activ(ic)*1.e2,r_dr*1.e6 104 format(1x,5e14.4,' sup,r0,r_act,s_act,r_qe ') radc(ic)=r_dr qcc(ic)=4./3.*pi*rho_w*(radc(ic)**3 - rad0(ic)**3) * conc(ic) print*,radc(ic),conc(ic),qcc(ic),' init rad,icon,qc' enddo ! loop over bins cccccccccccccccccccccccccc cc do 4 i=1,n do 4 j=1,m do 4 k=1,l o(i,j,k,0)=w(i,j,k,0)*gi(i,j)+u(i,j,k,0)*c13(i,j)*gmul(k) 1 +v(i,j,k,0)*c23(i,j)*gmul(k) p(i,j,k) =0. x0(i,j,k) =float(i) y0(i,j,k) =float(j) z0(i,j,k) =float(k) fx(i,j,k) =1. fy(i,j,k) =0. fz(i,j,k) =0. ft(i,j,k) =0. 4 continue ! ft(i,j,k) =0. set here or later... create moist initial conditions #if (MOISTMOD > 0) if(moist.eq.1) then do k=1,l do j=1,mp do i=1,np qc(i,j,k)=0. qr(i,j,k)=0. fqv(i,j,k)=0. fqc(i,j,k)=0. fqr(i,j,k)=0. ft(i,j,k) =0. ! brought perturbations... end do end do end do cc pi=4.*atan(1.) rho_w=1.e3 fact=4./3.*pi*rho_w npx=0 do i=1,n-1 do j=1,m-1 do k=1,l-1 c SDS initialization: do ipp=npx+1,npx+nppg cccc random position rand1=min(.9999,max(.0001,rand()))-.5 rand2=min(.9999,max(.0001,rand()))-.5 rand3=min(.9999,max(.0001,rand()))-.5 cc xp(ipp)=(i-1)*dx + rand1*dx yp(ipp)=(j-1)*dy + rand2*dy zp(ipp)=(k-1)*dz + rand3*dz plic(ipp)=200.e6/float(nppg)*rho(i,j,k) radp(ipp)=radc(1) qcp(ipp)=qcc(1)/float(nppg) enddo npx=npx+nppg cc end do end do end do print*,npx,(n-1)*(m-1)*(l-1)*nppg cc test cloud water: dxh=.5*dx dyh=.5*dy dzh=.5*dz do ip=1,npx i=(xp(ip)+dxh)/dx + 1 j=(yp(ip)+dyh)/dy + 1 k=(zp(ip)+dzh)/dz + 1 i=max(1,min(n,i)) j=max(1,min(m,j)) k=max(1,min(l,k)) qc(i,j,k)=qc(i,j,k)+qcp(ip) enddo c print*,qc(2,2,2) cc periodicity do j=1,m-1 do k=1,l-1 qc(n,j,k)=qc(1,j,k) enddo enddo do i=1,n do k=1,l-1 qc(i,m,k)=qc(i,1,k) enddo enddo do i=1,n do j=1,m qc(i,j,l)=qc(i,j,1) enddo enddo an=1.e20 ax=-1.e20 do i=1,n do j=1,m do k=1,l an=min(an,qc(i,j,k)) ax=max(ax,qc(i,j,k)) enddo enddo enddo print*,'--- initial min,max qc: ',an,ax #if (MOISTMOD == 2) if (iceab.eq.1) then do k=1,l do j=1,mp do i=1,np qia(i,j,k)=0. qib(i,j,k)=0. fqia(i,j,k)=0. fqib(i,j,k)=0. end do end do end do endif #endif endif #endif create tke km and its force create initial tke c if(ivis.eq.1) then c do k=1,l c do j=1,mp c do i=1,np c tke(i,j,k)=sqrt( 0.1*exp(-k*dz/500.) ) c end do c end do c end do c endif compute poisson equation for potential call gcrk(p,pfx,pfy,pfz,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),fx,fy,fz,n,m,l,itp0,epp0,0, * scr0,scr1,scr2) call prforc(p,pfx,pfy,pfz,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),fx,fy,fz,n,m,l, * scr1,scr2,scr3) 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. u(i,j,k,0)=pfx(i,j,k) v(i,j,k,0)=pfy(i,j,k) o(i,j,k,0)=pfz(i,j,k) omnt=u(i,j,k,0)*c13(i,j)+v(i,j,k,0)*c23(i,j) w(i,j,k,0)=( o(i,j,k,0)-gmul(k)*omnt )/gi(i,j) u(i,j,k,1)=u(i,j,k,0) v(i,j,k,1)=v(i,j,k,0) 5 o(i,j,k,1)=o(i,j,k,0) call potprs(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),p,n,m,l) c if(lagr.eq.1) then c call traject(u,v,o,n,m,l,gc1,gc2,gc3,0,1) c call forceb(u,v,o,w,n,m,l,gc1,gc2,gc3) c endif c if(iwrite.eq.1) then c if (mype.eq.0) then c call iowrite0(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), c . o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),th,p,fx,fy,fz,ft,fo, c . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke, c . hise,epp1) c else c call iowritek(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), c . o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),th,p,fx,fy,fz,ft,fo, c . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke) c end if c end if nitsm=0 icount=0 close potential flow initialisation if(ivis.eq.1) then hise(1,1)=0. hise(1,2)=0. hnrm=1./float(nml0) do k=1,l do j=1,mp do i=1,np ekn=0.5*(u(i,j,k,0)**2+v(i,j,k,0)**2+w(i,j,k,0)**2) hise(1,1)=hise(1,1)+ekn*hnrm hise(1,2)=hise(1,2)+tke(i,j,k)**2*hnrm enddo end do end do #if (PARALLEL > 0) hise(1,1)=globsum(hise(1,1),1,1,1,1,1,1,1,1,1,1,1,1) hise(1,2)=globsum(hise(1,2),1,1,1,1,1,1,1,1,1,1,1,1) #endif endif 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 u(i,j,k,2)=u(i,j,k,0)*(lagr+rho(i,j,k)*ieul) v(i,j,k,2)=v(i,j,k,0)*(lagr+rho(i,j,k)*ieul) o(i,j,k,2)=o(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. o(i,j,k,1)=0. enddo end do end do call velprd(u,v,w,o,fo,n,m,l,gc1,gc2,gc3,0,epp0,itp0, . scr6,scr7,scr8,scr9,nts,mts,lts) endif C**************************************** C* reading from tape: * C**************************************** else ! =>when irst=1 corporate information from the history tape print*,'-= Starting from a tape =-' #if (HP > 0 || SGI_O2K > 1) if (mype.eq.0) then if(ioptr.gt.0) then ifcr = CRAYOPEN ("./ftn10", 0, o'644') endif endif #endif do 1200 kf=1,nrestr #if (HP > 0 || SGI_O2K > 1) if (mype.eq.0) then endif #endif if (kf.eq.nrestr) then icomm=1 else icomm=0 end if if (mype.eq.0) then call ioread0(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),th,p,fx,fy,fz,ft,fo, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke, . icomm) else call ioreadk(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),th,p,fx,fy,fz,ft,fo, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke, . icomm) end if if((iwrite.eq.1).and.(iwrite0.eq.1).and.(kf.eq.nrestr)) then if (mype.eq.0) then call iowrite0(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),th,p,fx,fy,fz,ft,fo, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke, . hise,epp1) else call iowritek(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),th,p,fx,fy,fz,ft,fo, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke) end if end if time=time+dtfil(kf)*ntfil(kf)/60. tt=tt+dtfil(kf)*ntfil(kf) 1200 continue #if (HP > 0 || SGI_O2K > 1) if (mype.eq.0) then if(ioptr.gt.0) then ierr = CRAYCLOSE (ifcr) endif end if #endif 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 x0(i,j,k) =float(ia) y0(i,j,k) =float(ja) z0(i,j,k) =float(k) u(i,j,k,2)=u(i,j,k,0)*(lagr+rho(i,j,k)*ieul) v(i,j,k,2)=v(i,j,k,0)*(lagr+rho(i,j,k)*ieul) o(i,j,k,2)=o(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. o(i,j,k,1)=0. 1203 continue call velprd(u,v,w,o,fo,n,m,l,gc1,gc2,gc3,0,epp1,itp1, . scr6,scr7,scr8,scr9,nts,mts,lts) endif !of tape reading C********************************************************* C* end of data initialization (or reading from tape) * C********************************************************* compute time=0. diagnostics call sumcns(th,the,rho,n,m,l,thsum0,0) if(mype.eq.0) then print *,'**** total temperature:',thsum0 endif do 27 k=1,l do 27 j=1,mp do 27 i=1,np pfz(i,j,k)=w(i,j,k,0) 27 pfx(i,j,k)=rho(i,j,k) call rhsdiv(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . o(1-ih,1-ih,1,0),rho,pfy,n,m,l,1) #if (MOISTMOD > 0) if(moist.eq.1) then qws0=0. temp=0. do k=1,l do j=1,mp do i=1,np temp2(i,j,k)=(qv(i,j,k)+qc(i,j,k)+qr(i,j,k))*rho(i,j,k) end do end do end do #if (MOISTMOD == 2) if (iceab.eq.1) then do k=1,l do j=1,mp do i=1,np temp2(i,j,k)=temp2(i,j,k)+(qia(i,j,k)+qib(i,j,k))*rho(i,j,k) end do end do end do endif #endif if (irad.eq.1) then CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCC |--> R A D I A T I O N <--| CCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CTEST call ls_forc(1,time) c prepare surface fluxes CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C call surf_flux(th,qv,u(1-ih,1-ih,1,0), C 1 v(1-ih,1-ih,1,0),ft,fqv,iinav) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c call surf_flux_fair(th,qv,u(1-ih,1-ih,1,0), c 1 v(1-ih,1-ih,1,0),ft,fqv,0,iinav) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c flag to do radiation on startup: first=.true. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCC |--> R A D I A T I O N <--| CCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC endif qws0=globsum(temp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) call sumcns(qve,qve,rho,n,m,l,qwse,0) if(mype.eq.0) then print *,'**** total water (profile,initial):',qwse,qws0 endif endif #endif call diagnos(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),th,p,x0,y0,z0,rho,pfx,pfy,pfz, * thsum0,n,m,l,gc1,gc2,gc3,tt,tend,moist,qv,qc,qr,qia,qib, * qws0,0.,0.) #if (GKS == 1) #if (PLOTPL == 1) c if(moist.gt.0) call lwcpl(th,u,v,w,qv,qc,qr,qia,qib,lipps,0) call plot(th,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),p,pfy,qv,qc,qr,qia,qib, * lipps,tke,pfz) #endif #if (TURBPL == 1) c call turban(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), c * w(1-ih,1-ih,1,0),th,p,qv,qc,qr,lipps,tke,ivis) #endif #if (VORTPL == 1) c call vort(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), c * w(1-ih,1-ih,1,0),pfx,pfy,pfz,1) c call plov(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), c * w(1-ih,1-ih,1,0),o(1-ih,1-ih,1,0),th,pfx,pfy,pfz) #endif do ii=1,l utim(0,ii)=u(np/2,mp/2,ii,0) vtim(0,ii)=v(np/2,mp/2,ii,0) wtim(0,ii)=w(np/2,mp/2,ii,0) ttim(0,ii)=th(np/2,mp/2,ii) enddo #endif #if (V5D == 1) inr=0 call zbiory_v5d(th,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),p,pfy,qv,qc,qr, * qia,qib,tke,pfz,n,m,l,inr) #endif C#if (PARALLEL == 2) C if (mype.eq.0) then C timeit = MPI_Wtime() C timeval = timeit - timestart C write(*,*)'wallclock time in diagnose=',timeval,'sec' C end if C#endif close initial conditions ************************************* compute solution in time ************************************* do 10 it=1,nt c if (mype.eq.0) then print *,'mype:',mype,' at ',it,' time step' c endif if(it/mpfl*mpfl.eq.it) then liner=1 else liner=0 endif c call simple_rad(z,ft,qc) #if(MOISTMOD > 0) if (irad.eq.1) then CCCCCCCCC |--> R A D I A T I O N <--| CCCCCCCCCCCC CTEST call ls_forc(1,time) c call horave(u(1-ih,1-ih,1,0),haver1,np,mp,l,ibcx,ibcy,j3) c call horave(v(1-ih,1-ih,1,0),haver2,np,mp,l,ibcx,ibcy,j3) cc****** surface fluxes and radiation: ******************** c add surface fluxes CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C call surf_flux(th,qv,u(1-ih,1-ih,1,0), C 1 v(1-ih,1-ih,1,0),ft,fqv,iinav) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c call surf_flux_fair(th,qv,u(1-ih,1-ih,1,0), c 1 v(1-ih,1-ih,1,0),ft,fqv,1,iinav) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c do j=1,mp c do i=1,np c hfx(i,j)=hfx(i,j)+dhfx ! heat flux in K*m/s c enddo c enddo #if(MOISTMOD > 0) c do j=1,mp c do i=1,np c qfx(i,j)=qfx(i,j)+dqfx ! spec.hum.flux in kg/kg*m/s c enddo c enddo #endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ccc*************************** end of lsf and sf ******************** CCCCCCCCC |--> R A D I A T I O N <--| CCCCCCCCCCCC end if #endif #if (SEMILAG == 1) if(lagr.eq.1) call traject(u,v,o,n,m,l,gc1,gc2,gc3,itraj,1) #endif compute fields + half of the trapezoidal forcing updr=1. ! mean ascent c change of mean pressure rho0=1. do k=1,l pre(k)=pre(k)-g*rho0*updr*dt enddo do 290 k=1,l do 290 j=1,mp do 290 i=1,np cc adiabatic expansion: th(i,j,k) = th(i,j,k) 1 - g/cp*(w(i,j,k,0)+updr)*dt + ft1(i,j,k)*dt cc adiabatic expansion: u(i,j,k,2)=u(i,j,k,0)*(lagr+rho(i,j,k)*ieul) v(i,j,k,2)=v(i,j,k,0)*(lagr+rho(i,j,k)*ieul) o(i,j,k,2)=o(i,j,k,0)*(lagr+rho(i,j,k)*ieul) u(i,j,k,0)= u(i,j,k,0)+.5*fx(i,j,k)*dt v(i,j,k,0)= v(i,j,k,0)+.5*fy(i,j,k)*dt w(i,j,k,0)= w(i,j,k,0)+.5*fz(i,j,k)*dt 290 continue 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) if(itraj.eq.1) then do 291 k=1,l do 291 j=1,mp do 291 i=1,np 291 fo(i,j,k)= o(i,j,k,0)+.5*fo(i,j,k)*dt call advec(fo,x0,y0,z0,5,0) endif if(moist.eq.1) then do k=1,l do j=1,mp do i=1,np #if (MOISTMOD == 1) qv(i,j,k)=qv(i,j,k)+fqv1(i,j,k)*dt c qc(i,j,k)=amax1(0.,qc(i,j,k)+.5*fqc(i,j,k)*dt) c qv(i,j,k)=amax1(0.,qv(i,j,k)+.5*fqv(i,j,k)*dt) c qc(i,j,k)=qv(i,j,k)+qc(i,j,k)+.5*(fqv(i,j,k)+fqc(i,j,k))*dt c qv(i,j,k)=qv(i,j,k)+.5*fqv(i,j,k)*dt #endif #if (MOISTMOD == 2) qc(i,j,k)=amax1(0.,qc(i,j,k)+.5*fqc(i,j,k)*dt) qv(i,j,k)=amax1(0.,qv(i,j,k)+.5*fqv(i,j,k)*dt) #endif enddo end do end do call advec(qv,x0,y0,z0,6,0) c call advec(qc,x0,y0,z0,7,0) #if (MOISTMOD == 1) if(ice.eq.0) then cc NO RAIN c call rain(qr,ft,fqv,fqc,fqr,x0,y0,z0,u(1-ih,1-ih,1,2), c . v(1-ih,1-ih,1,2),o(1-ih,1-ih,1,2),fx,fy,fz, c . u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1),o(1-ih,1-ih,1,1), c . n,m,l) else call rain_snow(qr,ft,fqv,fqc,fqr,x0,y0,z0,u(1-ih,1-ih,1,2), . v(1-ih,1-ih,1,2),o(1-ih,1-ih,1,2),fx,fy,fz, . u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1),o(1-ih,1-ih,1,1), . n,m,l) endif #endif #if (MOISTMOD == 2) call prec_rain(qr,ft,fqv,fqc,fqr, . x0,y0,z0,u(1-ih,1-ih,1,2),v(1-ih,1-ih,1,2),o(1-ih,1-ih,1,2), . fx,fy,fz,u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1),o(1-ih,1-ih,1,1)) if(iceab.eq.1) then call prec_ice(qia,qib,ft,fqv,fqc,fqia,fqib, . x0,y0,z0,u(1-ih,1-ih,1,2),v(1-ih,1-ih,1,2),o(1-ih,1-ih,1,2), . fx,fy,fz,u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1),o(1-ih,1-ih,1,1)) endif #endif endif cc if(itke.eq.1) then do k=1,l do j=1,mp do i=1,np tke(i,j,k)=tke(i,j,k)+.5*ftke(i,j,k)*dt enddo end do end do call advec(tke,x0,y0,z0,9,0) endif compute time dependent metric terms and related quantities tt=tt+dt if(tt.le.tend) then compute coordinate transformation related matrices call topo(x,y,n,m) call metryc(x,y,z,n,m,l) compute base state, environmental, and absorber profiles cc call tinit_i(z,x,y,n,m,tau,lipps) call tinit_r(z,tau,lipps) call vbcad(rho,n,m,l) endif close time dependent metrics compute new forcing at grid points compute phase change and gravity wave absorbers if(moist.eq.1) then #if (MOISTMOD == 1) if(ice.eq.0) then c call water(th,qv,qc,qr,ft,fqv,fqc,fqr,n,m,l, c . tau,relx,rely,iabth,iabqw,scr1,scr2,scr3,scr4) do i=1,n do j=1,m do k=1,l ft(i,j,k)=0. fqv(i,j,k)=0. enddo enddo enddo else call water_ice(th,qv,qc,qr,ft,fqv,fqc,fqr,n,m,l, . tau,relx,rely,iabth,iabqw,scr1,scr2,scr3,scr4) endif #endif #if (MOISTMOD == 2) if(iceab.eq.0) . call water(th,qv,qc,qr,ft,fqv,fqc,fqr,n,m,l, . tau,relx,rely,iabth,iabqw) if(iceab.eq.1) . call water_ice(th,qv,qc,qr,qia,qib,ft,fqv,fqc,fqr,n,m,l, . fqia,fqib,tau,relx,rely,iabth,iabqw) #endif else c if (ivis.eq.0) then ! assume subgrid heat flux to warm the pbl c hf00=1.e-2 c apbl=0.04 c do k=1,l c floc=apbl*exp(-apbl*(k-1)*dz) c do j=1,mp c do i=1,np c ft(i,j,k)=floc*hf00 c enddo c enddo c enddo c endif c pbl (see invertab for the continuation) c call invertab(th,the,ft,tau,relx,rely,dt,iabth,n,m,l) endif convoke buoyncy, coriolis, and absorber forces into auxiliary velocities do 293 k=1,l do 293 j=1,mp do 293 i=1,np 293 fx(i,j,k)=0. ! g*(th(i,j,k)-the(i,j,k))/th0(i,j,k) if(moist.eq.1) then c epsb=rv/rg-1. c do 294 k=1,l c do 294 j=1,mp c do 294 i=1,np c 294 fx(i,j,k)=fx(i,j,k)+g*( epsb*(qv(i,j,k)-qve(i,j,k)) c * -(qc(i,j,k)+qr(i,j,k)) ) #if (MOISTMOD == 2) if(iceab.eq.1) then do 2941 k=1,l do 2941 j=1,mp do 2941 i=1,np 2941 fx(i,j,k)=fx(i,j,k)-g*(qia(i,j,k)+qib(i,j,k)) endif #endif endif #if (CAPEPL == 1) c do i=1,np c cin(i,it)=0 c cape(i,it)=0 c do k=1,l c cape(i,it)=cape(i,it)+amax1(0.,fx(i,20,k)) c cin(i,it)=cin(i,it)+amin1(0.,fx(i,20,k)) c enddo c enddo call parcel(z,th,qv,qc,qr,it) #endif if(igrid.eq.0) call integz(fx,fy,n,m,l) do k=1,l do j=1,mp do i=1,np temp2(i,j,k)=abs(fx(i,j,k)/g) end do end do end do bmx=globmax(temp2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) do 295 k=1,l do 295 j=1,mp do 295 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp buo=fx(i,j,k) relt=relx(ia)+rely(ja)-relx(ia)*rely(ja) tauv=tau(k,i,j)*(1.-relt)+relt fx(i,j,k)=1./(1.+.5*dt*tauv) fy(i,j,k)=0.5*dt*fcor3*fx(i,j,k) fz(i,j,k)=0.5*dt*fcor2*fx(i,j,k) utilda=u(i,j,k,0)+.5*dt*(tauv*ue(i,j,k)-fcor3*ve(i,j,k)) vtilda=v(i,j,k,0)+.5*dt*(tauv*ve(i,j,k)+fcor3*ue(i,j,k)) wtilda=w(i,j,k,0)+.5*dt*(buo-fcor2*ue(i,j,k)) u(i,j,k,1)=utilda+fy(i,j,k)*vtilda-fz(i,j,k)*wtilda v(i,j,k,1)=(1.+fz(i,j,k)**2)*vtilda-fy(i,j,k)*utilda . +fy(i,j,k)*fz(i,j,k)*wtilda o(i,j,k,1)=gi(i,j)*( wtilda*(1.+fy(i,j,k)**2) . +(utilda+fy(i,j,k)*vtilda)*fz(i,j,k) ) . +gmul(k)*(c13(i,j)*u(i,j,k,1)+c23(i,j)*v(i,j,k,1)) 295 continue if(tt.le.tend) then do 296 k=1,l do 296 j=1,mp do 296 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp o(i,j,k,1)=o(i,j,k,1) 1 -gmul(k)*zsd(ia,ja)/zb*gi(i,j)*(1.+fy(i,j,k)**2) 296 continue endif compute pressure equation c here fx, fy, and fz contain coefficients defined in 292; c we still need u0,v0,w0,t0 for new forces call gcrk(p,pfx,pfy,pfz,u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1), . o(1-ih,1-ih,1,1),fx,fy,fz,n,m,l,itp1,epp1,0, . scr0,scr1,scr2) call prforc(p,pfx,pfy,pfz,u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1), . o(1-ih,1-ih,1,1),fx,fy,fz,n,m,l, . scr1,scr2,scr3) compute velocity and forces' update, and shift temporal levels do 34 k=1,l do 34 j=1,mp do 34 i=1,np u(i,j,k,1)=pfx(i,j,k) v(i,j,k,1)=pfy(i,j,k) o(i,j,k,1)=pfz(i,j,k) w(i,j,k,1)=(o(i,j,k,1)-gmul(k)*c13(i,j)*u(i,j,k,1) 1 -gmul(k)*c23(i,j)*v(i,j,k,1))/gi(i,j) 34 continue if(tt.le.tend) then do 340 k=1,l do 340 j=1,mp do 340 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp 340 w(i,j,k,1)=w(i,j,k,1)+gmul(k)*zsd(ia,ja)/zb endif do 35 k=1,l do 35 j=1,mp do 35 i=1,np 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 u(i,j,k,0)= u(i,j,k,1) v(i,j,k,0)= v(i,j,k,1) o(i,j,k,0)= o(i,j,k,1) w(i,j,k,0)= w(i,j,k,1) u(i,j,k,1)= 0. v(i,j,k,1)= 0. w(i,j,k,1)= 0. o(i,j,k,1)= 0. 35 continue if(itraj.eq.1) then do 350 k=1,l do 350 j=1,mp do 350 i=1,np 350 fo(i,j,k)=( o(i,j,k,0)-fo(i,j,k) )*2.*dti endif 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),th, qv, qc, qr, qia, qib, tke, 1 fx,fy,fz,ft,fqv,fqc,fqr,fqia,fqib,ftke, 2 fo,pfx,pfy,pfz,u(1-ih,1-ih,1,1), . v(1-ih,1-ih,1,1),w(1-ih,1-ih,1,1), . o(1-ih,1-ih,1,1),scalar_id) endif ifilt=0 if(ifilt.eq.1) then call xyfilt(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . w(1-ih,1-ih,1,0),u(1-ih,1-ih,1,1), . v(1-ih,1-ih,1,1),w(1-ih,1-ih,1,1), . n,m,l,j3) factor=.025 do k=1,l do j=1,mp do i=1,np fx(i,j,k)=fx(i,j,k)+u(i,j,k,1)*2.*dti*factor fy(i,j,k)=fy(i,j,k)+v(i,j,k,1)*2.*dti*factor fz(i,j,k)=fz(i,j,k)+w(i,j,k,1)*2.*dti*factor enddo enddo enddo call xyfilt(ft,fqv,fqc,u(1-ih,1-ih,1,1), . v(1-ih,1-ih,1,1),w(1-ih,1-ih,1,1), . n,m,l,j3) do k=1,l do j=1,mp do i=1,np ft(i,j,k)=ft(i,j,k)+u(i,j,k,1)*2.*dti*factor fqv(i,j,k)=fqv(i,j,k)+v(i,j,k,1)*2.*dti*factor enddo enddo enddo endif compute velocity predictor for the first guess of the trajectory scheme call velprd(u,v,w,o,fo,n,m,l,gc1,gc2,gc3,itraj,epp1,itp1, . scr6,scr7,scr8,scr9,nts,mts,lts) do k=1,l do j=1,mp do i=1,np u(i,j,k,0)= u(i,j,k,0)-ularge(i,j,k) v(i,j,k,0)= v(i,j,k,0)-vlarge(i,j,k) w(i,j,k,0)= w(i,j,k,0)-wlarge(i,j,k) th(i,j,k) = th(i,j,k)-tlarge(i,j,k) #if (MOISTMOD == 2) qv(i,j,k)= qv(i,j,k)-qvlarge(i,j,k) qc(i,j,k)= qc(i,j,k)-qclarge(i,j,k) #endif enddo enddo enddo clock update (in minutes for plotting purposes) time=time+dt/60. calculate drag force itd=it call drag(p,fmx,fmy,n,m,l,scr1) if(ivis.eq.1) then hise(it+1,1)=0. hise(it+1,2)=0. hnrm=1./float(nml0) do k=1,l do j=1,mp do i=1,np ekn=0.5*(u(i,j,k,0)**2+v(i,j,k,0)**2+w(i,j,k,0)**2) hise(it+1,1)=hise(it+1,1)+ekn*hnrm hise(it+1,2)=hise(it+1,2)+tke(i,j,k)**2*hnrm enddo end do end do #if (PARALLEL > 0) hise(it+1,1)=globsum(hise(it+1,1),1,1,1,1,1,1,1,1,1,1,1,1) hise(it+1,2)=globsum(hise(it+1,1),1,1,1,1,1,1,1,1,1,1,1,1) #endif endif #if (GKS == 1) do ii=1,l utim(it,ii)=u(np/2,mp/2,ii,0) vtim(it,ii)=v(np/2,mp/2,ii,0) wtim(it,ii)=w(np/2,mp/2,ii,0) ttim(it,ii)=th(np/2,mp/2,ii) enddo #endif compute outputed fields call lipsch(u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1), . o(1-ih,1-ih,1,1),rho,n,m,l,gc1,gc2,gc3,cr1,cr2, . lagr,0) epp1=amax1(1.e-9, 1.e-5*lagr*amin1(cr1,cr2) . +.5e-4*ieul*amin1(cr1,cr2,bmx) ) if(moist.eq.1) call r_lipsch . (u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1),o(1-ih,1-ih,1,1), . qr,pfx,rho,gi,n,m,l,gc1,gc2,gc3,crr1,crr2,lagr,0) C--------------------------------------------------------------- C------------------> STORING DATA <--------------------- C--------------------------------------------------------------- if(it/nstor*nstor.eq.it.and.iwrite.eq.1) then write(9)(((u(i,j,k,0),i=1,n),j=1,m),k=1,l) write(9)(((v(i,j,k,0),i=1,n),j=1,m),k=1,l) write(9)(((w(i,j,k,0),i=1,n),j=1,m),k=1,l) write(9)(((th(i,j,k),i=1,n),j=1,m),k=1,l) write(9)(((qv(i,j,k),i=1,n),j=1,m),k=1,l) write(9) xp,yp,zp,qcp,plic,radp c if (mype.eq.0) then c call iowrite0(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), c . o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),th,p,fx,fy,fz,ft,fo, c . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke, c . hise,epp1) c else c call iowritek(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), c . o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),th,p,fx,fy,fz,ft,fo, c . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke) c end if end if C--------------------------------------------------------------- C------------------> STORING DATA <--------------------- C--------------------------------------------------------------- C--------------------------------------------------------------- C------------------> DIAGNOSTIC OUTPUT <--------------------- C--------------------------------------------------------------- ccc TKE and vorticity every time step: 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) anorm=(n-1)*(m-1)*(l-1) atke=0. atkex=0. atkey=0. atkez=0. enst=0. umean=0. vmean=0. wmean=0. do i=1,n-1 do j=1,m-1 do k=1,l-1 atke=atke+ u(i,j,k,0)**2+v(i,j,k,0)**2+w(i,j,k,0)**2 atkex=atkex+ u(i,j,k,0)**2 atkey=atkey+ v(i,j,k,0)**2 atkez=atkez+ w(i,j,k,0)**2 enst=enst+ pfx(i,j,k)**2+pfy(i,j,k)**2+pfz(i,j,k)**2 umean=umean + u(i,j,k,0) vmean=vmean + v(i,j,k,0) wmean=wmean + w(i,j,k,0) enddo enddo enddo umean=umean/anorm vmean=vmean/anorm wmean=wmean/anorm atke=.5*atke/anorm atkex=.5*atkex/anorm atkey=.5*atkey/anorm atkez=.5*atkez/anorm enst=.5*enst/anorm print*,'--- TKE,enstrophy: ',atke,enst print*,'--- u,v,w mean: ',umean,vmean,wmean atke0=5.2e-2/3. ! for 64**3 DNS Lois code on bluedwarf cc FORCING: coefx=sqrt(atke0/atkex) coefy=sqrt(atke0/atkey) coefz=sqrt(atke0/atkez) print*,'forcing coe: ',coefx,coefy,coefz dtr=10.*dt do i=1,n do j=1,m do k=1,l fx(i,j,k)=fx(i,j,k) + 2.*u(i,j,k,0)*(coefx-1.)/dt - 2.*umean/dtr fy(i,j,k)=fy(i,j,k) + 2.*v(i,j,k,0)*(coefy-1.)/dt - 2.*vmean/dtr fz(i,j,k)=fz(i,j,k) + 2.*w(i,j,k,0)*(coefz-1.)/dt - 2.*wmean/dtr ux(i,j,k)=u(i,j,k,0) uy(i,j,k)=v(i,j,k,0) uz(i,j,k)=w(i,j,k,0) enddo enddo enddo cc finish thermodynamics cc SDS transport and physics: call sd_adv(ux,uy,uz,n,m,l,xp,yp,zp,npx) a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg cc t00i=1./t00 do i=1,n do j=1,m do k=1,l thi=1./th(i,j,k) ess=ee0*exp(d * (t00i - thi)) qvs=rg/rv*ess/(pre(k)-ess) sup(i,j,k)=qv(i,j,k)/qvs-1. ft1(i,j,k)=0. fqv1(i,j,k)=0. qc(i,j,k)=0. anum(i,j,k)=0. enddo enddo enddo call extr11(sup,nml0,an,ax) print*,' sup min max: ',an,ax call sd_phy(th,sup,ft1,fqv1,pre,npx,xp,yp,zp,qcp,plic,radp) dxh=.5*dx dyh=.5*dy dzh=.5*dz do ip=1,npx i=(xp(ip)+dxh)/dx + 1 j=(yp(ip)+dyh)/dy + 1 k=(zp(ip)+dzh)/dz + 1 i=max(1,min(n,i)) j=max(1,min(m,j)) k=max(1,min(l,k)) qc(i,j,k)=qc(i,j,k)+qcp(ip) c anum(i,j,k)=anum(i,j,k)+1. enddo c do i=1,n-1 c do j=1,m-1 c do k=1,l-1 c if(anum(i,j,k).le.nppg-15) print*,i,j,k,anum(i,j,k) c if(anum(i,j,k).ge.nppg+15) print*,i,j,k,anum(i,j,k) c enddo c enddo c enddo cc periodicity do j=1,m-1 do k=1,l-1 qc(n,j,k)=qc(1,j,k) enddo enddo do i=1,n do k=1,l-1 qc(i,m,k)=qc(i,1,k) enddo enddo do i=1,n do j=1,m qc(i,j,l)=qc(i,j,1) enddo enddo an=1.e20 ax=-1.e20 do i=1,n do j=1,m do k=1,l an=min(an,qc(i,j,k)) ax=max(ax,qc(i,j,k)) enddo enddo enddo print*,'--- min,max qc: ',an,ax c sum=0. c do i=1,n-1 c do j=1,m-1 c do k=1,l-1 c sum=sum+qc(i,j,k) c enddo c enddo c enddo c print*,'--- total qc: ',sum c if(it/noutp*noutp.eq.it) then c if (mype.eq.0) then write(*,210) it,dt,time*60. 210 format(/,8x,' it=',i5,' dt(sec)=',f7.2,' time(sec)=',f8.2) print 211,cr1,cr2,bmx 211 format(1x,'cour,lipsh:',2e11.4,' max|g*B|=',e11.4) if(moist.eq.1) print 212,crr1,crr2 212 format(1x,'cour,lipsh:',2e11.4,' for rain') end if if(it/noutp*noutp.eq.it) then do 250 k=1,l do 250 j=1,mp do 250 i=1,np pfx(i,j,k)=rho(i,j,k) 250 pfz(i,j,k)= w(i,j,k,0) #if (SEMILAG == 1) if(lagr.eq.1) call interp(pfx,x0,y0,z0,1) #endif call rhsdiv(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . o(1-ih,1-ih,1,0),rho,pfy,n,m,l,1) call diagnos(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),th,p,x0,y0,z0,rho,pfx,pfy,pfz, * thsum0,n,m,l,gc1,gc2,gc3,tt,tend,moist,qv,qc,qr,qia,qib, * qws0,0.,0.) endif C--------------------------------------------------------------- C------------------> DIAGNOSTIC OUTPUT <--------------------- C--------------------------------------------------------------- #if (MOISTMOD > 0) if(moist.eq.1 .and. (noutp.ne.nkg .or. noutp.ne.nv5d)) . call rhfld(th,qv,n,m,l,1,pfz) #endif C--------------------------------------------------------------- C------------------> GKS OUTPUT <--------------------- C--------------------------------------------------------------- #if (GKS == 1) if(it.eq.nt+1) then #if (CAPEPL == 1) capem=-1.e10 cinm=-1.e10 capen=1.e10 cinn=1.e10 do j=0,nth-1 do i=1,np capem=amax1(capem,cape(i,j)) cinm=amax1( cinm, cin(i,j)) capen=amin1(capen,cape(i,j)) cinn=amin1( cinn, cin(i,j)) write (13,999) cape(i,j),cin(i,j) enddo enddo 999 format(1x,2f12.6) print *,'CAPE_CIN' print *,'cape min; max:',capen,capem,' cin min; max:',cinn,cinm call wyporpl(cape,cin,n,nth,10) #endif call timepl(utim,nth,l,10,35) call timepl(vtim,nth,l,10,36) call timepl(wtim,nth,l,10,37) call timepl(ttim,nth,l,10,38) endif if(it/nkg*nkg.eq.it) then #if (PLOTPL == 1) c if(moist.gt.0) call lwcpl(th,u,v,w,qv,qc,qr,qia,qib,lipps,it) call plot(th,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),p,pfy,qv,qc,qr,qia,qib, * lipps,tke,pfz) if((it.eq.nt).and.(ivis.eq.1)) call plothise(hise,it+1,nthv) call plotdrag(fmx,fmy,it) #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),o(1-ih,1-ih,1,0),th,pfx,pfy,pfz) #endif endif #endif C--------------------------------------------------------------- C------------------> GKS OUTPUT <--------------------- C--------------------------------------------------------------- C--------------------------------------------------------------- C------------------> VIS5D OUTPUT <--------------------- C--------------------------------------------------------------- #if (V5D == 1) if(it/nv5d*nv5d.eq.it) then inr=inr+1 call zbiory_v5d(th,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),p,pfy,qv,qc,qr, * qia,qib,tke,pfz,n,m,l,inr) endif #endif C--------------------------------------------------------------- C------------------> VIS5D OUTPUT <--------------------- C--------------------------------------------------------------- check for stability of computations if((lagr.eq.1.AND.(cr2.gt.2..OR.cr1.ge.ihlag)).OR. . (lagr.eq.0.and.cr1.gt.2.).or. . ((moist.eq.1).and.( . (lagr.eq.1.and.crr2.gt.2.).or. . (lagr.eq.0.and.crr1.gt.2.) ) ) ) then do 2501 k=1,l do 2501 j=1,mp do 2501 i=1,np pfx(i,j,k)=rho(i,j,k) 2501 pfz(i,j,k)= w(i,j,k,0) #if (SEMILAG == 1) if(lagr.eq.1) call interp(pfx,x0,y0,z0,1) #endif call rhsdiv(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . o(1-ih,1-ih,1,0),rho,pfy,n,m,l,1) call diagnos(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),th,p,x0,y0,z0,rho,pfx,pfy,pfz, * thsum0,n,m,l,gc1,gc2,gc3,tt,tend,moist,qv,qc,qr,qia,qib, * qws0,0.,0.) #if (PLOTPL == 1) if(moist.gt.0) call lwcpl(th,u,v,w,qv,qc,qr,qia,qib,lipps,it) call plot(th,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),p,pfy,qv,qc,qr,qia,qib, * lipps,tke,pfz) if((it.eq.nt).and.(ivis.eq.1)) call plothise(hise,it+1,nthv) call plotdrag(fmx,fmy,it) #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),o(1-ih,1-ih,1,0),th,pfx,pfy,pfz) #endif if(lagr.eq.1.AND.(cr2.gt.3..OR.cr1.ge.ihlag)) then print 211,cr1,cr2,bmx stop 'lipshitz' endif if(lagr.eq.0.and.cr1.gt.3.) then print 211,cr1,cr2,bmx stop 'courant' endif if(moist.eq.1) then if(lagr.eq.1.and.crr2.gt.3.) then print 212,crr1,crr2 stop 'rain-lipshitz' endif if(lagr.eq.0.and.crr1.gt.3.) then print 212,crr1,crr2 stop 'rain-courant' endif endif endif close stability checks C#if (PARALLEL == 2) C if (mype.eq.0) then C timeit0 = timeit C timeit = MPI_Wtime() C timeval = timeit - timeit0 C write(*,*)'wallclock time in time steps=',timeval,'sec' C end if C#endif 10 continue close time integration C*****************************************************C C END of Main Program C C*****************************************************C #if (HP > 0 || SGI_O2K > 1) if((iwrite.eq.1).or.(iwrite0.eq.1)) then if (mype.eq.0) then if(ioptw.gt.0) then ierr = CRAYCLOSE (ifcw) endif endif endif #endif Cendif ANALIZE == 0 #endif C------------------------ #if (ANALIZE == 1) #if (HP > 0 || SGI_O2K > 1) if (mype.eq.0) then if(ioptr.gt.0) then ifcr = CRAYOPEN ("./ftn10", 0, o'644') endif endif #endif nplo=1 it=0 do 1000 kf=1,nfil print *,'Read data from tape nr:',kf icomm=1 time=time+dtfil(kf)*ntfil(kf)/60. tt=tt+dtfil(kf)*ntfil(kf) it=it+ntfil(kf) print 310,ntfil(kf),dtfil(kf),time*60. 310 format(/,8x,' it=',i5,' dt(sec)=',f7.2,' time(sec)=',f8.2) #if (HP > 0 || SGI_O2K > 1) if (mype.eq.0) then print *,'Read data from tape ',ifcr,' nr:',kf endif #endif if (mype.eq.0) then call ioread0(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),th,p,fx,fy,fz,ft,fo, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke, . icomm) else call ioreadk(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),th,p,fx,fy,fz,ft,fo, . qv,qc,qr,fqv,fqc,fqr,qia,qib,fqia,fqib,tke,ftke, . icomm) end if if(kf/nplo*nplo.eq.kf) then qcnv=0. iqcav=0 do j=1,mp do i=1,np do k=2,l-1 zinv1=qv(i,j,k+1)-qv(i,j,k-1) ! find local z gradient of qv qcnv1=qc(i,j,k) ! find local qc mixing ratio if(qcnv1.gt.qcnv) then ! find maximum in local qc iqcv=k ! level of maxium (cloud) qcnv=qcnv1 ! new value of maximum endif ! end enddo iqcav=iqcav+iqcv ! level of mean maximum cloud water enddo enddo iqcav=iqcav/(np*mp) call topo(x,y,n,m) call metryc(x,y,z,n,m,l) c call tinit_i(z,x,y,n,m,tau,lipps) call tinit_r(z,x,y,n,m,tau,lipps) call rhsdiv(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), . o(1-ih,1-ih,1,0),rho,pfy,n,m,l,1) call rical(u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0),o(1-ih,1-ih,1,0), . th,qv,qc,0) #if (MOISTMOD > 0) if (moist.eq.1) call rhfld(th,qv,n,m,l,0,pfz) #endif #if (GKS == 1) #if (PLOTPL == 1) if(moist.gt.0) call lwcpl(th,u,v,w,qv,qc,qr,qia,qib,lipps,kf) if(kf.gt.1) call plot(th,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),p,pfy,qv,qc,qr,qia,qib, * lipps,tke,pfz) #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),o(1-ih,1-ih,1,0),th,pfx,pfy,pfz) #endif #endif #if (V5D == 1) call zbiory_v5d(th,u(1-ih,1-ih,1,0),v(1-ih,1-ih,1,0), * o(1-ih,1-ih,1,0),w(1-ih,1-ih,1,0),p,pfy,qv,qc,qr, * qia,qib,tke,pfz,n,m,l,kf) #endif endif 1000 continue #if (HP > 0 || SGI_O2K > 1) if (mype.eq.0) then if(ioptr.gt.0) then ierr = CRAYCLOSE (ifcr) print *,'Finsh raeding from tape ',ifcr endif end if #endif Cendif ANALIZE == 1 #endif C----------------- #if (GKS == 1) call clsgks #endif if (mype.eq.0) then print *,'*** ENDING TIME ***' call timefun() end if #if (PARALLEL == 2) C if (mype.eq.0) then C timeend = MPI_Wtime() C timeval = timeend - timestart C write(*,*)'wallclock time - total =',timeval,'sec' C end if call MPI_Finalize(ierr) #endif stop 'main' end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C C C C DEFINITIONS of all EULAG Subroutines and Functions: C C C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C subroutine extr11(qc,n,an,ax) dimension qc(n) an=1.e20 ax=-1.e20 do i=1,n an=min(an,qc(i)) ax=max(ax,qc(i)) enddo return end cc SDS routines: subroutine micro_set include 'aerosol1size.inc' c c MASS GRID (x) AND INTERFACE (o) STRUCTURE: c c 1 2 3 4 5 c o o o o o class boundaries c |--x--|--x--|--x--|--x--| classes c 1 2 3 4 c call chem_kin pi=4.*atan(1.) r0=1.e-8 ! 0.01 micron c r0=2.e-7 ! 0.2 micron rho_a=rho_s am0=4./3.*pi*rho_a*r0**3 do ic=1,nca mas0(ic)=am0 rad0(ic)=(3.*mas0(ic)/(4.*pi*rho_a))**(1./3.) print*,'i,rad,mass: ',ic,rad0(ic),mas0(ic) conc(ic)=200.e6 enddo sum=0. do ic=1,nca sum=sum+conc(ic)*1.e-6 enddo print*,' ---- total conc (cm**-3): ',sum return end subroutine chem_kin common /chemistry/ rho_w,amol_w,rho_s,amol_s,vanhof common /kinetic/ alpha_c,alpha_t,delta_v,delta_t cc water: amol_w=18.02 rho_w=1.e3 cc salt: c amonium sulfate: c amol_s=132.14 ! amonium sulfate c rho_s=1.77e3 c vanhof=3. c sodium chloride amol_s=56.44 ! sodium chloride rho_s=2.17e3 vanhof=2. cc kinetic coefficients: alpha_c=0.036 alpha_t=0.7 delta_v=2.16e-7 delta_t=1.04e-7 return end subroutine sd_adv(ux,uy,uz,nx,ny,nz,xp,yp,zp,npx) dimension ux(nx,ny,nz),uy(nx,ny,nz),uz(nx,ny,nz) include 'param.nml' include 'param.sds' dimension xp(npp),yp(npp),zp(npp) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 xxl=(nx-1)*dx yyl=(ny-1)*dy zzl=(nz-1)*dz c print*,'-- in sd_adv. npx,npp: ',npx,npp c print*,'-- in sd_adv. xxl,yyl,zzl: ',xxl,yyl,zzl dxh=.5*dx dyh=.5*dy dzh=.5*dz do ip=1,npx cc predictor: i=(xp(ip)+dxh)/dx + 1 i=max(1,min(i,nx)) ip1=i+1 im1=i-1 if(i.eq.nx) ip1=2 if(i.eq. 1) im1=nx-1 j=(yp(ip)+dyh)/dy + 1 j=max(1,min(j,ny)) jp1=j+1 jm1=j-1 if(j.eq.ny) jp1=2 if(j.eq. 1) jm1=ny-1 k=(zp(ip)+dzh)/dz + 1 k=max(1,min(k,nz)) kp1=k+1 km1=k-1 if(k.eq.nz) kp1=2 if(k.eq. 1) km1=nz-1 uup=.5*(ux(ip1,j,k)+ux(i,j,k)) uum=.5*(ux(im1,j,k)+ux(i,j,k)) delx=(xp(ip) + dxh - (i-1)*dx )/dx delx=max(0.,min(1.,delx)) uxc=(1.-delx)*uum + delx*uup xxf=xp(ip)+uxc*dt if(xxf.ge.xxl-dxh) xxf=xxf-xxl if(xxf.le. 0.-dxh) xxf=xxf+xxl vvp=.5*(uy(i,jp1,k)+uy(i,j,k)) vvm=.5*(uy(i,jm1,k)+uy(i,j,k)) dely=(yp(ip) + dyh - (j-1)*dy )/dy dely=max(0.,min(1.,dely)) uyc=(1.-dely)*vvm + dely*vvp yyf=yp(ip)+uyc*dt if(yyf.ge.yyl-dyh) yyf=yyf-yyl if(yyf.le. 0.-dyh) yyf=yyf+yyl wwp=.5*(uz(i,j,k)+uz(i,j,kp1)) wwm=.5*(uz(i,j,k)+uz(i,j,km1)) delz=(zp(ip) + dzh - (k-1)*dz )/dz delz=max(0.,min(1.,delz)) uzc=(1.-delz)*wwm + delz*wwp zzf=zp(ip)+uzc*dt if(zzf.ge.zzl-dzh) zzf=zzf-zzl if(zzf.le. 0.-dzh) zzf=zzf+zzl xp(ip)=xxf yp(ip)=yyf zp(ip)=zzf enddo ! do ip=1,npx return end subroutine sd_phy(th,sup,ftt,fqv,pre,nsd,xp,yp,zp,qcp,plic,radp) include 'param.nml' include 'param.sds' include 'aerosol1size.inc' dimension th(n,m,l),sup(n,m,l),pre(l),ftt(n,m,l),fqv(n,m,l) c SDs: dimension xp(npp),yp(npp),zp(npp) dimension qcp(npp),plic(npp),radp(npp) common/ctherm/ rg,cp,cap,st,gg,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/cmoist/ rv,t00,e00,hlat,hlatv,hlats,hlatf common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 ccc function describing droplet growth rate drdt(r17)=gfact/r17 1 * (supers - exp(aaa/r17-bbb/(r17**3 -rs0**3)) + 1.) t00i=1./t00 pi=4.*atan(1.) rho_w=1.e3 fact=4./3.*pi*rho_w a=rg/rv b=hlat/(rv*tt0) c=hlat/cp d=hlat/rv e=-cp/rg xxlv=hlat rho0=1. dxh=.5*dx dyh=.5*dy dzh=.5*dz do ip=1,nsd i=(xp(ip)+dxh)/dx + 1 j=(yp(ip)+dyh)/dy + 1 k=(zp(ip)+dzh)/dz + 1 i=max(1,min(n,i)) j=max(1,min(m,j)) k=max(1,min(l,k)) dupa cc no interpolation supers=sup(i,j,k) rad_o=radp(ip) temp=th(i,j,k) sigma=76.1-0.155*(temp-273.16) sigma=sigma*1.e-3 ! in N/m difvp=2.11 * (temp/273.16)**1.94 * 101325./pre(k) difvp=difvp*1.e-5 ! in m**2/s tcond=1.5e-11*temp**3 - 4.8e-8*temp**2 + 1.0e-4*temp - 3.9e-4 tcond=tcond ! in W/mK c print*,'-- in sd_phys: sigma,difvp,tcond: ',sigma,difvp,tcond rs0=rad0(1) sm0=mas0(1) r_dr=radp(ip) aaa=2*sigma/(rv*rho_w*temp) bbb=vanhof*sm0*amol_w/amol_s/(4./3.*pi*rho_w) c print*,aaa,bbb,' ---aaa,bbb' cc kinetic: coev=sqrt(2.*pi/rv/temp) coet=sqrt(2.*pi/rg/temp) coe1=r_dr/(r_dr+delta_v) + difvp/(r_dr*alpha_c)*coev difvpp=difvp / coe1 coe2=r_dr/(r_dr+delta_t) + tcond/(r_dr*alpha_t*rho0*cp)*coet tcondp=tcond / coe2 c print*,tcond,coe2,tcondp,' ---tcond,coe2,tcondp' thi=1./temp ess=e00*exp( hlat/rv * (t00i - thi)) cc termodynamic factor with kinetic effects: gfact1=rho_w*rv*temp/ess/difvpp gfact2=rho_w*hlat/tcondp/temp * (hlat/rv/temp - 1.) gfact = 1./(gfact1+gfact2) c print*,gfact1,' ---gfact1' c print*,gfact2,' ---gfact2' c print*,gfact,' ---gfact' r_old=r_dr cc do explicit, but substep if needed:: eps=0.05 rr=r_dr tt=0. it=0 100 continue it=it+1 tau=rr/abs(drdt(rr)) c print*,drdt(rr) dts=eps*tau if(tt+dts.ge.dt) dts=dt-tt ak1=dts*drdt(rr) rr = rr + ak1 tt = tt + dts if(dt-tt.lt.1.e-5) go to 701 go to 100 701 continue c print*,'== i,j,k,it,rr: ',i,j,k,it,rr r_dr=rr radp(ip)=max(0.,r_dr) qcp(ip)=fact * radp(ip)**3. *plic(ip)/rho0 dqc=fact * (radp(ip)**3.-rad_o**3.) 1 * plic(ip)/rho0 / dt fqv(i,j,k)=fqv(i,j,k)-dqc ftt(i,j,k)=ftt(i,j,k)+dqc*hlat/cp enddo ! ip loop cc apply cyclicity for forces: do j=1,n-1 do k=1,l-1 ftt(n,j,k)=ftt(1,j,k) fqv(n,j,k)=fqv(1,j,k) enddo enddo do i=1,n do k=1,l-1 ftt(i,m,k)=ftt(i,1,k) fqv(i,m,k)=fqv(i,1,k) enddo enddo do i=1,n do j=1,m ftt(i,j,l)=ftt(i,j,1) fqv(i,j,l)=fqv(i,j,1) enddo enddo return end subroutine vort(u,v,w,vrx,vry,vrz,iflg) include 'param.nml' include 'param.misc' 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) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) 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), . ugg(1-ih:np+ih, 1-ih:mp+ih, l), . vgg(1-ih:np+ih, 1-ih:mp+ih, l), . wgg(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 3) C common ug(n,m,l), vg(n,m,l), wg(n,m,l), C . ugg(n,m,l),vgg(n,m,l),wgg(n,m,l) nm=n*m ml=m*l nml=n*m*l dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi do i=1,np do j=1,mp do k=1,l ug(i,j,k)=(u(i,j,k)-iflg*ue(i,j,k))/gi(i,j) vg(i,j,k)=(v(i,j,k)-iflg*ve(i,j,k))/gi(i,j) wg(i,j,k)=w(i,j,k)/gi(i,j) ugg(i,j,k)=(u(i,j,k)-iflg*ue(i,j,k)) - . c13(i,j)*gmul(k)*w(i,j,k)/gi(i,j) vgg(i,j,k)=(v(i,j,k)-iflg*ve(i,j,k)) - . c23(i,j)*gmul(k)*w(i,j,k)/gi(i,j) wgg(i,j,k)=(c13(i,j)*gmul(k)*(v(i,j,k)-iflg*ve(i,j,k)) - . c23(i,j)*gmul(k)*(u(i,j,k)-iflg*ue(i,j,k)))/ . gi(i,j) enddo enddo enddo call update(ug,np,mp,l,np,mp) call update(vg,np,mp,l,np,mp) call update(wg,np,mp,l,np,mp) call update(ugg,np,mp,l,np,mp) call update(vgg,np,mp,l,np,mp) call update(wgg,np,mp,l,np,mp) illim = 1 + 1*leftedge iulim = np - 1*rightedge do k=1,l do j=1,mp do i=illim,iulim vry(i,j,k)= - dxil*(wg(i+1,j,k)-wg(i-1,j,k)) vrz(i,j,k)= dxil*(vg(i+1,j,k)-vg(i-1,j,k))*j3 enddo enddo enddo if (leftedge.eq.1) then do k=1,l do j=1,mp vry(1,j,k)= -((1-ibcx)*dxi*(wg(2,j,k)-wg(1 ,j,k)) . +ibcx*dxil*(wg(2,j,k)-wg(-1,j,k))) vrz(1,j,k)= ((1-ibcx)*dxi*(vg(2,j,k)-vg(1 ,j,k)) . +ibcx*dxil*(vg(2,j,k)-vg(-1,j,k)))*j3 enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp vry(np,j,k)= -((1-ibcx)*dxi*(wg(np,j,k)-wg(np-1,j,k)) . +ibcx*dxil*(wg(np+2,j,k)-wg(np-1,j,k))) vrz(np,j,k)= ((1-ibcx)*dxi*(vg(np,j,k)-vg(np-1,j,k)) . +ibcx*dxil*(vg(np+2,j,k)-vg(np-1,j,k)))*j3 enddo enddo endif if (j3.eq.1) then jllim = 1 + j3*botedge julim = mp - j3*topedge do k=1,l do j=jllim,julim do i=1,np vrx(i,j,k)= dyil*(wg(i,j+j3,k)-wg(i,j-j3,k)) vrz(i,j,k)= vrz(i,j,k) - . dyil*(ug(i,j+j3,k)-ug(i,j-j3,k)) enddo enddo enddo if (botedge.eq.1) then do k=1,l do i=1,np vrx(i,1,k)=(1-ibcy)*dyi*(wg(i,1+j3,k)-wg(i,1,k)) . + ibcy*dyil*(wg(i,1+j3,k)-wg(i,-j3,k)) vrz(i,1,k)= vrz(i,1,k) - . ((1-ibcy)*dyi*(ug(i,1+j3,k)-ug(i,1,k)) . + ibcy*dyil*(ug(i,1+j3,k)-ug(i,-j3,k))) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np vrx(i,mp,k)=(1-ibcy)*dyi*(wg(i,mp,k)-wg(i,mp-j3,k)) . + ibcy*dyil*(wg(i,mp+2,k)-wg(i,mp-j3,k)) vrz(i,mp,k)= vrz(i,mp,k) - . ((1-ibcy)*dyi*(ug(i,mp,k)-ug(i,mp-j3,k)) . + ibcy*dyil*(ug(i,mp+2,k)-ug(i,mp-j3,k))) enddo enddo end if else do i=1,np do j=1,mp do k=1,l vrx(i,j,k)=0. vrz(i,j,k)=0. enddo enddo enddo endif do k=2,l-1 do j=1,mp do i=1,np vrx(i,j,k)=vrx(i,j,k) - . dzil*(vgg(i,j,k+1)-vgg(i,j,k-1))*j3 vry(i,j,k)=vry(i,j,k) + . dzil*(ugg(i,j,k+1)-ugg(i,j,k-1)) vrz(i,j,k)=vrz(i,j,k) + . dzil*(wgg(i,j,k+1)-wgg(i,j,k-1))*j3 enddo enddo enddo do j=1,mp do i=1,np vrx(i,j,1)=vrx(i,j,1)- dzi*(vgg(i,j,2)-vgg(i,j,1))*j3 vrx(i,j,l)=vrx(i,j,l)- dzi*(vgg(i,j,l)-vgg(i,j,l-1))*j3 vry(i,j,1)=vry(i,j,1)+ dzi*(ugg(i,j,2)-ugg(i,j,1)) vry(i,j,l)=vry(i,j,l)+ dzi*(ugg(i,j,l)-ugg(i,j,l-1)) vrz(i,j,1)=vrz(i,j,1)+ dzi*(wgg(i,j,2)-wgg(i,j,1))*j3 vrz(i,j,l)=vrz(i,j,l)+ dzi*(wgg(i,j,l)-wgg(i,j,l-1))*j3 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 do k=1,l do j=1,mp do i=1,np vrx(i,j,k)=vrx(i,j,k)*gi(i,j)*dt vry(i,j,k)=vry(i,j,k)*gi(i,j)*dt vrz(i,j,k)=vrz(i,j,k)*gi(i,j)*dt enddo enddo enddo return end subroutine noisegn(ft) c fill ft with random noise include 'param.nml' include 'param.misc' include 'msg.inc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 dimension ft(1-ih:np+ih,1-ih:mp+ih,l) #if (HP > 0 || WORKS == 1 || SGI_O2K > 0 || IBM >0) 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 im=86436 ia=1093 ic=18254 iran=mype+1 cc different sets of random numbers... do iii=1,10 a=rand() c print*,a enddo do j=1,mp do i=1,np do k=1,l ft(i,j,k)=2.*(rand()-0.5) enddo end do end do #else call ranset(mype+1) do k=1,l do j=1,mp do i=1,np ia=i + (npos-1)*np x1=float(ia-1)*dx z1=float(k-1)*dz xc=float(np-1)*dx/2. zc=1200. del=0. rad=sqrt((x1-xc)**2 + (z1-zc)**2) if(rad.le.500.) del=1. ft(i,j,k)=del*2.*(ranf( )-0.5) enddo end do end do #endif call update(ft,np,mp,l,np,mp) if (rightedge.eq.1) then do k=1,l do j=1,mp ft(np,j,k)=ft(np+1,j,k) enddo enddo end if call update(ft,np,mp,l,np,mp) if (topedge.eq.1) then do k=1,l do i=1,np ft(i,mp,k)=ft(i,mp+1,k) enddo end do end if call update(ft,np,mp,l,np,mp) return end subroutine header(lipps,icorio,nt,nstore,itkes) include 'param.nml' 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/gora/ xml,yml,amp,xml0,yml0 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/davies/ zab,towx,towy,towz,nrx,nry,relx(n),rely(m), 1 iab,iabth,iabqw common/stresd/ ivis,irid,itstr,noutp,diagstr(8) character*80 title c eps=1.e-15 write (6,999) #if (GKS == 1) ipt1=int(192.8+819.2)-50 call sflush call set(0.1,0.9,0.1,0.9,0.,1.,0.,1.,1) call gstxci(1) call gsplci(1) call pcsetc('FC - FUNCTION CODE CHARACTER','?') #endif c if((abs(u0z).lt.eps).and.(abs(v0z).le.eps)) then ri00=0. write (6,899) #if (GKS == 1) write (title,899) call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif else ri00 = g*st/(u0z**2 + v0z**2) write (6,900) ri00 #if (GKS == 1) write (title,900) ri00 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif endif c write (6,901) n,m,l,ior #if (GKS == 1) write (title,901) n,m,L,ior ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif write (6,902) dx,dy,dz,dt #if (GKS == 1) write (title,902) dx,dy,dz,dt ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif write (6,903) lagr,nt,nstore #if (GKS == 1) write (title,903) lagr,nt,nstore ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif write (6,904) ibcx,ibcy,ibcz,irlx,irly #if (GKS == 1) write (title,904) ibcx,ibcy,ibcz,irlx,irly ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif write (6,905) iab,iabth,iabqw #if (GKS == 1) write (title,905) iab,iabth,iabqw ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif write (6,906) zab,towz #if (GKS == 1) write (title,906) zab,towz ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif write (6,908) towx,towy,nrx,nry #if (GKS == 1) write (title,908) towx,towy,nrx,nry ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif c if((abs(u0z).lt.eps).and.(abs(v0z).le.eps)) then write (6,929) u00,v00 #if (GKS == 1) write (title,929) u00,v00 ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif else write (6,909) u00,u0z #if (GKS == 1) write (title,909) u00,u0z ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif write (6,919) v00,v0z #if (GKS == 1) write (title,919) v00,v0z ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif endif c bv=sqrt(st*g) write (6,910) bv,lipps #if (GKS == 1) write (title,910) bv,lipps ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif write (6,911) xml,yml,amp write (6,9111) xml0,yml0 #if (GKS == 1) write (title,911) xml,yml,amp ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) write (title,9111) xml0,yml0 ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif write (6,912) moist,ice,iceab #if (GKS == 1) write (title,912) moist,ice,iceab ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) #endif write (6,913) icorio,ivis,itkes #if (GKS == 1) write (title,913) icorio,ivis,itkes ipt1=ipt1-50 call plchhq(cpux(12),cpuy(ipt1),title(1:80),0.015,0.,-1.) call frame #endif 899 format(1x,'Ri0 = infinity') 900 format(1x,'Ri0 =',e11.4) 901 format(1x,'n,m,L,ior =',4i4) 902 format(1x,'dx,dy,dz,dt =',4e11.4) 903 format(1x,'lagr =',i3,' nt,nstore=',2i5) 904 format(1x,'ibcx,ibcy,ibcz,irlx,irly=',5i4) 905 format(1x,'iab,iabth,iabqw =',3i4) 906 format(1x,'zab,towz =',2e11.4) 908 format(1x,'towx,towy =',2e11.4,' nrx,nry =',2i4) 909 format(1x,'Const shear profile: U00,U00Z =',2e11.4) 919 format(1x,'Const shear profile: V00,V00Z =',2e11.4) 929 format(1x,'Const wind profile: U00,V00 =',2e11.4) 910 format(1x,'Const stability profile: N =',e11.4,' lipps =',i3) 911 format(1x,'mountain scales Lx,Ly,h0 =',3e11.4) 9111 format(1x,'mountain scales Lxc,Lyc=',2e11.4) 912 format(1x,'moist,ice,iceab =',3i3) 913 format(1x,'icorio,ivis,itke =',3i3) 999 format(1x,' ') write (6,999) return end #if (ANALIZE == 0) subroutine advec(xf,xd1,xd2,xd3,iflg,ifirst) include 'param.nml' include 'param.misc' include 'msg.inc' 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), . dv(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 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) if(lagr.eq.1) then #if (SEMILAG == 1) if(j3.eq.1) then #if (J3DIM == 1) call inter3(xf,xd1,xd2,xd3,ux,uy,uz,ifirst) #endif else #if (J3DIM == 0) call inter2(xf,xd1,xd3,ux,uy,ifirst) #endif endif #endif else #if (SEMILAG == 0) if(j3.eq.1) then #if (J3DIM == 1) if(iflg.ge.2.and.iflg.le.5) then call mpdatm3(xd1,xd2,xd3,xf,rho,iflg,ux,uy,uz,vx) !default c call mpdata3(xd1,xd2,xd3,xf,rho,iflg,ux,uy,uz,vx) else c call mpdatm3(xd1,xd2,xd3,xf,rho,iflg,ux,uy,uz,vx) call mpdata3(xd1,xd2,xd3,xf,rho,iflg,ux,uy,uz,vx) !default endif #endif else #if (J3DIM == 0) if(iflg.ge.2.and.iflg.le.5) then call mpdatm2(xd1,xd3,xf,rho,iflg,ux,uy,uz,vx) c call mpdata2(xd1,xd3,xf,rho,iflg,ux,uy,uz,vx) else c call mpdatm2(xd1,xd3,xf,rho,iflg,ux,uy,uz,vx) call mpdata2(xd1,xd3,xf,rho,iflg,ux,uy,uz,vx) endif #endif endif #endif call updatelr(xf,np,mp,l,np,mp) if (rightedge.eq.1) then do k=1,l do j=1,mp xf(np,j,k)=xf(np+1,j,k) enddo enddo end if call updatebt(xf,np,mp,l,np,mp) if (topedge.eq.1) then do k=1,l do i=1,np xf(i,mp,k)=xf(i,mp+1,k) enddo end do end if call update(xf,np,mp,l,np,mp) endif return end Cendif ANALIZE == 0 #endif subroutine ckcyc(a,n1,m1,l1,iflg) include 'param.nml' include 'param.misc' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly dimension temp(1-ih:np+ih, 1-ih:mp+ih, l) dimension a(1-ih:np+ih, 1-ih:mp+ih, l) real globmax,globmin call update(a,np,mp,l,np,mp) if(ibcx.eq.1) then cmx=-1.e15 cmn= 1.e15 do k=1,l do j=1,mp do i=1,np temp(i,j,k)=cmx end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp temp(np,j,k)=(a(np,j,k) - a(np+1,j,k)) end do end do end if cmx=max(globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . cmx) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=cmn end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp temp(np,j,k)=(a(np,j,k) - a(np+1,j,k)) end do end do end if cmn=min(globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . 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 100,cmx,cmn 100 format(12x,'ibcx periodicity check; dmx, dmn=',2e11.4) endif end if endif if(ibcy.eq.1) then cmx=-1.e15 cmn= 1.e15 do k=1,l do j=1,mp do i=1,np temp(i,j,k)=cmx end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np temp(i,mp,k) = (a(i,mp+1,k) - a(i,mp,k)) end do end do end if cmx=max(globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . cmx) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=cmn end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np temp(i,mp,k) = (a(i,mp+1,k) - a(i,mp,k)) end do end do end if cmn=min(globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . 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 200,cmx,cmn 200 format(12x,'ibcy periodicity check; dmx, dmn=',2e11.4) endif end if endif if(ibcz.eq.1) then cmx=-1.e15 cmn= 1.e15 do k=1,l do j=1,mp do i=1,np temp(i,j,k)=cmx end do end do end do do j=1,mp do i=1,np temp(i,j,l)=(a(i,j,l) - a(i,j,1)) end do end do cmx=max(globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . cmx) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=cmn end do end do end do do i=1,np do j=1,mp temp(i,j,l)=(a(i,j,l) - a(i,j,1)) end do end do cmn=min(globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . 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 end if endif return end subroutine cndinst include 'param.nml' include 'param.misc' include 'msg.inc' common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u0,v0,u0z,v0z common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf 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) 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) indx=1 if(x.le.x0) indx=-1 x0=x if (mype.eq.0) then if(indx.eq.-1) print 100, x,k,indx 100 format(2x,'thetae, k, indx:', e11.4, 2i4) end if 1 continue return end subroutine diagnos(u,v,w,th,p,x,y,z,rho,rh,div, * ww,thsum0,n1,m1,l1,g1,g2,g3,tt,tend,moist1,qv,qc,qr, * qia,qib,qws0,drgx,drgy) include 'param.nml' include 'param.misc' include 'msg.inc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/itero/ niter,nitsm,icount,miter,mitsm,jcount common/radbcdg/ cx1avg,cxnavg,cy1avg,cymavg common/vbcdg/ uinf,vinf,oinf,uout,vout,oout,tflx,epsim,epsia common/stresd/ ivis,irid,itstr,noutp, * primx,primn,priav,prisd, * kmmx,kmmn,kmav,kmsd 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, 6) common/strese/ rimx,rimn,riav,risd, * stmx,stmn,stav,stsd, * dfmx,dfmn,dfav,dfsd common/dragc/ drgnorm, itd real kmmx,kmmn,kmav,kmsd data ifirst/0/ 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), . 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), . rh(1-ih:np+ih, 1-ih:mp+ih, l), . div(1-ih:np+ih, 1-ih:mp+ih, l), . ww(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) dimension qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic) dimension temp(1-ih:np+ih, 1-ih:mp+ih, l) real gacmxt(1-ih:1+ih, 1-ih:1+ih, 1), . gacmnt(1-ih:1+ih, 1-ih:1+ih, 1), . gacavt(1-ih:1+ih, 1-ih:1+ih, 1), . gacsdt(1-ih:1+ih, 1-ih:1+ih, 1) real globmax,globmin,globsum 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 call update(u,np,mp,l,np,mp) call update(v,np,mp,l,np,mp) call update(w,np,mp,l,np,mp) eer=0. eem=0. check lipshitz and courant numbers call lipsch(u,v,w,rho,n,m,l,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 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(ww,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) wmn=min(wmn,globmin(ww,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)) tmx=max(tmx,globmax(th,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) tmn=min(tmn,globmin(th,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) pmx=pmx*2.*dti pmn=pmn*2.*dti if (mype.eq.0) then print 201,umx,umn,vmx,vmn,wmx,wmn,pmx,pmn,tmx,tmn 201 format(1x,'umax, umin:',2e11.4/ 2 1x,'vmax, vmin:',2e11.4/ 3 1x,'wmax, wmin:',2e11.4/ 4 1x,'pmax, pmin:',2e11.4/ 5 1x,'thmx, thmn:',2e11.4) end if c mype=my_pe()+1 if(lagr.eq.1) then call update(x,np,mp,l,np,mp) call update(y,np,mp,l,np,mp) call update(z,np,mp,l,np,mp) check lagrangian jacobian gacmx=-1.e15 gacmn= 1.e15 gacav=0. gacsd=0. gacmxt(1,1,1)=-1.e15 gacmnt(1,1,1)= 1.e15 gacavt(1,1,1)=0. gacsdt(1,1,1)=0. if(j3.eq.1) then jllim=1 +j3*botedge julim=mp-j3*topedge illim=1 +leftedge iulim=np-rightedge 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(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) gac=.125*( dxx*dyy*dzz+dxy*dyz*dzx+dxz*dyx*dzy 1 -dzx*dyy*dxz-dzx*dyz*dxx-dzz*dyx*dxy )*rh(i,j,k)/rho(i,j,k) gacmxt(1,1,1)=amax1(gacmxt(1,1,1),gac) gacmnt(1,1,1)=amin1(gacmnt(1,1,1),gac) gacavt(1,1,1)=gacavt(1,1,1)+gac gacsdt(1,1,1)=gacsdt(1,1,1)+(gac-1.)**2 c gacmxt=amax1(gacmxt(mype),gac) c gacmnt(mype)=amin1(gacmnt(mype),gac) c gacavt(mype)=gacavt(mype)+gac c gacsdt(mype)=gacsdt(mype)+(gac-1.)**2 3 continue gacmx=max(gacmx,globmax(gacmxt,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1, . 1,1)) gacmn=min(gacmn,globmin(gacmnt,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1, . 1,1)) gacav=globsum(gacavt,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1,1,1) gacsd=globsum(gacsdt,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1,1,1) else 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 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(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) gac=.25*(dxx*dzz-dzx*dxz)*rh(i,1,k)/rho(i,1,k) gacmxt(1,1,1)=amax1(gacmxt(1,1,1),gac) gacmnt(1,1,1)=amin1(gacmnt(1,1,1),gac) gacavt(1,1,1)=gacavt(1,1,1)+gac gacsdt(1,1,1)=gacsdt(1,1,1)+(gac-1.)**2 31 continue gacmx=max(gacmx,globmax(gacmxt,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1, . 1,1)) gacmn=min(gacmn,globmin(gacmnt,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1, . 1,1)) gacav=globsum(gacavt,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1,1,1) gacsd=globsum(gacsdt,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1,1,1) endif 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. do k=1,l do j=1,mp do i=1,np temp(i,j,k)=divmx end do end do end do 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 do k=1+igrid,l do j=jllim,mp do i=illim,np temp(i,j,k)=div(i,j,k) end do end do end do divmx=max(divmx,globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,illim,np, . jllim,mp,1+igrid,l)) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=divmn end do end do end do do k=1+igrid,l do j=jllim,mp do i=illim,np temp(i,j,k)=div(i,j,k) end do end do end do divmn=min(divmn,globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,illim,np, . jllim,mp,1+igrid,l)) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=0.0 end do end do end do do k=1+igrid,l do j=jllim,mp do i=illim,np temp(i,j,k)=div(i,j,k) end do end do end do divav=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,illim,np,jllim,mp, . 1+igrid,l) divav=divav*xnorm do k=1+igrid,l do j=jllim,mp do i=illim,np temp(i,j,k)=(div(i,j,k)-divav)**2 end do end do end do divsd=0. divsd=globsum(temp,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,niter,nitav,miter,mitav 205 format(1x,'dvmx,dvmn,dvav,dvsd:',4e11.4/ 1 1x,'niter,nitav,miter,mitav:',4i4) end if check integrability condition for time-dependent bottom 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) 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)/ . float(nml) 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)/ . float(nml) 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)/ . float(nml) risd=0. stsd=0. dfsd=0. do k=1,l do j=1,mp do i=1,np temp(i,j,k)=(ri(i,j,k)-riav)**2 end do end do end do risd = sqrt(globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) . /float(nml-1)) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=(stab(i,j,k)-stav)**2 end do end do end do stsd = sqrt(globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) . /float(nml-1)) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=(defsq(i,j,k)-dfav)**2 end do end do end do dfsd = sqrt(globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) . /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 c 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) then print 2062, drgx,drgy,drgnorm 2062 format(1x,'drgx, drgy, drgnorm:',3e11.4) end if check boundary velocities do 7 k=1,l,l-1 ommx=-1.e15 ommn= 1.e15 ommx=max(ommx,globmax(w,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,k,k)) ommn=min(ommn,globmin(w,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,k,k)) if (mype.eq.0) then print 207,k,ommx,ommn end if 7 continue 207 format(1x,'k,ommx,ommn:',i5,2e11.4) ummx=-1.e15 ummn= 1.e15 do k=1,l do j=1,mp do i=1,np temp(i,j,k)=ummx end do end do end do if (leftedge.eq.1) then do k=1,l do j=1,mp temp(1,j,k)=u(1,j,k) end do end do end if ummx=max(ummx,globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,1,1,mp, . 1,l)) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=ummn end do end do end do if (leftedge.eq.1) then do k=1,l do j=1,mp temp(1,j,k)=u(1,j,k) end do end do end if ummn=min(ummn,globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,1,1,mp, . 1,l)) i=1 if (mype.eq.0) then print 208,i,ummx,ummn end if #if (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else call mybarrier() #endif ummx=-1.e15 ummn= 1.e15 do k=1,l do j=1,mp do i=1,np temp(i,j,k)=ummx end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp temp(np,j,k)=u(np,j,k) end do end do end if ummx=max(ummx,globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,np,np, . 1,mp,1,l)) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=ummn end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp temp(np,j,k)=u(np,j,k) end do end do end if ummn=min(ummn,globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,np,np, . 1,mp,1,l)) if (mype.eq.0) then i=n print 208,i,ummx,ummn end if #if (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else call mybarrier() #endif 208 format(1x,'i,ummx,ummn:',i5,2e11.4) vmmx=-1.e15 vmmn= 1.e15 do k=1,l do j=1,mp do i=1,np temp(i,j,k)=vmmx end do end do end do if (botedge.eq.1) then do k=1,l do i=1,np temp(i,1,k)=v(i,1,k) end do end do end if vmmx=max(vmmx,globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,1, . 1,l)) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=vmmn end do end do end do if (botedge.eq.1) then do k=1,l do i=1,np temp(i,1,k)=v(i,1,k) end do end do end if vmmn=min(vmmn,globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,1, . 1,l)) if (mype.eq.0) then j=1 print 209,j,vmmx,vmmn end if 209 format(1x,'j,vmmx,vmmn:',i5,2e11.4) if (j3.eq.1) then vmmx=-1.e15 vmmn= 1.e15 do k=1,l do j=1,mp do i=1,np temp(i,j,k)=vmmx end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np temp(i,mp,k)=v(i,mp,k) end do end do end if vmmx=max(vmmx,globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np, . mp,mp,1,l)) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=vmmn end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np temp(i,mp,k)=v(i,mp,k) end do end do end if vmmn=min(vmmn,globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np, . mp,mp,1,l)) if (mype.eq.0) then j=m print 209,j,vmmx,vmmn end if end if cyclicity check if(ibcx+ibcy.ne.0) then call ckcyc( u,n,m,l,1) call ckcyc( v,n,m,l,2) call ckcyc( w,n,m,l,3) ccc call ckcyc( p,n,m,l,4) call ckcyc(th,n,m,l,5) endif #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 qvmx=max(qvmx,globmax(qv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qvmn=min(qvmn,globmin(qv,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qcmx=max(qcmx,globmax(qc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qcmn=min(qcmn,globmin(qc,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qrmx=max(qrmx,globmax(qr,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) qrmn=min(qrmn,globmin(qr,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=rho(i,j,k)*(qv(i,j,k)+qc(i,j,k)+qr(i,j,k)) end do end do end do c call rhfld(th,qv,n,m,l,1,temp) call rhfld(th,qv,n,m,l,1,ww) if (mype.eq.0) then print 301,qvmx,qvmn,qcmx,qcmn,qrmx,qrmn end if 301 format(1x,'qvmx, qvmn:',2e11.4/ 1 1x,'qcmx, qcmn:',2e11.4/ 2 1x,'qrmx, qrmn:',2e11.4) if(ibcx+ibcy.ne.0) then call ckcyc(qv,n,m,l,6) call ckcyc(qc,n,m,l,7) call ckcyc(qr,n,m,l,8) endif endif #if (MOISTMOD == 2) if(iceab.eq.1) then qamx=-1.e15 qamn= 1.e15 qbmx=-1.e15 qbmn= 1.e15 qtot=0. qamx1=globmax(qia,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) qamn1=globmin(qia,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) qbmx1=globmax(qib,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) qbmn1=globmin(qib,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) qamx=max(qamx,qamx1) qamn=min(qamn,qamn1) qbmx=max(qbmx,qbmx1) qbmn=min(qbmn,qbmn1) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=temp(i,j,k)+(qia(i,j,k)+qib(i,j,k))*rho(i,j,k) end do end do end do if (mype.eq.0) then print 701,qamx,qamn,qbmx,qbmn 701 format(1x,'qiamx, qiamn:',2e11.4/ 1 1x,'qibmx, qibmn:',2e11.4) endif if(ibcx+ibcy.ne.0) then call ckcyc(qia,n,m,l,10) call ckcyc(qib,n,m,l,11) endif endif #endif qtot=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) qtot1=(qtot-qws0)/qws0 * 100. if (mype.eq.0) then print *,'total water: initial present perc. change' print 751,qws0,qtot,qtot1 751 format(11x,f11.3,1x,f11.3,4x,e11.4) endif #endif call sumcns(th,th,rho,n,m,l,tsm,0) tsm1=(tsm-thsum0)/thsum0 * 100. if (mype.eq.0) then print *,'total temp: initial present perc. change' print 752,thsum0,tsm,tsm1 752 format(12x,e11.4,2x,e11.4,2x,e11.4) endif return end #if (ANALIZE == 0) subroutine coef0(c33,ep,c,fc,fd,n1,n2,n3) include 'param.nml' include 'param.misc' include 'msg.inc' dimension c33(1-ih:np+ih, 1-ih:mp+ih, l), . ep(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) 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) do k=1,l do j=1,mp do i=1,np ep(i,j,k)=c(i,j,k)/(1.+fc(i,j,k)**2+fd(i,j,k)**2)*rho(i,j,k) c33(i,j,k)= (c13(i,j)*gmul(k))**2 . +(1.+fd(i,j,k)**2)*(c23(i,j)*gmul(k))**2 . +2.*fc(i,j,k)*fd(i,j,k)*gi(i,j)*c23(i,j)*gmul(k) . +(1.+fc(i,j,k)**2)*gi(i,j)**2 end do end do end do return end Cendif ANALIZE == 0 #endif subroutine drag (p,fx,fy,n1,m1,l1,pe) include 'param.nml' include 'param.misc' include 'msg.inc' dimension 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u0,v0,u0z,v0z common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/dragc/ drgnorm, itd common/indx/ e1,e2,e3 dimension p(1-ih:np+ih, 1-ih:mp+ih, l), . pe(1-ih:np+ih, 1-ih:mp+ih, l) dimension temp(1-ih:np+ih, 1-ih:mp+ih) real globsum call update(rho,np,mp,l,np,mp) call update(zs, np,mp,1,np,mp) call update(gi, np,mp,1,np,mp) dxil=.5*dxi dyil=.5*dyi nm=n*m nml=n*m*l do k=1,l do j=1,mp do i=1,np pe(i,j,k)=p(i,j,k) enddo end do end do construct perturbation pressure along the lower boundary for igrid=1 if (igrid.eq.1) then illim=1 + 1*leftedge jllim=1 + j3*botedge do j=jllim,mp do i=illim,np plex=e1*pe(i,j,2)+e2*pe(i,j,3)+e3*pe(i,j,4) pe(i,j,1)=plex enddo enddo endif calculate perturbation pressure if (igrid.eq.0) then 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 end do else illim=1 + 1*leftedge jllim=1 + j3*botedge do j=jllim,mp do i=illim,np 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)=pe(i,j,1)*rhoav*2.*dti enddo enddo endif fx(itd)=0. fy(itd)=0. if (igrid.eq.0) then do j=1,mp do i=1,np temp(i,j)=0.0 end do end do illim=1 + 1*leftedge iulim=np - 1*rightedge jllim=1 + j3*botedge julim=mp - j3*topedge do j=jllim,julim do i=illim,iulim temp(i,j)=(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,1,1,np,1,mp,1,1) if (j3.eq.1) then do j=1,mp do i=1,np temp(i,j)=0.0 end do end do illim=1 + 1*leftedge iulim=np - 1*rightedge jllim=1 + j3*botedge julim=mp - j3*topedge do j=jllim,julim do i=illim,iulim temp(i,j)=(zs(i,j+1)-zs(i,j-1))*pe(i,j,1)*dyil end do end do fy(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1) end if else illim = 1 + leftedge iulim = np jllim = 1 + j3*botedge julim = mp do j=1,mp do i=1,np temp(i,j)=0.0 end do end do do i=illim,iulim do j=jllim,julim temp(i,j) = (pe(i,j,1)*dxil*(zs(i,j)-zs(i-1,j)+ . zs(i,j-1)-zs(i-1,j-1))) end do end do fx(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp,1,1) if (j3.eq.1) then do j=1,mp do i=1,np temp(i,j)=0.0 end do end do do i=illim,iulim do j=jllim,julim temp(i,j)=(pe(i,j,1)*dyil*(zs(i,j)-zs(i,j-1)+ . zs(i-1,j)-zs(i-1,j-1))) end do end do fy(itd)=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,1,1,np,1,mp, . 1,1) end if endif fx(itd)=fx(itd)*dx*dy/drgnorm fy(itd)=fy(itd)*dx*dy/drgnorm call update(pe,np,mp,l,np,mp) return end subroutine filstr(a,n1,n2,n3) include 'param.nml' include 'param.misc' include 'msg.inc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly dimension a(1-ih:np+ih, 1-ih:mp+ih, l) dimension sx(np), sy(mp+1), sz(l) call update(a,np,mp,l,np,mp) illim = 1 + 1*leftedge iulim = np - 1*rightedge 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 (leftedge.eq.1) then sx(1)=ibcx*0.25*(a(2,j,k)+2.*a(1,j,k)+a(-1,j,k)) . +(1-ibcx)*a(1,j,k) end if if (rightedge.eq.1) then temp=ibcx*0.25*(a(np+2,j,k)+2.*a(np+1,j,k)+a(np-1,j,k)) . +(1-ibcx)*a(np+1,j,k) sx(np)=ibcx*temp+(1-ibcx)*a(np,j,k) end if do i=1,np a(i,j,k)=sx(i) enddo enddo enddo call update(a,np,mp,l,np,mp) cold do k=1,l cold do j=1,m cold do i=2,n-1 cold sx(i)=0.25*(a(i+1,j,k)+2.*a(i,j,k)+a(i-1,j,k)) cold enddo cold sx(1)=ibcx*0.25*(a(2,j,k)+2.*a(1,j,k)+a(n-1,j,k)) cold . +(1-ibcx)*a(1,j,k) cold sx(n)=ibcx*sx(1)+(1-ibcx)*a(n,j,k) cold do i=1,n cold a(i,j,k)=sx(i) cold enddo cold enddo cold enddo if(j3.eq.1) then jllim=1 + j3*botedge julim=mp - j3*topedge 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 (botedge.eq.1) then sy(1)=ibcy*0.25*(a(i,1+j3,k)+2.*a(i,1,k)+a(i,-j3,k)) . +(1-ibcy)*a(i,1,k) end if if (topedge.eq.1) then temp=ibcy*0.25*(a(i,mp+1+j3,k)+2.*a(i,mp+1,k)+ . a(i,mp-j3,k)) +(1-ibcy)*a(i,mp+1,k) sy(mp)=ibcy*temp+(1-ibcy)*a(i,mp,k) end if do j=1,mp a(i,j,k)=sy(j) enddo enddo enddo endif call update(a,np,mp,l,np,mp) 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) return end #if (ANALIZE == 0) subroutine galin(a,n1,m1,l1,del) include 'param.nml' include 'param.misc' include 'msg.inc' dimension a(1-ih:np+ih, 1-ih:mp+ih, l) 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) return end subroutine gcrk(p,pfx,pfy,pfz,u,v,w,c,fc,fd,n1,n2,n3, . itr,eps0,inner,r,qr,ar) include 'param.nml' include 'param.misc' include 'msg.inc' dimension p(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), . 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), . r(1-ih:np+ih, 1-ih:mp+ih, l), . qr(1-ih:np+ih, 1-ih:mp+ih, l), . ar(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 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/itero/ niter,nitsm,icount,miter,mitsm,jcount c scr0 to scr2 are occupied by r,qr,ar; c scr3 and scr4 will be used locally for cf33 and cf00 common/blank/ scr0(1-ih:np+ih,1-ih:mp+ih,l), . scr1(1-ih:np+ih,1-ih:mp+ih,l), . scr2(1-ih:np+ih,1-ih:mp+ih,l), . scr3(1-ih:np+ih,1-ih:mp+ih,l), . scr4(1-ih:np+ih,1-ih:mp+ih,l), . scr5(1-ih:np+ih,1-ih:mp+ih,l), . scr6(1-ih:np+ih,1-ih:mp+ih,l), . scr7(1-ih:np+ih,1-ih:mp+ih,l), . scr8(1-ih:np+ih,1-ih:mp+ih,l), . scr9(1-ih:np+ih,1-ih:mp+ih,l) dimension cf33(1-ih:np+ih, 1-ih:mp+ih, l), . cf00(1-ih:np+ih, 1-ih:mp+ih, l) equivalence (cf33,scr3), (cf00,scr4) parameter (lord=1) dimension ax2(lord),axar(lord),del(lord) dimension x(1-ih:np+ih, 1-ih:mp+ih, l, lord), . ax(1-ih:np+ih, 1-ih:mp+ih, l, lord) real globmax,globsum convergence test modes ************************************************** c parameter (nplt=100) * c dimension err(0:nplt),xitr(0:nplt) * c itr=3000/lord * c ner=30 * c snorm=1./float(n*m*l) * c eps0=1.e-15 * convergence test modes ************************************************** eps=eps0*dti nml=n1*n2*n3 epa=1.e-30 nlc=0 itmn=5 iprc=1 if(ibcz.eq.1) iprc=0 if(igrid.eq.1) iprc=0 call coef0(cf33,cf00,c,fc,fd,n1,n2,n3) call precon(r,qr,ar,pfx,pfy,pfz,cf00,cf33,fd,iprc,n1,n2,n3, . scr6,scr7,scr8,scr9,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,n1,n2,n3,scr7,scr8,scr9) call rhsdiv(pfx,pfy,pfz,rho,r,n1,n2,n3,-1) call precon(r,qr,ar,pfx,pfy,pfz,cf00,cf33,fd,iprc,n1,n2,n3, . scr6,scr7,scr8,scr9,1) convergence test modes ************************************************** c eer=-1.e15 * cc do 3 k=1,nml * cc 3 eer=amax1(eer,abs(r(k))) * c eer=globmax(abs(r),1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) * c err(0)=eer * c if (mype.eq.0) then * c print 300, err(0) * c 300 format(4x,e11.4,' residual error at it=1') * c endif * convergence test modes ************************************************** do k1=1,l do j1=1,mp do i1=1,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, . c,fc,fd,n1,n2,n3,cf33,cf00,scr7,scr8,scr9) do 100 it=1,itr c print *,'Iteration:',it do i=1,lord ax2(i)=0. rax=0. do kk=1,l do jj=1,mp do ii=1,np scr9(ii,jj,kk)=r(ii,jj,kk)*ax(ii,jj,kk,i) end do end do end do rax = globsum(scr9,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) do kk=1,l do jj=1,mp do ii=1,np scr9(ii,jj,kk)=ax(ii,jj,kk,i)**2 end do end do end do ax2(i) = globsum(scr9,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) ax2(i)=amax1(epa,ax2(i)) beta=-rax/ax2(i) dvmx=-1.e15 c call mybarrier() do k1=1,l do j1=1,mp do i1=1,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) enddo end do end do do k1=1,l do j1=1,mp do i1=1,np scr9(i1,j1,k1)=abs(r(i1,j1,k1)) end do end do end do dvmx=max(globmax(scr9,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l), . dvmx) c print *,'eps,dvmx',eps,dvmx if(dvmx.le.eps.and.it.ge.itmn) go to 200 call precon(r,qr,ar,pfx,pfy,pfz,cf00,cf33,fd,iprc,n1,n2,n3, . scr6,scr7,scr8,scr9,1) call laplc(qr,ar,pfx,pfy,pfz,c,fc,fd,n1,n2,n3, . cf33,cf00,scr7,scr8,scr9) nlc=nlc+1 do ii=1,i axar(ii)=0. do k1=1,l do j1=1,mp do i1=1,np scr9(i1,j1,k1)=ax(i1,j1,k1,ii)*ar(i1,j1,k1) end do end do end do axar(ii) = globsum(scr9,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp, . 1,l) del(ii)=-axar(ii)/ax2(ii) c del(ii)=amax1(del(ii),0.5) enddo if(i.lt.lord) then do k1=1,l do j1=1,mp do i1=1,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=1,l do j1=1,mp do i1=1,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=1,l do j1=1,mp do i1=1,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=1,l do j1=1,mp do i1=1,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 ************************************************** c if(nlc/ner*ner.eq.nlc) then * c ier=nlc/ner * c eer=-1.e15 * cc do 50 k=1,nml * cc 50 eer=amax1(eer,abs(r(k))) * c eer=globmax(abs(r),1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) * c err(ier)=eer * c endif * convergence test modes ************************************************** enddo 100 continue 200 continue if(inner.eq.0) then niter=nlc nitsm=nitsm+niter icount=icount+1 else miter=nlc mitsm=mitsm+miter jcount=jcount+1 endif convergence test modes ************************************************** c if (mype.eq.0) then * c print 301, (err(ier),ier=1,nplt,1) * c 301 format(4x,5e11.4) * c do 400 ier=0,nplt * c xitr(ier)=ier*ner * c 400 err(ier)=alog10(err(ier)*dt ) * c plmx=float(itr*lord) * c call set(.1,.9,.1,.9,0.,plmx,-10.,0.,1) * c call labmod('(i4)','(f5.0)',4,4,2,2,20,20,0) * c call periml(4,10,5,2) * c call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) * c call curved(xitr,err,nplt+1) * c i1=int(102.4+409.6) * c call plchhq(cpux(i1),cpuy(50),'niter',0.015,0.,0.) * c call plchhq(cpux(17),cpuy(i1),'log e',0.015,90.,0.) * c call frame * c endif * convergence test modes ************************************************** return end Cendif ANALIZE == 0 #endif subroutine integz(a,b,n1,n2,n3) include 'param.nml' include 'param.misc' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly dimension a(1-ih:np+ih, 1-ih:mp+ih, l), . b(1-ih:np+ih, 1-ih:mp+ih, l) nm=n1*n2 nml=n1*n2*n3 do k=2,n3-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 end do 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,n3)=0.5*(a(i,j,n3)+a(i,j,n3-1)) enddo end do 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,n3-1)) b(i,j,n3)=0.25*(a(i,j,2)+2.*a(i,j,1)+a(i,j,n3-1)) enddo enddo endif do k=1,n3 do j=1,mp do i=1,np a(i,j,k)=b(i,j,k) enddo end do end do call update(a,np,mp,l,np,mp) call update(b,np,mp,l,np,mp) return end #if (ANALIZE == 0) #if (SEMILAG == 1) subroutine interp(xf,xd1,xd2,xd3,ifirst) include 'param.nml' include 'param.misc' 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) 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), . dv(1-ih:np+ih,1-ih:mp+ih,l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 if(j3.eq.1) then #if (J3DIM == 1) call inter3(xf,xd1,xd2,xd3,ux,uy,uz,ifirst) #endif else #if (J3DIM == 0) call inter2(xf,xd1,xd3,ux,uy,ifirst) #endif endif return end #if (J3DIM == 0) subroutine inter2(xf,xd1,xd2,ig0,jg0,ifirst) c ior=order of accuracy/2; only even order trmback schemes are considered include 'param.ior' parameter(nonos=1) common/mpfil/ liner,mpfl,ampd include 'param.nml' include 'param.misc' 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), . ig0(1-ih:np+ih,1-ih:mp+ih,l), . jg0(1-ih:np+ih,1-ih:mp+ih,l) c parameter (n1=1,n2=1,nn=100) parameter (n1=n,n2=l,nn=n1*n2) data ep/ 1.e-10/ real mx,mn common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly dimension z(1-ih:np+ih, 1-ih:mp+ih, l, -ior:ior), . x(1-ior-ihlag:np+ior+ihlag, 1-ior-ihlag:mp+ior+ihlag, . 1-ior:n2+ior) #if (PARALLEL>0) common /slag/ iloc(np,mp,l,-ior:ior),jloc(np,mp,l,-ior:ior) #endif 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 call updatelagr(x,np,mp,(n2+2*ior),np,mp) 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 call updatelagr(x,np,mp,(n2+2*ior),np,mp) 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 call updatelagr(x,np,mp,(n2+2*ior),np,mp) 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 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,-2)=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,2)=il ym2=x(iloc(ii,1,jj,-2),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,+2),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,-2)=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,2)=il ym2=x(iloc(ii,1,jj,-2),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,+2),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 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,-3)=il ia=ig0(ii,1,jj)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-2)=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,2)=il ia=ig0(ii,1,jj)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,3)=il ym3=x(iloc(ii,1,jj,-3),1,jg0(ii,1,jj)+j) ym2=x(iloc(ii,1,jj,-2),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,+2),1,jg0(ii,1,jj)+j) yp3=x(iloc(ii,1,jj,+3),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,-3)=il ia=ig0(ii,1,jj)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,-2)=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,2)=il ia=ig0(ii,1,jj)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,1,jj,3)=il ym3=x(iloc(ii,1,jj,-3),1,jg0(ii,1,jj)+j) ym2=x(iloc(ii,1,jj,-2),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,+2),1,jg0(ii,1,jj)+j) yp3=x(iloc(ii,1,jj,+2),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) 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,-2),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,2),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,-2),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,2),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,-3),z(ii,1,jj,-2),z(ii,1,jj,-1),z(ii,1,jj,0), 1 z(ii,1,jj, 1),z(ii,1,jj, 2),u) f1=tr6(z(ii,1,jj,-2),z(ii,1,jj,-1),z(ii,1,jj, 0),z(ii,1,jj,1), 1 z(ii,1,jj, 2),z(ii,1,jj, 3),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,-3),z(ii,1,jj,-2),z(ii,1,jj,-1),z(ii,1,jj,0), 1 z(ii,1,jj, 1),z(ii,1,jj, 2),u) f1=tr6(z(ii,1,jj,-2),z(ii,1,jj,-1),z(ii,1,jj, 0),z(ii,1,jj,1), 1 z(ii,1,jj, 2),z(ii,1,jj, 3),u) 423 xf(ii,1,jj)=z(ii,1,jj,0)-(f1-f0) endif endif call update(xf,np,mp,n2,np,mp) 500 continue if (ibcx.eq.1) then 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 call update(xf,np,mp,n2,np,mp) end if return end #else subroutine inter3(xf,xd1,xd2,xd3,ig0,jg0,kg0,ifirst) c ior=order of accuracy/2; only even order trmback schemes are considered include 'param.ior' include 'param.nml' include 'param.misc' include 'msg.inc' parameter(nonos=1) common/mpfil/ liner,mpfl,ampd 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), . 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) parameter(n1=n,n2=m,n3=l,nn=n1*n2*n3) data ep/ 1.e-10/ real mx,mn dimension x(1-ior-ihlag:np+ior+ihlag, 1-ior-ihlag:mp+ior+ihlag, . 1-ior:n3+ior) dimension y(1-ih:np+ih, 1-ih:mp+ih, l, -ior:ior), . z(1-ih:np+ih, 1-ih:mp+ih, l, -ior:ior) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly #if (PARALLEL>0) common /slag/ iloc(np,mp,l,-ior:ior),jloc(np,mp,l,-ior:ior) #endif 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 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 call updatelagr(x,np,mp,(n3+2*ior),np,mp) 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 call updatelagr(x,np,mp,(n3+2*ior),np,mp) 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 call updatelagr(x,np,mp,(n3+2*ior),np,mp) 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 call updatelagr(x,np,mp,(n3+2*ior),np,mp) 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 call updatelagr(x,np,mp,(n3+2*ior),np,mp) 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 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,-2)=il 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,2)=il end if ym2=x(iloc(ii,jj,kk,-2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) 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,+2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) #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,-2)=il 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,2)=il end if ym2=x(iloc(ii,jj,kk,-2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) 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,+2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) #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 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,-3)=il jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-2)=il 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,2)=il ia=ig0(ii,jj,kk)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,3)=il end if ym3=x(iloc(ii,jj,kk,-3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ym2=x(iloc(ii,jj,kk,-2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) 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,+2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp3=x(iloc(ii,jj,kk,+3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) #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,-3)=il jloc(ii,jj,kk,j) =jl ia=ig0(ii,jj,kk)-2 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,-2)=il 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,2)=il ia=ig0(ii,jj,kk)+3 call lagrmsg(ia,ja,il,jl) iloc(ii,jj,kk,3)=il end if ym3=x(iloc(ii,jj,kk,-3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) ym2=x(iloc(ii,jj,kk,-2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) 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,+2),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) yp3=x(iloc(ii,jj,kk,+3),jloc(ii,jj,kk,j),kg0(ii,jj,kk)+k) #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,-2),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,2), . 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,-2),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,2), . 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,-3),z(ii,jj,kk,-2),z(ii,jj,kk,-1),z(ii,jj,kk,0) . , z(ii,jj,kk, 1),z(ii,jj,kk, 2),u) f1=tr6(z(ii,jj,kk,-2),z(ii,jj,kk,-1),z(ii,jj,kk, 0),z(ii,jj,kk,1) . , z(ii,jj,kk, 2),z(ii,jj,kk, 3),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,-3),z(ii,jj,kk,-2),z(ii,jj,kk,-1),z(ii,jj,kk,0) . , z(ii,jj,kk, 1),z(ii,jj,kk, 2),u) f1=tr6(z(ii,jj,kk,-2),z(ii,jj,kk,-1),z(ii,jj,kk, 0),z(ii,jj,kk,1) . , z(ii,jj,kk, 2),z(ii,jj,kk, 3),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,-2),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,2), . 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,-2),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,2), . 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,-3),y(ii,jj,kk,-2),y(ii,jj,kk,-1),y(ii,jj,kk,0) . , y(ii,jj,kk, 1),y(ii,jj,kk, 2),u) f1=tr6(y(ii,jj,kk,-2),y(ii,jj,kk,-1),y(ii,jj,kk, 0),y(ii,jj,kk,1) . , y(ii,jj,kk, 2),y(ii,jj,kk, 3),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,-3),y(ii,jj,kk,-2),y(ii,jj,kk,-1),y(ii,jj,kk,0) . , y(ii,jj,kk, 1),y(ii,jj,kk, 2),u) f1=tr6(y(ii,jj,kk,-2),y(ii,jj,kk,-1),y(ii,jj,kk, 0),y(ii,jj,kk,1) . , y(ii,jj,kk, 2),y(ii,jj,kk, 3),u) 723 xf(ii,jj,kk)=y(ii,jj,kk,0)-(f1-f0) endif endif c 500 continue call update(xf,np,mp,n3,np,mp) if (ibcx.eq.1) then 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 call update(xf,np,mp,n3,np,mp) end if if (ibcy.eq.1) then 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 call update(xf,np,mp,n3,np,mp) end if return end #endif subroutine traject(u,v,w,n1,m1,l1,gc1,gc2,gc3,itraj1,itrt) include 'param.nml' include 'param.misc' 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) c dimension u(n1,m1,l1,0:2),v(n1,m1,l1,0:2),w(n1,m1,l1,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 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), 1 fy(1-ih:np+ih,1-ih:mp+ih,l), 1 fz(1-ih:np+ih,1-ih:mp+ih,l), 1 ft(1-ih:np+ih,1-ih:mp+ih,l) nml=n*m*l 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,n,m,l) if(itraj.eq.0) then c if(itraj.ge.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 pfx(i,j,k)=u(i,j,k,0) pfy(i,j,k)=v(i,j,k,0) 13 pfz(i,j,k)=w(i,j,k,0) call interp(pfx,x0,y0,z0,1) if(j3.eq.1) call interp(pfy,x0,y0,z0,0) call interp(pfz,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*(pfx(i,j,k)+u(i,j,k,1)) y0(i,j,k)= ja-.5*gc2*(pfy(i,j,k)+v(i,j,k,1)) 14 z0(i,j,k)= k-.5*gc3*(pfz(i,j,k)+w(i,j,k,1)) call trajbc(x0,y0,z0,n,m,l) 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 pfx(i,j,k)=u(i,j,k,1) pfy(i,j,k)=v(i,j,k,1) 23 pfz(i,j,k)=w(i,j,k,1) call interp(pfx,x0,y0,z0,1) if(j3.eq.1) call interp(pfy,x0,y0,z0,0) call interp(pfz,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*pfx(i,j,k) y0(i,j,k)= ja-gc2*pfy(i,j,k) 24 z0(i,j,k)= k-gc3*pfz(i,j,k) call trajbc(x0,y0,z0,n,m,l) 22 continue endif return end subroutine trajbc(x0,y0,z0,n1,m1,l1) include 'param.nml' include 'param.misc' 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) c dimension x0(n,m,l),y0(n,m,l),z0(n,m,l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly nml=n*m*l nm=n*m 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 1 k=1,l do 1 j=1,mp do 1 i=1,np x0(i,j,k)=amax1(1.-dl, amin1( float(n)+dl, x0(i,j,k) )) 1 continue else do 11 k=1,l do 11 j=1,mp do 11 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) 11 continue endif if(ibcy.eq.0) then do 2 k=1,l do 2 j=1,mp do 2 i=1,np y0(i,j,k)=amax1(1.-dl, amin1( float(m)+dl, y0(i,j,k) )) 2 continue else do 22 k=1,l do 22 j=1,mp do 22 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) 22 continue endif if(ibcz.eq.0) then do 3 k=1,l do 3 j=1,mp do 3 i=1,np z0(i,j,k)=amax1(1.-dv, amin1( float(l)+dv, z0(i,j,k) )) 3 continue else do 33 k=1,l do 33 j=1,mp do 33 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) 33 continue endif return end subroutine forceb(u,v,o,w,n1,m1,l1,gc1,gc2,gc3,itraj1) include 'param.nml' include 'param.misc' 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), . o(1-ih:np+ih, 1-ih:mp+ih, l, 0:2), . w(1-ih:np+ih, 1-ih:mp+ih, l, 0: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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) 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), 1 fy(1-ih:np+ih,1-ih:mp+ih,l), 1 fz(1-ih:np+ih,1-ih:mp+ih,l), 1 ft(1-ih:np+ih,1-ih:mp+ih,l) imid=1 niter=0 nml=n*m*l nm=n*m compute velocities at the departure points do 2 k=1,l do 2 j=1,mp do 2 i=1,np pfx(i,j,k)=u(i,j,k,0) pfy(i,j,k)=v(i,j,k,0) 2 pfz(i,j,k)=w(i,j,k,0) call interp(pfx,x0,y0,z0,1) call interp(pfy,x0,y0,z0,0) call interp(pfz,x0,y0,z0,0) compute balanced forces at the midpoints do 3 k=1,l do 3 j=1,mp do 3 i=1,np fx(i,j,k)=(u(i,j,k,0)-pfx(i,j,k))*dti fy(i,j,k)=(v(i,j,k,0)-pfy(i,j,k))*dti 3 fz(i,j,k)=(w(i,j,k,0)-pfz(i,j,k))*dti if(itraj.eq.1) then do 21 k=1,l do 21 j=1,mp do 21 i=1,np 21 pfz(i,j,k)=o(i,j,k,0) call interp(pfz,x0,y0,z0,1) do 31 k=1,l do 31 j=1,mp do 31 i=1,np 31 o(i,j,k,2)=(o(i,j,k,0)-pfz(i,j,k))*dti endif if(imid.eq.1) then compute balanced forces at the arrival points do 4 k=1,l do 4 j=1,mp do 4 i=1,np u(i,j,k,1)=.5*(i+x0(i,j,k)) v(i,j,k,1)=.5*(j+y0(i,j,k)) o(i,j,k,1)=.5*(k+z0(i,j,k)) pfx(i,j,k)=u(i,j,k,0) pfy(i,j,k)=v(i,j,k,0) 4 pfz(i,j,k)=w(i,j,k,0) call interp(pfx,u(1,1,1,1),v(1,1,1,1),o(1,1,1,1),1) call interp(pfy,u(1,1,1,1),v(1,1,1,1),o(1,1,1,1),0) call interp(pfz,u(1,1,1,1),v(1,1,1,1),o(1,1,1,1),0) do 5 k=1,l do 5 j=1,mp do 5 i=1,np fx(i,j,k)=(u(i,j,k,0)-pfx(i,j,k))*4.*dti-fx(i,j,k) fy(i,j,k)=(v(i,j,k,0)-pfy(i,j,k))*4.*dti-fy(i,j,k) 5 fz(i,j,k)=(w(i,j,k,0)-pfz(i,j,k))*4.*dti-fz(i,j,k) if(itraj.eq.1) then do 41 k=1,l do 41 j=1,mp do 41 i=1,np 41 pfz(i,j,k)=o(i,j,k,0) call interp(pfz,u(1,1,1,1),v(1,1,1,1),o(1,1,1,1),1) do 51 k=1,l do 51 j=1,mp do 51 i=1,np 51 o(i,j,k,2)=(o(i,j,k,0)-pfz(i,j,k))*4.*dti-o(i,j,k,2) endif do 6 k=1,l do 6 j=1,mp do 6 i=1,np u(i,j,k,1)=u(i,j,k,0) v(i,j,k,1)=v(i,j,k,0) 6 o(i,j,k,1)=o(i,j,k,0) endif do 100 it=1,niter do 10 k=1,l do 10 j=1,mp do 10 i=1,np pfx(i,j,k)=u(i,j,k,0)+.5*dt*fx(i,j,k) pfy(i,j,k)=v(i,j,k,0)+.5*dt*fy(i,j,k) 10 pfz(i,j,k)=w(i,j,k,0)+.5*dt*fz(i,j,k) call interp(pfx,x0,y0,z0,1) call interp(pfy,x0,y0,z0,0) call interp(pfz,x0,y0,z0,0) do 11 k=1,l do 11 j=1,mp do 11 i=1,np fx(i,j,k)=(u(i,j,k,0)-pfx(i,j,k))*2.*dti fy(i,j,k)=(v(i,j,k,0)-pfy(i,j,k))*2.*dti 11 fz(i,j,k)=(w(i,j,k,0)-pfz(i,j,k))*2.*dti if(itraj.eq.1) then do 12 k=1,l do 12 j=1,mp do 12 i=1,np 12 pfz(i,j,k)=o(i,j,k,0) call interp(pfz,x0,y0,z0,1) do 13 k=1,l do 13 j=1,mp do 13 i=1,np 13 o(i,j,k,2)=(o(i,j,k,0)-pfz(i,j,k))*2.*dti endif 100 continue call update(pfx,np,mp,l,np,mp) call update(pfy,np,mp,l,np,mp) call update(pfz,np,mp,l,np,mp) call update(fx, np,mp,l,np,mp) call update(fy, np,mp,l,np,mp) call update(fz, np,mp,l,np,mp) call update(u, np,mp,l,np,mp) call update(v, np,mp,l,np,mp) call update(o, np,mp,l,np,mp) return end #if (PARALLEL>0) subroutine lagrmsg(ia,ja,i,j) include 'param.nml' include 'param.misc' include 'param.ior' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly c print *,'lagrmsg',mype 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 c print *,'lagrmsg done',mype return end #endif #else #if (J3DIM == 0) subroutine mp2bc(x,iflg,bcx,n1,n2) include 'param.nml' include 'param.misc' 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), . 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 (iflg.eq.1) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=the( 1,1,k) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=the(np,1,k) enddo end if else if (iflg.eq.2) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=ue( 1,1,k) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=ue(np,1,k) enddo end if else if (iflg.eq.3) then if (leftedge.eq.1) then do k=1,n2 bcx(k,1)=ve( 1,1,k) end do end if if (rightedge.eq.1) then do k=1,n2 bcx(k,2)=ve(np,1,k) enddo end if end if c if(iflg.le.3) then c do k=1,n2 c bcx(k,1)=prf( 1,1,k,iflg) c bcx(k,2)=prf(n1,1,k,iflg) c enddo c endif if(iflg.eq.4.or.iflg.eq.5) then do k=1,n2 bcx(k,1)=0. bcx(k,2)=0. enddo endif if(iflg.eq.6.or.iflg.eq.7) then if (leftedge.eq.1) then do k=1,nmsp bcx(k,1)=qve( 1,1,k) end do end if if (rightedge.eq.1) then do k=1,nmsp bcx(k,2)=qve(nmsp,1,k) enddo end if endif if(iflg.ge.8) then do k=1,n2 bcx(k,1)=0. bcx(k,2)=0. enddo endif return end subroutine mpdata2(u1,u2,x,h,iflg,cp,cn,mx,mn) include 'param.nml' include 'param.misc' include 'msg.inc' parameter(n1=n+1,n2=l+1) parameter(n1m=n1-1,n2m=n2-1,n2mm=n2-2) 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) dimension v1(1-ih:np+ih+1,1-ih:mp+ih, l) dimension v2(1-ih:np+ih, 1-ih:mp+ih, l+1) dimension f1(1-ih:np+1+ih,1-ih:mp+ih, l) dimension f2(1-ih:np+ih, 1-ih:mp+ih, l+1), . 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) dimension bcx(l,2) real mx,mn parameter(iord0=2,isor=1,nonos=1,idiv=0) common/mpfil/ liner,mpfl,ampd common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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) 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) iprec=0 if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib call updatelr(x,np,mp,l,np,mp) iord=iord0 if(isor.eq.3) iord=max0(iord,3) if(liner.eq.1) iord=1 ibox=1-ibcx iboz=1-ibcz illim1 = 1 illim2 = 1 + 1*leftedge illim3 = 1 + 2*leftedge iulim1 = np + 1*rightedge iulim2 = np - 1*rightedge illimx = 1 + (1-ibcx)*leftedge illimx2 = 1 + (2-ibcx)*leftedge iulimx = np + (ibcx-1)*rightedge do j=1,n2m do i=illim2,np v1(i,1,j) = u1(i,1,j) end do end do 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 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 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) 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 c im=ibcx*(i-1+(n1-i)/n1m*(n1-2))+(1-ibcx)*max0(i-1,1 ) c ip=ibcx*(i+1 -i /n1m*(n1-2))+(1-ibcx)*min0(i+1,n1m) 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) COLD call update(x,np,mp,l,np,mp) CLOOP illim = 1 + 1*leftedge 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 (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp) else call updatelr(f1,np+1,mp,l,np+1,mp) 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) else call updatelr(f1,np+1,mp,l,np+1,mp) end if 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 CLOOP iulim1 = np + 1*rightedge 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) else call updatelr(f1,np+1,mp,l,np+1,mp) end if call updatelr(f2,np,mp,l+1,np,mp) call updatelr(x,np,mp,l,np,mp) CLOOP illim2 = 1 + 1*leftedge 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 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 CLOOP illim2 = 1 + 1*leftedge CLOOP iulim2 = np - 1*rightedge 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(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) if (rightedge.eq.1) then do j=2,n2m v2(np,1,j)=v2(np+1,1,j) end do endif #endif end if if(idiv.eq.1) then CLOOP illimx = 1 + (1-ibcx)*leftedge CLOOP iulimx = np + (ibcx-1)*rightedge 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 CLOOP illim3 = 1 + 2*leftedge CLOOP iulim2 = np - 1*rightedge 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(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 CLOOP illimx2 = 1 + (2-ibcx)*leftedge CLOOP iulimx = np + (ibcx-1)*rightedge 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 CLOOP illimx = 1 + (1-ibcx)*leftedge CLOOP iulimx = np + (ibcx-1)*rightedge do 63 j=3,n2-2 do 63 i=illimx,iulimx 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 CLOOP illim2 = 1 + 1*leftedge CLOOP iulim2 = np - 1*rightedge do 64 j=3-ibcz,n2-2+ibcz do 64 i=illim2,iulim2 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(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) 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 !isor=3 if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp) else call updatelr(v1,np+1,mp,l,np+1,mp) end if if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j)=v1(-1,1,j) end do end if COLD the following update is probably unnecessary ; when I have time COLD I'll check to make sure and remove it if that's the case. COLD if (rightedge.eq.0) then COLD call update(v1,np,mp,l,np+1,mp) COLD else COLD call update(v1,np+1,mp,l,np+1,mp) COLD 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 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-osscilatory option do 401 j=1,n2m 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) 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 c im=ibc*(i-1+(n1-i)/n1m*(n1-2))+ibo*max0(i-1,1 ) c ip=ibc*(i+1 -i /n1m*(n1-2))+ibo*min0(i+1,n1m) 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(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp) else call updatelr(f1,np+1,mp,l,np+1,mp) 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) else call updatelr(f1,np+1,mp,l,np+1,mp) end if 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) call updatelr(cn,np,mp,l,np,mp) 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(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp) else call updatelr(v1,np+1,mp,l,np+1,mp) end if if (leftedge.eq.1) then do j=1,n2m v1(1,1,j)=v1(-1,1,j) enddo end if COLD if (rightedge.eq.0) then COLD call update(v1,np,mp,l,np+1,mp) COLD else COLD call update(v1,np+1,mp,l,np+1,mp) COLD 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 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) return end subroutine mpdatm2(u1,u2,x,h,iflg,cp,cn,mx,mn) include 'param.nml' include 'param.misc' include 'msg.inc' parameter(n1=n+1,n2=l+1) parameter(n1m=n1-1,n2m=n2-1,n2mm=n2-2) 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) dimension v1(1-ih:np+ih+1,1-ih:mp+ih, l) dimension v2(1-ih:np+ih, 1-ih:mp+ih, l+1) dimension f1(1-ih:np+1+ih,1-ih:mp+ih, l) dimension f2(1-ih:np+ih, 1-ih:mp+ih, l+1), . 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) dimension bcx(l,2) real mx,mn parameter(isor=1,nonos=1,idiv=1) common/mpfil/ liner,mpfl,ampd common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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) 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+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 if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib call update(x,np,mp,l,np,mp) ibox=1-ibcx iboz=1-ibcz itmx=2-liner illim = 1 + 1*leftedge iulim = np do j=1,n2m do i=illim,iulim v1(i,1,j) = u1(i,1,j) end do end do 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 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 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) 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 c im=ibc*(i-1+(n1-i)/n1m*(n1-2))+ibo*max0(i-1,1 ) c ip=ibc*(i+1 -i /n1m*(n1-2))+ibo*min0(i+1,n1m) 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((k.eq.1).and.(ibcx.eq.0)) call mp2bc(x,iflg,bcx,n1m,n2m) COLD call update(x,np,mp,l,np,mp) illim = 1 + 1*leftedge iulim = np 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(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp) else call updatelr(f1,np+1,mp,l,np+1,mp) 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) else call updatelr(f1,np+1,mp,l,np+1,mp) end if 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. illim = 1 iulim = np + 1*rightedge 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) else call updatelr(f1,np+1,mp,l,np+1,mp) end if call updatelr(f2,np,mp,l+1,np,mp) call updatelr(x,np,mp,l,np,mp) illim = 1 + 1*leftedge iulim = np 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 endif if(idiv.eq.1) then illim = 1 + 1*leftedge iulim = np 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 illim = 1 + 1*leftedge iulim = np - 1*rightedge 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(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) if (rightedge.eq.1) then do j=2,n2m v2(np,1,j)=v2(np+1,1,j) enddo end if #endif endif if(idiv.eq.1) then illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge 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 illim = 1 + 2*leftedge iulim = np - 1*rightedge 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(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 illim = 1 + (2-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge 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 illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge 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 illim = 1 + 1*leftedge iulim = np - 1*rightedge 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(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) 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 if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp) else call updatelr(v1,np+1,mp,l,np+1,mp) end if if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j)=v1(-1,1,j) end do end if COLD the following update is probably unnecessary ; when I have time COLD I'll check to make sure and remove it if that's the case. COLD if (rightedge.eq.0) then COLD call update(v1,np,mp,l,np+1,mp) COLD else COLD call update(v1,np+1,mp,l,np+1,mp) COLD 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 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 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) 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 c im=ibcx*(i-1+(n1-i)/n1m*(n1-2))+ibox*max0(i-1,1 ) c ip=ibcx*(i+1 -i /n1m*(n1-2))+ibox*min0(i+1,n1m) 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)) iulim = np + 1*rightedge 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) else call updatelr(f1,np+1,mp,l,np+1,mp) 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) call updatelr(cn,np,mp,l,np,mp) illim = 1 + 1*leftedge 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 (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp) else call updatelr(v1,np+1,mp,l,np+1,mp) end if if (leftedge.eq.1) then do j=1,n2m v1( 1,1,j)=v1(-1,1,j) end do end if COLD following update is probably unnecessary COLD if (rightedge.eq.0) then COLD call update(v1,np,mp,l,np+1,mp) COLD else COLD call update(v1,np+1,mp,l,np+1,mp) COLD 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 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) return end #else subroutine mp3bc(x,iflg,bcx,bcy,n1,n2,n3) include 'param.nml' include 'param.misc' include 'msg.inc' dimension x(n1,n2,n3),bcx(1-ih:n2+ih,n3,2),bcy(1-ih:n1+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), . 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/profc/qce(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) C dimension qve_(1-ih:n1+ih,1-ih:n2+ih,n3) if (iflg.eq.1) then COLD call update(the,np,mp,l,np,mp) if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=the(1,j,k) bcx(j,k,2)=the(0,j,k) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=the(n1+1,j,k) bcx(j,k,2)=the(n1, j,k) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=the(i,1,k) bcy(i,k,2)=the(i,0,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=the(i,n2+1,k) bcy(i,k,2)=the(i,n2,k) enddo enddo end if else if (iflg.eq.2) then COLD call update(ue,np,mp,l,np,mp) if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=ue(1,j,k) bcx(j,k,2)=ue(0,j,k) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=ue(n1+1,j,k) bcx(j,k,2)=ue(n1, j,k) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=ue(i,1,k) bcy(i,k,2)=ue(i,0,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=ue(i,n2+1,k) bcy(i,k,2)=ue(i,n2,k) enddo enddo end if else if (iflg.eq.3) then COLD call update(ve,np,mp,l,np,mp) if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=ve(1,j,k) bcx(j,k,2)=ve(0,j,k) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=ve(n1+1,j,k) bcx(j,k,2)=ve(n1, j,k) enddo enddo end if if (botedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=ve(i,1,k) bcy(i,k,2)=ve(i,0,k) enddo enddo else if (topedge.eq.1) then do k=1,n3 do i=1,n1 bcy(i,k,1)=ve(i,n2+1,k) bcy(i,k,2)=ve(i,n2,k) enddo enddo end if end if if(iflg.eq.4.or.iflg.eq.5) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. enddo enddo endif if(iflg.eq.6) then 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(n1+1,j,k) bcx(j,k,2)=qve(n1, 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,n2+1,k) bcy(i,k,2)=qve(i,n2,k) enddo enddo end if endif if(iflg.eq.7) then if (leftedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=qve(1,j,k)+qce(1,j,k) bcx(j,k,2)=qve(0,j,k)+qce(0,j,k) enddo enddo else if (rightedge.eq.1) then do k=1,n3 do j=1,n2 bcx(j,k,1)=qve(n1+1,j,k)+qce(n1+1,j,k) bcx(j,k,2)=qve(n1, j,k)+qce(n1, 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)+qce(i,1,k) bcy(i,k,2)=qve(i,0,k)+qce(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,n2+1,k)+qce(i,n2+1,k) bcy(i,k,2)=qve(i,n2,k)+qce(i,n2,k) enddo enddo end if endif if(iflg.ge.8) then do k=1,n3 do j=1,n2 bcx(j,k,1)=0. bcx(j,k,2)=0. enddo enddo do k=1,n3 do i=1,n1 bcy(i,k,1)=0. bcy(i,k,2)=0. enddo enddo endif return end subroutine mpdata3(u1,u2,u3,x,h,iflg,cp,cn,mx,mn) include 'param.nml' include 'param.misc' include 'msg.inc' real mx, mn 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), . 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) 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 v1(1-ih:np+ih+1,1-ih:mp+ih, l) dimension v2(1-ih:np+ih, 1-ih:mp+1+ih, l) dimension v3(1-ih:np+ih, 1-ih:mp+ih, l+1) dimension f1(1-ih:np+1+ih, 1-ih:mp+ih, l) dimension f2(1-ih:np+ih, 1-ih:mp+1+ih, l) dimension f3(1-ih:np+ih, 1-ih:mp+ih, l+1) dimension bcx(1-ih:mp+ih, n3m, 2) dimension bcy(1-ih:np+ih, n3m, 2) common/mpfil/ liner,mpfl,ampd common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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 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 call update(x,np,mp,l,np,mp) iord=iord0 if(isor.eq.3) iord=max0(iord,3) if(liner.eq.1) iord=1 ibox=1-ibcx iboy=1-ibcy iboz=1-ibcz iprec=0 if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib do j=1,mp do i=1,np do k=2,n3m 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 + 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 i=1,np do j=jllim,mp 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))+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 endif do 30 itr=1,iord if((itr.eq.1).and.((ibcx*ibcy).eq.0)) . call mp3bc(x,iflg,bcx,bcy,np,mp,n3m) COLD call update(x,np,mp,l,np,mp) illim = 1 + 1*leftedge do 331 k=1,n3m do 331 j=1,mp do 331 i=illim,np 331 f1(i,j,k)=donor(x(i-1,j,k),x(i,j,k),v1(i,j,k)) if(ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp) else call updatelr(f1,np+1,mp,l,np+1,mp) 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) else call updatelr(f1,np+1,mp,l,np+1,mp) end if endif jllim = 1 + 1*botedge 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)) if(ibcy.eq.1) then if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1) else call updatebt(f2,np,mp+1,l,np,mp+1) 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) else call updatebt(f2,np,mp+1,l,np,mp+1) end if endif 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)) 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 iulim = np + 1*rightedge 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 + 1*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. compute antidiffusive velocities in x direction if (rightedge.eq.0) then call update(f1,np,mp,l,np+1,mp) else call update(f1,np+1,mp,l,np+1,mp) end if if (topedge.eq.0) then call update(f2,np,mp,l,np,mp+1) else call update(f2,np,mp+1,l,np,mp+1) end if call update(x,np,mp,l,np,mp) call update(f3,np,mp,l+1,np,mp) jllim = 1 + 1*botedge julim = mp - 1*topedge illim = 1 + 1*leftedge 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))) 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) else call updatebt(v1,np+1,mp,l,np+1,mp) 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 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 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 #if (PARALLEL > 0) if (rightedge.eq.0) then call updatebt(v1,np,mp,l,np+1,mp) else call updatebt(v1,np+1,mp,l,np+1,mp) 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 endif !ibcz=1 if(idiv.eq.1) then jllim = 1 + (1-ibcy)*botedge julim = mp + (-1+ibcy)*topedge illim = 1 + 1*leftedge 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 illim = 1 + 2*leftedge iulim = np - 1*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge 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))) 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 illim = 1 + (2-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + 1*botedge julim = mp - 1*topedge 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))) 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) else call updatebt(v1,np+1,mp,l,np+1,mp) 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 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))) 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) else call updatebt(v1,np+1,mp,l,np+1,mp) 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 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 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) else call updatebt(v1,np+1,mp,l,np+1,mp) 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 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 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) else call updatebt(v1,np+1,mp,l,np+1,mp) 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 endif !ibcz=1 endif ! isor=3 compute antidiffusive velocities in y direction jllim = 1 + 1*botedge illim = 1 + 1*leftedge iulim = np - 1*rightedge do 52 k=2,n3-2 do 52 j=jllim,mp 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))) if(ibcx.eq.1) then if (leftedge.eq.1) then do k=2,n3-2 do j=jllim,mp 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) else call updatelr(v2,np,mp+1,l,np,mp+1) end if if (rightedge.eq.1) then do k=2,n3-2 do j=jllim,mp v2(np,j,k)=v2(np+1,j,k) end do end do end if #endif endif !ibcx=1 if(ibcz.eq.1) then do j=jllim,mp 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 if(ibcx.eq.1) then if (leftedge.eq.1) then do j=jllim,mp 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 #if (PARALLEL > 0) if (topedge.eq.0) then call updatelr(v2,np,mp,l,np,mp+1) else call updatelr(v2,np,mp+1,l,np,mp+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 ,j,1) end do end if #endif endif !ibcx=1 endif !ibcz=1 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 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 jllim = 1 + 2*botedge julim = mp - 1*topedge illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge 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))) 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 jllim = 1 + (2-ibcy)*botedge julim = mp - (1-ibcy)*topedge illim = 1 + 1*leftedge iulim = np - 1*rightedge 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))) 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) else call updatelr(v2,np,mp+1,l,np,mp+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 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))) 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) else call updatelr(v2,np,mp+1,l,np,mp+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 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 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) else call updatelr(v2,np,mp+1,l,np,mp+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 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 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) else call updatelr(v2,np,mp+1,l,np,mp+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 endif !ibcz=1 endif ! isor=3 compute antidiffusive velocities in z direction illim = 1 + 1*leftedge iulim = np - 1*rightedge jllim = 1 + 1*botedge julim = mp - 1*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))) * +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))) 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) 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) 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) 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 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 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 illim = 1 + (1-ibcx)*leftedge iulim = np - (1-ibcx)*rightedge jllim = 1 + (1-ibcy)*botedge julim = mp - (1-ibcy)*topedge 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 illim = 1 + 1*leftedge iulim = np - 1*rightedge jllim = 1 + 1*botedge julim = mp - 1*topedge 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))) 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) 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 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))) 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) 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) 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) 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) 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) 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) 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) 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 endif !isor=3 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 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 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)) illim = 1 + 1*leftedge 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)) if (rightedge.eq.0) then call updatelr(f1,np,mp,l,np+1,mp) else call updatelr(f1,np+1,mp,l,np+1,mp) 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 jllim = 1 + 1*botedge 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)) if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1) else call updatebt(f2,np,mp+1,l,np,mp+1) 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 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) call update2(cn,np,mp,l,np,mp) 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 ! non-osscilatory option if (ibcx.eq.1) then if (rightedge.eq.0) then call updatelr(v1,np,mp,l,np+1,mp) else call updatelr(v1,np+1,mp,l,np+1,mp) 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) else call updatebt(v2,np,mp+1,l,np,mp+1) 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.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) return end subroutine mpdatm3(u1,u2,u3,x,h,iflg,cp,cn,mx,mn) include 'param.nml' include 'param.misc' parameter(n1=n+1,n2=m+1,n3=l+1) parameter(n1m=n1-1,n2m=n2-1,n3m=n3-1) parameter(nonos=1,idiv=0) common/mpfil/ liner,mpfl,ampd common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly data ep/1.e-10/ include 'msg.inc' dimension u1(1-ih:np+ih, 1-ih:mp+ih, l) dimension u2(1-ih:np+ih, 1-ih:mp+ih, l) dimension u3(1-ih:np+ih, 1-ih:mp+ih, l) dimension x(1-ih:np+ih, 1-ih:mp+ih, l) dimension h(1-ih:np+ih, 1-ih:mp+ih, l) dimension v1(1-ih:np+ih+1,1-ih:mp+ih, l) dimension v2(1-ih:np+ih, 1-ih:mp+1+ih, l) dimension v3(1-ih:np+ih, 1-ih:mp+ih, l+1) dimension f1(1-ih:np+1+ih, 1-ih:mp+ih, l) dimension f2(1-ih:np+ih, 1-ih:mp+1+ih, l) dimension f3(1-ih:np+ih, 1-ih:mp+ih, l+1) dimension cp(1-ih:np+ih, 1-ih:mp+ih, l) dimension cn(1-ih:np+ih, 1-ih:mp+ih, l) dimension mx(1-ih:np+ih, 1-ih:mp+ih, l) dimension mn(1-ih:np+ih, 1-ih:mp+ih, l) dimension bcx(1-ih:mp+ih, n3m, 2) dimension bcy(1-ih:np+ih, n3m, 2) real mx,mn 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) 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+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 c transfer data from shared arrays to msg arrays c call update(x,np,mp,l,np,mp) ibox=1-ibcx iboy=1-ibcy iboz=1-ibcz ibcxy=ibcx*ibcy itmx=2-liner iprec=0 if(iflg.eq.8.or.iflg.eq.10.or.iflg.eq.11) iprec=1 !qr, qia, qib do j=1,mp do i=1,np do k=2,n3m v3(i,j,k) = u3(i,j,k) enddo v3(i,j, 1) = wbc(i,j,1) v3(i,j,n3) = wbc(i,j,2) end do end do illim = 1 + 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 i=1,np do j=jllim,mp 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 end if 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) ilft=1+leftedge*1 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)) cex . -c1*ampd*.5*(h(i,j,k)+h(i-1,j,k))*(x(i,j,k)-x(i-1,j,k)) 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) else call updatelr(f1,np+1,mp,l,np+1,mp) 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(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 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) else call updatelr(f1,np+1,mp,l,np+1,mp) end if endif jbot=1+botedge*1 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)) cex . -c1*ampd*.5*(h(i,j,k)+h(i,j-1,k))*(x(i,j,k)-x(i,j-1,k)) 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) else call updatebt(f2,np,mp+1,l,np,mp+1) 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)) 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)) end do end do end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1) else call updatebt(f2,np,mp+1,l,np,mp+1) end if endif 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)) cex . -c1*ampd*.5*(h(i,j,k)+h(i,j,k-1))*(x(i,j,k)-x(i,j,k-1)) 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 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) go to 6 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 compute antidiffusive velocities in x direction call update(x,np,mp,l,np,mp) if (rightedge.eq.0) then call update(f1,np,mp,l,np+1,mp) else call update(f1,np+1,mp,l,np+1,mp) end if if (topedge.eq.0) then call update(f2,np,mp,l,np,mp+1) else call update(f2,np,mp+1,l,np,mp+1) end if call update(f3,np,mp,l+1,np,mp) illim = 1 + 1*leftedge iulim = np jllim = 1 + 1*botedge julim = mp - 1*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))) * +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 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) else call updatebt(v1,np+1,mp,l,np+1,mp) 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 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 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) else call updatebt(v1,np+1,mp,l,np+1,mp) 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 endif !ibcz=1 if(idiv.eq.1) then illim = 1 + 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 compute antidiffusive velocities in y direction illim = 1 + 1*leftedge iulim = np - 1*rightedge jllim = 1 + 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))) * +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 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) else call updatelr(v2,np,mp+1,l,np,mp+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 end if 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 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) else call updatelr(v2,np,mp+1,l,np,mp+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 endif !ibcz=1 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 compute antidiffusive velocities in z direction illim = 1 + 1*leftedge iulim = np - 1*rightedge jllim = 1 + 1*botedge julim = mp - 1*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))) * +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))) * +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) 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) 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) 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) else call updatelr(v1,np+1,mp,l,np+1,mp) 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) else call updatebt(v2,np,mp+1,l,np,mp+1) 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) else call updatelr(f1,np+1,mp,l,np+1,mp) end if if (topedge.eq.0) then call updatebt(f2,np,mp,l,np,mp+1) else call updatebt(f2,np,mp+1,l,np,mp+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) call update2(cn,np,mp,l,np,mp) illim = 1 + 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 if (v2(i,j,k).ge.0.) then v2(i,j,k)= pp(v2(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j-1,k)) else v2(i,j,k)=-pn(v2(i,j,k))*amin1(1.,cp(i,j-1,k),cn(i,j,k)) end if cori v2(i,j,k)= pp(v2(i,j,k))*amin1(1.,cp(i,j,k),cn(i,j-1,k)) cori . -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) else call updatelr(v1,np+1,mp,l,np+1,mp) 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) else call updatebt(v2,np,mp+1,l,np,mp+1) 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,n3m c do j=1,mp c do i=1,np c x(i,j,k)=amax1(0.,x(i,j,k)) c enddo c enddo c enddo c endif call update(x,np,mp,l,np,mp) return end #endif #endif subroutine invertab(th,the,fth,tau,rx,ry,dt,iabth,n1,m1,l1) include 'param.nml' include 'param.misc' dimension rx(n),ry(m) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly include 'msg.inc' dimension tau(l, 1-ih:np+ih, 1-ih:mp+ih) dimension th(1-ih:np+ih, 1-ih:mp+ih, l), . the(1-ih:np+ih, 1-ih:mp+ih, l), . fth(1-ih:np+ih, 1-ih:mp+ih, l) do 183 k=1,l do 183 jt=1,mp do 183 it=1,np i=it+(npos-1)*np j=jt+(mpos-1)*mp relt=rx(i)+ry(j)-rx(i)*ry(j) tth=iabth*tau(k,it,jt)*(1.-relt)+relt th(it,jt,k)=(th(it,jt,k)+tth*the(it,jt,k)*dt*.5)/(1.+.5*tth*dt) fth(it,jt,k)= -tth*(th(it,jt,k)-the(it,jt,k)) c pbl c th(it,jt,k)=(th(it,jt,k)+(fth(it,jt,k)+tth*the(it,jt,k))*dt*.5) c . /(1.+.5*tth*dt) c fth(it,jt,k)=fth(it,jt,k)-tth*(th(it,jt,k)-the(it,jt,k)) c pbl 183 continue call update(th,np,mp,l,np,mp) return end subroutine laplc(p,r,u,v,w,c,fc,fd,n1,m1,l1,cf33,cf00,px,py,pz) include 'param.nml' include 'param.misc' include 'msg.inc' 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/indx/ e1,e2,e3 compute available storage in // include 'param.ior' include 'param.icw' parameter (nml=n*m*l,iuse=3*nml+(2*ior+1)*nml) dimension p(1-ih:np+ih, 1-ih:mp+ih, l), . r(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), . cf33(1-ih:np+ih, 1-ih:mp+ih, l), . cf00(1-ih:np+ih, 1-ih:mp+ih, l) dimension 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, l), . pe(1-ih:np+ih, 1-ih:mp+ih, l+1) c dimension tmp(1-ih:np+ih, 1-ih:mp+ih, l) c copy from shared arrays to pvm arrays call update2(p,np,mp,l,np,mp) nm=n*m ml=m*l if(igrid.eq.0) then dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi compute pressure derivatives everywhere if (leftedge.eq.0 .and. rightedge.eq.0) then do k=1,l do j=1,mp do i=1,np px(i,j,k)=dxil*(p(i+1,j,k)-p(i-1,j,k)) end do end do end do end if if (leftedge.eq.1 .and. rightedge.eq.0) then do k=1,l do j=1,mp do i=2,np px(i,j,k)=dxil*(p(i+1,j,k)-p(i-1,j,k)) end do 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 .and. leftedge.eq.0) then do k=1,l do j=1,mp do i=1,np-1 px(i,j,k)=dxil*(p(i+1,j,k)-p(i-1,j,k)) end do 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 if (rightedge.eq.1 .and. leftedge.eq.1) then do k=1,l do j=1,mp do i=2,np-1 px(i,j,k)=dxil*(p(i+1,j,k)-p(i-1,j,k)) end do 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)) 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 if(j3.eq.1) then if (topedge.eq.0 .and. botedge.eq.0) then do k=1,l do j=1,mp do i=1,np py(i,j,k)=dyil*(p(i,j+j3,k)-p(i,j-j3,k)) end do end do end do end if if (botedge.eq.1 .and. topedge.eq.0) then do k=1,l do i=1,np do j=2,mp py(i,j,k)=dyil*(p(i,j+j3,k)-p(i,j-j3,k)) end do 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 else if (topedge.eq.1 .and. botedge.eq.0) then do k=1,l do i=1,np do j=1,mp-1 py(i,j,k)=dyil*(p(i,j+j3,k)-p(i,j-j3,k)) end do 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 else if (botedge.eq.1 .and. topedge.eq.1) then do k=1,l do i=1,np do j=2,mp-1 py(i,j,k)=dyil*(p(i,j+j3,k)-p(i,j-j3,k)) end do 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)) 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 do k=1,l do j=1,mp do i=1,np py(i,j,k)=0.0 end do end do end do endif do k=2,l-1 do j=1,mp do i=1,np pz(i,j,k)=dzil*(p(i,j,k+1)-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,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 else dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi construct extended, auxiliary pressure field with either cyclic or extrapolated boundaries do 4 i=2,n do 4 k=2,l do 4 j=1+j3,m 4 pe(i,j,k)=p(i,j,k) do 41 i=2,n do 41 j=1+j3,m 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)=plex 41 pe(i,j,l+1)=prex do 42 k=1,l+1 do 42 j=1+j3,m 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) 42 pe(n+1,j,k)=(1-ibcx)*prex+ibcx*pe(2,j,k) if(j3.eq.1) then do 43 i=1,n+1 do 43 k=1,l+1 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) 43 pe(i,m+1,k)=(1-ibcy)*prex+ibcy*pe(i,1+j3,k) endif compute pressure derivatives everywhere if(j3.eq.1) then do 5 i=1,n do 5 k=1,l do 5 j=1,m 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 i=1,n do 51 k=1,l 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 i=1,n do 52 k=1,l do 52 j=1,m 52 py(i,j,k)=0. endif endif compute interior pressure forces do 10 k=2-ibcz,l-1+ibcz do 10 j=1,mp do 10 i=1,np g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=cf33(i,j,k) u(i,j,k)=-(a11*px(i,j,k)+a12*py(i,j,k)+a13*pz(i,j,k)) v(i,j,k)=-(a21*px(i,j,k)+a22*py(i,j,k)+a23*pz(i,j,k)) 10 w(i,j,k)=-(a31*px(i,j,k)+a32*py(i,j,k)+a33*pz(i,j,k)) compute pressure forces at the boundaries 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 if (botedge.eq.1) then jllim=1+j3-ibcy else jllim=1 end if if (topedge.eq.1) then julim=mp-j3+ibcy else julim=mp end if do 11 i=illim,iulim,np-1 ii=1+i/np do 111 j=jllim,julim do 111 k=2-ibcz,l-1+ibcz g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=cf33(i,j,k) u(i,j,k)=0. pxb=-(a12*py(i,j,k)+a13*pz(i,j,k))/a11 v(i,j,k)=-(a21*pxb+a22*py(i,j,k)+a23*pz(i,j,k)) 111 w(i,j,k)=-(a31*pxb+a32*py(i,j,k)+a33*pz(i,j,k))*icw 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 j=jllim,julim,mp-j3 jj=1+j/mp do 1121 k=2-ibcz,l-1+ibcz g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=cf33(i,j,k) u(i,j,k)= 0. v(i,j,k)= 0. a=-a13*pz(i,j,k) b=-a23*pz(i,j,k) pxb=(a22*a-a12*b)/(a11*a22-a12*a21) pyb=(a11*b-a21*a)/(a11*a22-a12*a21) 1121 w(i,j,k)=-(a31*pxb+a32*pyb+a33*pz(i,j,k)) 112 continue endif 11 continue endif 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 if (leftedge.eq.1) then illim=2-ibcx else illim=1 end if if (rightedge.eq.1) then iulim=np-1+ibcx else iulim=np end if do 12 j=jllim,julim,mp-j3 jj=1+j/mp do 121 k=2-ibcz,l-1+ibcz do 121 i=illim,iulim g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=cf33(i,j,k) v(i,j,k)= 0. pyb=-(a21*px(i,j,k)+a23*pz(i,j,k))/a22 u(i,j,k)=-(a11*px(i,j,k)+a12*pyb+a13*pz(i,j,k)) 121 w(i,j,k)=-(a31*px(i,j,k)+a32*pyb+a33*pz(i,j,k))*icw 12 continue endif if(ibcz.eq.0) then do 20 k=1,l,l-1 kk=1+k/l if (botedge.eq.1) then jllim=1+j3-ibcy else jllim=1 end if if (topedge.eq.1) then julim=mp-j3+ibcy else julim=mp end if if (leftedge.eq.1) then illim=2-ibcx else illim=1 end if if (rightedge.eq.1) then iulim=np-1+ibcx else iulim=np end if do 21 j=jllim,julim do 21 i=illim,iulim g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=cf33(i,j,k) w(i,j,k)= 0. pzb=-(a31*px(i,j,k)+a32*py(i,j,k))/a33 u(i,j,k)=-(a11*px(i,j,k)+a12*py(i,j,k)+a13*pzb) 21 v(i,j,k)=-(a21*px(i,j,k)+a22*py(i,j,k)+a23*pzb) 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 i=illim,iulim,np-1 ii=1+i/np if (botedge.eq.1) then jllim=1+j3-ibcy else jllim=1 end if if (topedge.eq.1) then julim=mp-j3+ibcy else julim=mp end if do 2111 j=jllim,julim g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=cf33(i,j,k) w(i,j,k)= 0. u(i,j,k)= 0. pzb=-(a11*a32-a31*a12)*py(i,j,k)/(a11*a33-a31*a13) pxb=-(a12*py(i,j,k)+a13*pzb)/a11 2111 v(i,j,k)=-(a21*pxb+a22*py(i,j,k)+a23*pzb) 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 2112 j=jllim,julim,mp-j3 u(i,j,k)= 0. v(i,j,k)= 0. 2112 w(i,j,k)= 0. endif 211 continue endif 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 if (leftedge.eq.1) then illim=2-ibcx else illim=1 end if if (rightedge.eq.1) then iulim=np-1+ibcx else iulim=np end if do 212 j=jllim,julim,mp-j3 jj=1+j/mp do 2121 i=illim,iulim g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=cf33(i,j,k) w(i,j,k)= 0. v(i,j,k)= 0. pzb= -(a31*a22-a32*a21)*px(i,j,k)/(a33*a22-a32*a23) pyb=-(a21*px(i,j,k)+a23*pzb)/a22 2121 u(i,j,k)=-(a11*px(i,j,k)+a12*pyb+a13*pzb) 212 continue endif 20 continue endif do 99 k=1,l do 99 j=1,mp do 99 i=1,np coef=cf00(i,j,k) u(i,j,k)=coef*u(i,j,k) v(i,j,k)=coef*v(i,j,k) 99 w(i,j,k)=coef*w(i,j,k) c special for the noslip c do j=1,mp c do i=1,np c u(i,j,1)=0. c v(i,j,1)=0. c w(i,j,1)=0. c enddo c enddo c end of special c update halos of msg arrays call update2(u,np,mp,l,np,mp) call update2(v,np,mp,l,np,mp) compute laplacian if(igrid.eq.0) then 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 if(j3.eq.1) then 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-1 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-1 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 end if 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)) 932 r(i,j,l)=r(i,j,l)+dzil*(w(i,j,2)-w(i,j,l-1)) 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)/rho(i,j,k) else if(j3.eq.1) then do 95 i=2,n do 95 k=2,l do 95 j=1+j3,m r(i,j,k)=dxil*( 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*( 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*( 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*( rho(i,j,k-1)+rho(i-1,j,k-1)+rho(i-1,j-j3,k-1)+ . rho(i,j-j3,k-1)+rho(i,j,k)+rho(i-1,j,k)+rho(i-1,j-j3,k)+ . rho(i,j-j3,k) ) 95 r(i,j,k)=-r(i,j,k)/rhoav else do 96 i=2,n do 96 k=2,l 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*( rho(i,1,k-1)+rho(i-1,1,k-1)+rho(i,1,k)+rho(i-1,1,k)) 96 r(i,1,k)=-r(i,1,k)/rhoav endif endif return end Cendif ANALIZE == 0 #endif subroutine lipsch(u,v,w,d,n1,m1,l1,g1,g2,g3,cr1,cr2, . lagr1,iprnt) include 'param.nml' include 'param.misc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 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), . temp(1-ih:np+ih, 1-ih:mp+ih, l), . tempcr2(1-ih:1+ih, 1-ih:1+ih, l) real globmax nml=n*m*l check courant and lipschitz numbers if(lagr1.eq.1) then 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) tempcr2(1,1,1)=0. jllim = 1 + j3*botedge julim = mp - j3*topedge illim = 1 + 1*leftedge iulim = np - 1*rightedge do 2 k=2,l-1 do 2 j=jllim,julim do 2 i=illim,iulim 2 tempcr2(1,1,1)=max(tempcr2(1,1,1), . .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) )) cr2=globmax(tempcr2,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1,1,1) else 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) gy=j3*g2+(1-j3)*1. tempcr2(1,1,1)=-1.e15 jllim = 1 + j3*botedge julim = mp - j3*topedge illim = 1 + 1*leftedge iulim = np - 1*rightedge do 20 k=2,l-1 do 20 j=jllim,julim do 20 i=illim,iulim 20 tempcr2(1,1,1)=max(tempcr2(1,1,1), . .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)) 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 return end subroutine metryc(x,y,z,n1,n2,n3) dimension x(n1),y(n2),z(n3) include 'param.nml' include 'param.misc' include 'msg.inc' common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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 do 1 k=1,l 1 gmul(k)=(zb-z(k)) do 2 j=1,mp do 2 i=1,np 2 gi(i,j)=zb/(zb-zs(i,j)) call update(gi,np,mp,1,np,mp) illim = 1 + 1*leftedge iulim = np - 1*rightedge do 41 j=1,mp do 41 i=illim,iulim 41 c13(i,j)=.5*dxi*(1./gi(i+1,j)-1./gi(i-1,j))*gi(i,j) if (leftedge.eq.1) then do j=1,mp c13(1,j)=0.+ibcx*.5*dxi*(1./gi(2,j)-1./gi(-1,j))*gi(1,j) end do end if if (rightedge.eq.1) then do j=1,mp c13(np,j)=0.+ibcx*.5*dxi*(1./gi(np+2,j)-1./ . gi(np-1,j))*gi(np+1,j) end do end if jllim = 1 + j3*botedge julim = mp - j3*topedge do 51 j=jllim,julim do 51 i=1,np 51 c23(i,j)=.5*dyi*(1./gi(i,j+j3)-1./gi(i,j-j3))*gi(i,j) if (botedge.eq.1) then do i=1,np c23(i,1)=0.+ibcy*.5*dyi*(1./gi(i,1+j3)-1./gi(i,-j3))* . gi(i,1) end do end if if (topedge.eq.1) then do i=1,np c23(i,mp)=0.+ibcy*.5*dyi*(1./gi(i,mp+1+j3)-1./gi(i,mp-j3))* . gi(i,mp+1) end do end if call update(c13,np,mp,1,np,mp) call update(c23,np,mp,1,np,mp) return end #if (ANALIZE == 0) subroutine potprs(u,v,w,p,n1,m1,l1) include 'param.nml' include 'param.misc' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 compute pressure from the potential 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) real globsum c dimension tmp(1-ih:np+ih, 1-ih:mp+ih, l) nml=n*m*l psum=0. if(igrid.eq.0) then 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) psum=globsum(p,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) c psum=fsum(p,np,mp,l) psum=psum/float(nml) 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 call update(p,np,mp,l,np,mp) else call update(p,np,mp,l,np,mp) illim = 1 + 1*leftedge jllim = 1 + j3*botedge 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) c tmp=0.0 c do k=2,l c do j=jllim,mp c do i=illim,np c tmp(i,j,k)=p(i,j,k) c end do c end do c end do psum=globsum(p,1-ih,np+ih,1-ih,mp+ih,1,l,illim,np,jllim,mp,2,l) c psum=fsum(tmp,np,mp,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 c print 100, psum 100 format(2x,'potential initalisation, psum=', e11.4) return end subroutine precon(rhs,p,r,c11,c22,c33,cf00,cf33,fd,iflg, . n1,n2,n3,e,f,px,py,jfl) include 'param.nml' include 'param.misc' include 'msg.inc' dimension rhs(1-ih:np+ih, 1-ih:mp+ih, l), . p(1-ih:np+ih, 1-ih:mp+ih, l), . r(1-ih:np+ih, 1-ih:mp+ih, l), . c11(1-ih:np+ih, 1-ih:mp+ih, l), . c22(1-ih:np+ih, 1-ih:mp+ih, l), . c33(1-ih:np+ih, 1-ih:mp+ih, l), . cf33(1-ih:np+ih, 1-ih:mp+ih, l), . cf00(1-ih:np+ih, 1-ih:mp+ih, l), . fd(1-ih:np+ih, 1-ih:mp+ih, l), . e(1-ih:np+ih, 1-ih:mp+ih, 0:l-1), . f(1-ih:np+ih, 1-ih:mp+ih, 0:l-1), . px(1-ih:np+ih, 1-ih:mp+ih, l), . py(1-ih:np+ih, 1-ih:mp+ih, l), . dgh(1-ih:np+ih, 1-ih:mp+ih, l), . po(1-ih:np+ih, 1-ih:mp+ih, l) 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/cyclbc/ ibcx,ibcy,ibcz,irlx,irly real globmax data beta/-1.e15/ data itr,line/2,1/ c data itr,line/1,0/ if(iflg.eq.0) then do k=1,n3 do j=1,mp do i=1,np p(i,j,k)= rhs(i,j,k) end do end do end do return endif omg=.7 oms=1.-omg dxi2=0.25*dxi*dxi dyi2=0.25*dyi*dyi dzi2=0.25*dzi*dzi do k=1,n3 do j=1,mp do i=1,np c11(i,j,k)=cf00(i,j,k)*dxi2 c22(i,j,k)=(1.+fd(i,j,k)**2)*cf00(i,j,k)*dyi2 c33(i,j,k)=cf33(i,j,k)*cf00(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 update(c11,np,mp,l,np,mp) call update(c22,np,mp,l,np,mp) do k=1,l do j=1,mp illim = 1 + 1*leftedge iulim = np - 1*rightedge do i=illim,iulim dgh(i,j,k)=c11(i+1,j,k)+c11(i-1,j,k) enddo if (leftedge.eq.1) then dgh(1,j,k)=c11(2,j,k)+ibcx*c11(-1,j,k) end if if (rightedge.eq.1) then dgh(np,j,k)=ibcx*c11(np+2,j,k)+c11(np-1,j,k) end if enddo if(j3.eq.1) then jllim = 1 + j3*botedge julim = mp - j3*topedge 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 do i=1,np if (botedge.eq.1) then dgh(i,1,k)=dgh(i,1,k)+c22(i,1+j3,k)+ibcy*c22(i,-j3,k) end if if (topedge.eq.1) then dgh(i,mp,k)=dgh(i,mp,k)+ibcy*c22(i,mp+1+j3,k)+c22(i,mp-j3,k) end if enddo endif enddo endif if(jfl.eq.0) then if(line.eq.0) then do k=1,n3 do j=1,mp do i=1,np e(i,j,k-1)=(abs(c11(i,j,k))+abs(c22(i,j,k)))/rho(i,j,k) enddo enddo enddo beta=-1.e15 beta=max(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 return endif beti=1./beta*(1-line) do 100 it=1,itr do k=1,n3 do j=1,mp do i=1,np r(i,j,k)=r(i,j,k)+rho(i,j,k)*(beti*p(i,j,k)-rhs(i,j,k)) . +dgh(i,j,k)*p(i,j,k) enddo enddo enddo do j=1,mp do i=1,np e(i,j,0)=1. f(i,j,0)=0. dn=rho(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))+rho(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=rho(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 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 end do end do endif if(it.eq.itr) go to 101 call update(p,np,mp,l,np,mp) illim = 1 + 1*leftedge iulim = np - 1*rightedge do 1 k=1,l do 1 j=1,mp do 1 i=illim,iulim 1 px(i,j,k)=c11(i,j,k)*(p(i+1,j,k)-p(i-1,j,k)) 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 if(j3.eq.1) then jllim = 1 + j3*botedge julim = mp - j3*topedge do 28 k=1,l do 28 i=1,np do 28 j=jllim,julim 28 py(i,j,k)= c22(i,j,k)*(p(i,j+j3,k)-p(i,j-j3,k)) 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 else do k=1,l do j=1,mp do i=1,np py(i,j,k)=0. end do end do end do endif call update(px,np,mp,l,np,mp) illim = 1 + 1*leftedge iulim = np - 1*rightedge do 91 i=illim,iulim do 91 j=1,mp do 91 k=1,l 91 r(i,j,k)=px(i+1,j,k)-px(i-1,j,k) 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 if(j3.eq.1) then call update(py,np,mp,l,np,mp) jllim = 1 + j3*botedge julim = mp - j3*topedge do k=1,l do i=1,np do j=jllim,julim 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 (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 endif 100 continue 101 continue return end subroutine prforc(p,pfx,pfy,pfz,u,v,w,c,fc,fd,n1,n2,n3, . px,py,pz) include 'param.nml' include 'param.misc' include 'msg.inc' compute available storage in // include 'param.ior' include 'param.icw' parameter (nml=n*m*l,iuse=3*nml+(2*ior+1)*nml) 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) 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/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/indx/ e1,e2,e3 cc data e1,e2,e3/1.5,-0.5,0./ data e1,e2,e3/1.875,-1.250,0.375/ 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), . 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 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, l), . pe(1-ih:np*2+ih, 1-ih:mp*2+ih, l*2) call update(p,np,mp,l,np,mp) nm=n*m ml=m*l if(igrid.eq.0) then dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi compute pressure derivatives everywhere illim = 1 + 1*leftedge iulim = np - 1*rightedge 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 (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 if(j3.eq.1) then jllim = 1 + j3*botedge julim = mp - j3*topedge do 28 k=1,l do 28 j=jllim,julim do 28 i=1,np 28 py(i,j,k)= dyil*(p(i,j+j3,k)-p(i,j-j3,k)) if (botedge.eq.1) then do 2 k=1,l do 2 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)) 2 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 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 else dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi construct extended, auxiliary pressure field with either cyclic or extrapolated boundaries do 4 k=2,l do 4 j=1+j3,m do 4 i=2,n 4 pe(i,j,k)=p(i,j,k) do 41 j=1+j3,m do 41 i=2,n 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)=plex 41 pe(i,j,l+1)=prex do 42 k=1,l+1 do 42 j=1+j3,m 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) 42 pe(n+1,j,k)=(1-ibcx)*prex+ibcx*pe(2,j,k) if(j3.eq.1) then do 43 k=1,l+1 do 43 i=1,n+1 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) 43 pe(i,m+1,k)=(1-ibcy)*prex+ibcy*pe(i,1+j3,k) endif compute pressure derivatives everywhere if(j3.eq.1) then do 5 k=1,l do 5 j=1,m do 5 i=1,n 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,n 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,m do 52 i=1,n 52 py(i,j,k)=0. endif endif compute interior pressure forces do 10 k=2-ibcz,l-1+ibcz do 10 j=1,mp do 10 i=1,np g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=g13**2+(1+fd(i,j,k)**2)*g23**2 . +2*fc(i,j,k)*fd(i,j,k)*g23*gi(i,j) . +(1.+fc(i,j,k)**2)*gi(i,j)**2 pfx(i,j,k)=u(i,j,k) . -(a11*px(i,j,k)+a12*py(i,j,k)+a13*pz(i,j,k)) pfy(i,j,k)=v(i,j,k) . -(a21*px(i,j,k)+a22*py(i,j,k)+a23*pz(i,j,k)) 10 pfz(i,j,k)=w(i,j,k) . -(a31*px(i,j,k)+a32*py(i,j,k)+a33*pz(i,j,k)) compute pressure forces at the boundaries 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 if (botedge.eq.1) then jllim=1+j3-ibcy else jllim=1 end if if (topedge.eq.1) then julim=mp-j3+ibcy else julim=mp end if do 11 i=illim,iulim,np-1 ii=1+i/np do 111 j=jllim,julim do 111 k=2-ibcz,l-1+ibcz g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=g13**2+(1+fd(i,j,k)**2)*g23**2 . +2*fc(i,j,k)*fd(i,j,k)*g23*gi(i,j) . +(1.+fc(i,j,k)**2)*gi(i,j)**2 coefi=(1.+fc(i,j,k)**2+fd(i,j,k)**2)/c(i,j,k) pfx(i,j,k)= ub(j,k,ii)*coefi pxb=( u(i,j,k)-pfx(i,j,k)-(a12*py(i,j,k)+a13*pz(i,j,k)) )/a11 pfy(i,j,k)=v(i,j,k)-(a21*pxb+a22*py(i,j,k)+a23*pz(i,j,k)) 111 pfz(i,j,k)= . icw*(w(i,j,k)-(a31*pxb+a32*py(i,j,k)+a33*pz(i,j,k))) . +(1-icw)*(g13*pfx(i,j,k)+g23*pfy(i,j,k)) 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 j=jllim,julim,mp-j3 jj=1+j/mp do 1121 k=2-ibcz,l-1+ibcz g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=g13**2+(1.+fd(i,j,k)**2)*g23**2 . +2*fc(i,j,k)*fd(i,j,k)*g23*gi(i,j) . +(1.+fc(i,j,k)**2)*gi(i,j)**2 coefi=(1.+fc(i,j,k)**2+fd(i,j,k)**2)/c(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)-a13*pz(i,j,k) b=v(i,j,k)-pfy(i,j,k)-a23*pz(i,j,k) pxb=(a22*a-a12*b)/(a11*a22-a12*a21) pyb=(a11*b-a21*a)/(a11*a22-a12*a21) 1121 pfz(i,j,k)=w(i,j,k)-(a31*pxb+a32*pyb+a33*pz(i,j,k)) 112 continue endif 11 continue endif 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 if (leftedge.eq.1) then illim=2-ibcx else illim=1 end if if (rightedge.eq.1) then iulim=np-1+ibcx else iulim=np end if do 12 j=jllim,julim,mp-j3 jj=1+j/mp do 121 k=2-ibcz,l-1+ibcz do 121 i=illim,iulim g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=g13**2+(1.+fd(i,j,k)**2)*g23**2 . +2*fc(i,j,k)*fd(i,j,k)*g23*gi(i,j) . +(1.+fc(i,j,k)**2)*gi(i,j)**2 coefi=(1.+fc(i,j,k)**2+fd(i,j,k)**2)/c(i,j,k) pfy(i,j,k)= vb(i,k,jj)*coefi pyb=( v(i,j,k)-pfy(i,j,k)-(a21*px(i,j,k)+a23*pz(i,j,k)) )/a22 pfx(i,j,k)=u(i,j,k)-(a11*px(i,j,k)+a12*pyb+a13*pz(i,j,k)) 121 pfz(i,j,k)= . icw*(w(i,j,k)-(a31*px(i,j,k)+a32*pyb+a33*pz(i,j,k))) . +(1-icw)*(g13*pfx(i,j,k)+g23*pfy(i,j,k)) 12 continue endif if(ibcz.eq.0) then do 20 k=1,l,l-1 kk=1+k/l jllim = 1 + (j3-ibcy)*botedge julim = mp + (-j3+ibcy)*topedge illim = 1 + (1-ibcx)*leftedge iulim = np + (-1+ibcx)*rightedge do 21 j=jllim,julim do 21 i=illim,iulim g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=g13**2+(1.+fd(i,j,k)**2)*g23**2 . +2*fc(i,j,k)*fd(i,j,k)*g23*gi(i,j) . +(1.+fc(i,j,k)**2)*gi(i,j)**2 coefi=(1.+fc(i,j,k)**2+fd(i,j,k)**2)/c(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pzb=(w(i,j,k)-pfz(i,j,k)-(a31*px(i,j,k)+a32*py(i,j,k)))/a33 pfx(i,j,k)=u(i,j,k)-(a11*px(i,j,k)+a12*py(i,j,k)+a13*pzb) 21 pfy(i,j,k)=v(i,j,k)-(a21*px(i,j,k)+a22*py(i,j,k)+a23*pzb) 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 i=illim,iulim,np-1 ii=1+i/np jllim = 1 + (j3-ibcy)*botedge julim = mp + (-j3+ibcy)*topedge do 2111 j=jllim,julim g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=g13**2+(1.+fd(i,j,k)**2)*g23**2 . +2*fc(i,j,k)*fd(i,j,k)*g23*gi(i,j) . +(1.+fc(i,j,k)**2)*gi(i,j)**2 coefi=(1.+fc(i,j,k)**2+fd(i,j,k)**2)/c(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pfx(i,j,k)= ub(j,k,ii)*coefi pzb=(a11*(w(i,j,k)-pfz(i,j,k))-a31*(u(i,j,k)-pfx(i,j,k)) . -(a11*a32-a31*a12)*py(i,j,k) )/(a11*a33-a31*a13) pxb=(u(i,j,k)-pfx(i,j,k)-(a12*py(i,j,k)+a13*pzb))/a11 2111 pfy(i,j,k)=v(i,j,k)-(a21*pxb+a22*py(i,j,k)+a23*pzb) 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 2112 j=jllim,julim,mp-j3 jj=1+j/mp coefi=(1.+fc(i,j,k)**2+fd(i,j,k)**2)/c(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pfx(i,j,k)= ub(j,k,ii)*coefi 2112 pfy(i,j,k)= vb(i,k,jj)*coefi endif 211 continue endif 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 if (leftedge.eq.1) then illim=2-ibcx else illim=1 end if if (rightedge.eq.1) then iulim=np-1+ibcx else iulim=np end if do 212 j=jllim,julim,mp-j3 jj=1+j/mp do 2121 i=illim,iulim g13=c13(i,j)*gmul(k) g23=c23(i,j)*gmul(k) a11=1. a12= fc(i,j,k) a13= g13+fc(i,j,k)*g23-fd(i,j,k)*gi(i,j) a21=-fc(i,j,k) a22=1.+fd(i,j,k)**2 a23= (1.+fd(i,j,k)**2)*g23-fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a31= g13-fc(i,j,k)*g23+fd(i,j,k)*gi(i,j) a32= (1.+fd(i,j,k)**2)*g23+fc(i,j,k)*g13 . +fc(i,j,k)*fd(i,j,k)*gi(i,j) a33=g13**2+(1.+fd(i,j,k)**2)*g23**2 . +2*fc(i,j,k)*fd(i,j,k)*g23*gi(i,j) . +(1.+fc(i,j,k)**2)*gi(i,j)**2 coefi=(1.+fc(i,j,k)**2+fd(i,j,k)**2)/c(i,j,k) pfz(i,j,k)= ob(i,j,kk)*coefi pfy(i,j,k)= vb(i,k,jj)*coefi pzb=( a22*(w(i,j,k)-pfz(i,j,k))-a32*(v(i,j,k)-pfy(i,j,k)) . -(a31*a22-a32*a21)*px(i,j,k) )/(a33*a22-a32*a23) pyb=(v(i,j,k)-pfy(i,j,k)-(a21*px(i,j,k)+a23*pzb))/a22 2121 pfx(i,j,k)=u(i,j,k)-(a11*px(i,j,k)+a12*pyb+a13*pzb) 212 continue endif 20 continue endif do 99 k=1,l do 99 j=1,mp do 99 i=1,np coef=c(i,j,k)/(1.+fc(i,j,k)**2+fd(i,j,k)**2) pfx(i,j,k)=coef*pfx(i,j,k) pfy(i,j,k)=coef*pfy(i,j,k) 99 pfz(i,j,k)=coef*pfz(i,j,k) c special for the noslip c do j=1,mp c do i=1,np c pfx(i,j,1)=0. c pfy(i,j,1)=0. c pfz(i,j,1)=0. c enddo c enddo c end of special return end Cendif ANALIZE == 0 #endif subroutine r_lipsch 1 (u,v,w,q,vt,d,gi,n1,m1,l1,g1,g2,g3,cr1,cr2,lagr1,iprnt) include 'param.nml' include 'param.misc' 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 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), . q(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . vt(1-ih:np+ih, 1-ih:mp+ih, l), . gi(1-ih:np+ih, 1-ih:mp+ih), . temp(1-ih:np+ih, 1-ih:mp+ih, l), . tempcr2(1-ih:1+ih, 1-ih:1+ih, l) real globmax nml=n*m*l nm=n*m check courant number with correction for rain if(lagr1.eq.1) then do k=1,l do j=1,mp do i=1,np vt(i,j,k)=d(i,j,k)*gi(i,j) enddo enddo end do do k=1,l do j=1,mp do i=1,np vt(i,j,k)= 1 -36.34*(amax1(0.,q(i,j,k))*1.e-3*vt(i,j,k))**.1346 1 *sqrt(rh00/vt(i,j,k)) vt(i,j,k)=amax1(2.,vt(i,j,k)) enddo end do end do cr1=0. 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)+vt(i,j,k)) end do end do end do c temp=g1*abs(u)+g2*abs(v)+g3*abs(w+vt) cr1=max(cr1,globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)) tempcr2(1,1,1)=-1.e15 jllim = 1 + j3*botedge julim = mp - j3*topedge illim = 1 + 1*leftedge iulim = np - 1*rightedge do 2 k=2,l-1 do 2 j=jllim,julim do 2 i=illim,iulim 2 tempcr2(1,1,1)=max(tempcr2(1,1,1), . .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)+vt(i+1,j,k)-w(i-1,j,k)-vt(i-1,j,k) ), 3.5*g2*abs( w(i,j+j3,k)+vt(i,j+j3,k)-w(i,j-j3,k)-vt(i,j-j3,k) ), 3.5*g3*abs( w(i,j,k+1)+vt(i,j,k+1)-w(i,j,k-1) )-vt(i,j,k-1)) cr2=globmax(tempcr2,1-ih,1+ih,1-ih,1+ih,1,1,1,1,1,1,1,1) else do k=1,l do j=1,mp do i=1,np vt(i,j,k)=d(i,j,k)*gi(i,j) enddo enddo end do do k=1,l do j=1,mp do i=1,np vt(i,j,k)= 1 -36.34*(amax1(0.,q(i,j,k))*1.e-3*vt(i,j,k))**.1346 1 *sqrt(rh00/vt(i,j,k))*g3*d(i,j,k) enddo end do end do cr1=0. do k=1,l do j=1,mp do i=1,np temp(i,j,k)=0. end do end do end do 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)+vt(i,j,k))) . /d(i,j,k) end do end do end do c temp=(abs(u)+abs(v)+abs(w+vt))/d cr1=max(cr1, globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp, . 1,l)) tempcr2(1,1,1)=-1.e15 jllim = 1 + j3*botedge julim = mp - j3*topedge illim = 1 + 1*leftedge iulim = np - 1*rightedge gy=j3*g2+(1-j3)*1. do 20 k=2,l-1 do 20 j=jllim,julim do 20 i=illim,iulim 20 tempcr2(1,1,1)=max(tempcr2(1,1,1), . .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( 3 w(i+1,j,k)+vt(i+1,j,k)-vt(i-1,j,k)-w(i-1,j,k) )/d(i,j,k), 3 .5*g2/g3*abs( 3 w(i,j+j3,k)+vt(i,j+j3,k)-vt(i,j-j3,k)-w(i,j-j3,k) )/d(i,j,k), 3 .5*g3/g3*abs( 3 w(i,j,k+1)+vt(i,j,k+1)-vt(i,j,k-1)-w(i,j,k-1) )/d(i,j,k)) 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 201 format(1x,'rain_cour,rain_lipsh:',2e11.4) end if endif return end #if (ANALIZE == 0) #if (MOISTMOD > 0) #if (MOISTMOD == 1) subroutine rain( qr,ft,fqv,fqc,fqr,x0,y0,z0, . u,v,w,bx,by,bz,xr,yr,zr,n1,m1,l1 ) include 'param.nml' include 'param.misc' include 'msg.inc' dimension 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), . ft(1-ih:np+ih, 1-ih:mp+ih, l), . 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), . 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), . 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), . xr(1-ih:np+ih, 1-ih:mp+ih, l), . yr(1-ih:np+ih, 1-ih:mp+ih, l), . zr(1-ih:np+ih, 1-ih:mp+ih, l) parameter (nml=n*m*l,nm=n*m,ml=m*l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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/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) c common/advbc/ wbc(n,m,2),ubc(m,l,2),vbc(n,l,2) real kappa vtrmv(qq,rro)=(36.34*((rh00/rro)**.5)* . ((rro*1.e-3*max(0.,qq))**.1346)) ifirst=1 gc1=dt*dxi gc2=dt*dyi gc3=dt*dzi gamma=-.3654 kappa= .1346 if(lagr.eq.0) then cc --------> treatment of rain in eulerian model: do k=2,l do j=1,mp do i=1,np dens= 0.5*(rho(i,j,k)+rho(i,j,k-1))*gi(i,j) qrv = 0.5*( qr(i,j,k)+ qr(i,j,k-1)) vtr=vtrmv(qrv,dens) fqv(i,j,k)=z0(i,j,k)-vtr*dens*gc3 end do end do end do compute boundary velocities for rain do j=1,mp do i=1,np dens1= 0.5*(rho(i,j,2)+rho(i,j,1))*gi(i,j) qrv1 = 0.5*( qr(i,j,2)+ qr(i,j,1)) bx(i,j,1) = vtrmv(qrv1,dens1)*dens1*gc3 wbc(i,j,1) = wbc(i,j,1) - bx(i,j,1) densl= 0.5*(rho(i,j,l-1)+rho(i,j,l))*gi(i,j) qrvl = 0.5*( qr(i,j,l-1)+ qr(i,j,l)) bx(i,j,2) = vtrmv(qrvl,densl)*densl*gc3 wbc(i,j,2) = wbc(i,j,2) - bx(i,j,2) end do end do do k=1,l do j=1,mp do i=1,np qr(i,j,k)=qr(i,j,k)+.5*fqr(i,j,k)*dt end do end do end do call advec(qr,x0,y0,fqv,8,ifirst) c recover original b.c. do j=1,mp do i=1,np wbc(i,j,1) = wbc(i,j,1) + bx(i,j,1) wbc(i,j,2) = wbc(i,j,2) + bx(i,j,2) end do end do else cc --------> treatment of rain in lagrangian model: do k=1,l do j=1,mp do i=1,np dens=rho(i,j,k)*gi(i,j) fqv(i,j,k)=vtrmv(qr(i,j,k),dens) enddo end do enddo cc calculate betas: do k=1,l kp=min0(l,k+1) do j=1,mp do i=1,np bx(i,j,k)= -.5*gc3*(u(i,j,kp)-u(i,j,k)) by(i,j,k)= -.5*gc3*(v(i,j,kp)-v(i,j,k)) bz(i,j,k)=1.-.5*gc3*(w(i,j,kp)-w(i,j,k)) enddo enddo end do cc compute rainfall rate source term (qr*vt)/rho * d/dz[rho/G]+Fs do k=2,l-1 do j=1,mp do i=1,np ft(i,j,k)=(1.+gamma)*dzi*fqv(i,j,k)*qr(i,j,k) . *gi(i,j)*( rho(i,j,k+1)-rho(i,j,k-1) ) . /( rho(i,j,k+1)+rho(i,j,k-1) ) . +0.5*fqr(i,j,k) enddo enddo end do do j=1,mp do i=1,np ft(i,j,1)=(1.+gamma)*dzi*fqv(i,j,1)*qr(i,j,1) . *gi(i,j)*( rho(i,j,2)-rho(i,j,1) ) . /( rho(i,j,2)+rho(i,j,1) )*2. . +0.5*fqr(i,j,1) ft(i,j,l)=(1.+gamma)*dzi*fqv(i,j,l)*qr(i,j,l) . *gi(i,j)*( rho(i,j,l)-rho(i,j,l-1) ) . /( rho(i,j,l)+rho(i,j,l-1) ) . +0.5*fqr(i,j,l) enddo end do do j=1,mp do i=1,np qr(i,j,1)=amax1(0., qr(i,j,1)+dt*ft(i,j,1)) fqv(i,j,1)=(1.+kappa)*fqv(i,j,1) enddo end do calculate departure point for rain; use ft, fqv, fqc and fqr as scratches compute first guess c ifgues=1 - simple approach; DEFAULT OPTION c ifgues=2 - full approach coded in 2D only ifgues=1 if(ifgues.eq.1) then CC SIMPLE APPROACH: do k=1,l kp=min0(l,k+1) do j=1,mp do i=1,np fqc(i,j,k)=( fqv(i,j,kp)-fqv(i,j,k ) )*dzi enddo enddo end do do 392 k=1,l do 392 j=1,mp do 392 i=1,np xr(i,j,k)=x0(i,j,k)+gc1*gi(i,j)*bx(i,j,k)*fqv(i,j,k) yr(i,j,k)=y0(i,j,k)+gc2*gi(i,j)*by(i,j,k)*fqv(i,j,k) zr(i,j,k)=( z0(i,j,k)+gc3*gi(i,j)*bz(i,j,k)*( . fqv(i,j,k)-fqc(i,j,k)*(k-1)*dz) ) . /( 1.-dt*bz(i,j,k)*fqc(i,j,k) ) xr(i,j,k)=amax1(1.,amin1(float(n),xr(i,j,k))) yr(i,j,k)=amax1(1.,amin1(float(m),yr(i,j,k))) zr(i,j,k)=amax1(1.,amin1(float(l),zr(i,j,k))) 392 continue endif if(ifgues.eq.2) then CC FULL APPROACH: if(j3.eq.1) stop 'not ready' do k=1,l kp=min0(l,k+1) do i=1,np if (rightedge.eq.1) then ip=min0(np,i+1) else ip=i+1 end if fqc(i,1,k)=( fqv(i,1,kp)-fqv(i,1,k ) )*dzi fqr(i,1,k)=( fqv(ip,1,k)-fqv(i,1,k ) )*dxi enddo enddo do 792 k=1,l do 792 i=1,np ia=i+(npos-1)*np xx=x0(i,1,k)-float(ia-1) zz=z0(i,1,k)-float(k-1) bottom=1.-dt*(bz(i,1,k)*fqc(i,1,k)-bx(i,1,k)*fqr(i,1,k)) xst=(xx*(1.-dt*bz(i,1,k)*fqc(i,1,k)) + 1 gc1*bx(i,1,k)*(fqv(i,1,k)+fqc(i,1,k)*zz))/bottom zst=(zz*(1.-dt*bx(i,1,k)*fqr(i,1,k)) + 1 gc3*bz(i,1,k)*(fqv(i,1,k)+fqr(i,1,k)*xx))/bottom xr(i,1,k)=xst+float(ia-1) zr(i,1,k)=zst+float(k-1) xr(i,1,k)=amax1(1.,amin1(float(n),xr(i,1,k))) yr(i,1,k)=amax1(1.,amin1(float(m),yr(i,1,k))) zr(i,1,k)=amax1(1.,amin1(float(l),zr(i,1,k))) 792 continue endif cc corrector for rain departure point cc number of iteration (1 SHOULD BE DEFAULT) itera=1 if(itera.gt.1) then do k=1,l do j=1,mp do i=1,np ft(i,j,k)=fqv(i,j,k) end do end do enddo endif do itr=1,itera call advec(fqv,xr,yr,zr,8,ifirst) do 394 k=1,l do 394 j=1,mp do 394 i=1,np xr(i,j,k)=x0(i,j,k)+gc1*gi(i,j)*bx(i,j,k)*fqv(i,j,k) yr(i,j,k)=y0(i,j,k)+gc2*gi(i,j)*by(i,j,k)*fqv(i,j,k) zr(i,j,k)=z0(i,j,k)+gc3*gi(i,j)*bz(i,j,k)*fqv(i,j,k) xr(i,j,k)=amax1(1.,amin1(float(n),xr(i,j,k))) yr(i,j,k)=amax1(1.,amin1(float(m),yr(i,j,k))) zr(i,j,k)=amax1(1.,amin1(float(l),zr(i,j,k))) 394 continue if(itr.lt.itera) then do k=1,l do j=1,mp do i=1,np fqv(i,j,k)=ft(i,j,k) enddo end do end do endif enddo cc call advec(qr,xr,yr,zr,8,ifirst) cc --------> end of treatment of rain in lagrangian model endif return end subroutine water(th,qv,qc,qr,fth,fqv,fqc,fqr, * n1,m1,l1,tau,rx,ry,ith,iqw,rhl,thetme, * rfl,ss) include 'param.nml' include 'param.misc' include 'msg.inc' dimension th(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), . fth(1-ih:np+ih, 1-ih:mp+ih, l), . 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), . tau(l, 1-ih:np+ih, 1-ih:mp+ih) dimension rx(n1), ry(m1) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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,hlatv,hlats,hlatf common/rainc/ 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) dimension rhl(1-ih:np+ih, 1-ih:mp+ih, l), . thetme(1-ih:np+ih, 1-ih:mp+ih, l), . rfl(1-ih:np+ih, 1-ih:mp+ih, l), . ss(1-ih:np+ih, 1-ih:mp+ih, l) condensation/evaporation a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg nm=n*m nml=n*m*l do 10 k=1,l do 100 j=1,mp do 100 i=1,np rhl(i,j,k)=rho(i,j,k)*gi(i,j) thetme(i,j,k)=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme(i,j,k)**e thi=1./th(i,j,k) y=b*thetme(i,j,k)*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) ccc linearized condensation rate is next: cf1=thetme(i,j,k)*thetme(i,j,k)*thi*thi cf1=c*cf1*pre/(pre-ees)*d delta=(qv(i,j,k)-qvs)/(1.+qvs*cf1) c---> ccc 2nd order correction is next: c cf2=d*thetme(i,j,k) c cf2=pre/(pre-ees)*cf2*thi**3 c 1 *((pre+ees)/(pre-ees)*cf2*thi-2.) c cf3=(c*thetme(i,j,k))**2 c r=(1.+qvs*cf1) / (qvs*cf2*cf3) c delta=sqrt(r**2+2.*delta*r)-r c---> ccc one Newton-Raphson iteration is next: thi=1./(th(i,j,k)+c*thetme(i,j,k)*delta) y=b*thetme(i,j,k)*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) fff=qv(i,j,k)-delta-qvs cf1=thetme(i,j,k)*thetme(i,j,k)*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 c---> c delta=amin1( qv(i,j,k), amax1(qv(i,j,k)-qc(i,j,k),delta) ) delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) ccc ccccccccccccccccccccccccccccccccccccccccccccccccccc cccc NO EVAPORATION: cc delta=amax1(0.,delta) ccccccccccccccccccccccccccccccccccccccccccccccccccc qv(i,j,k)=qv(i,j,k)-delta c qc(i,j,k)=qc(i,j,k)-qv(i,j,k) qc(i,j,k)=qc(i,j,k)+delta th(i,j,k)=th(i,j,k)+c*thetme(i,j,k)*delta delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) fqv(i,j,k)=-delta*2.*dti fth(i,j,k)=-c*thetme(i,j,k)*fqv(i,j,k) 100 continue 10 continue compute gravity wave absorber (implicit) do 20 k=1,l do 20 j=1,mp do 20 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp relt=rx(ia)+ry(ja)-rx(ia)*ry(ja) tth=ith*tau(k,i,j)*(1.-relt)+relt tqv=iqw*tau(k,i,j)*(1.-relt)+relt th(i,j,k)=(th(i,j,k)+tth*the(i,j,k)*dt*.5)/(1.+.5*tth*dt) qv(i,j,k)=(qv(i,j,k)+tqv*qve(i,j,k)*dt*.5)/(1.+.5*tqv*dt) qc(i,j,k)=(qc(i,j,k)+ 0. )/(1.+.5*tqv*dt) fth(i,j,k)=fth(i,j,k)-tth*(th(i,j,k)-the(i,j,k)) fqv(i,j,k)=fqv(i,j,k)-tqv*(qv(i,j,k)-qve(i,j,k)) fqc(i,j,k)=-fqv(i,j,k) 20 continue compute moist forces update do k=1,l do j=1,mp do i=1,np pre=1.e5*thetme(i,j,k)**e thi=1./th(i,j,k) y=b*thetme(i,j,k)*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) ss(i,j,k)=amin1(qv(i,j,k)/qvs-1., 0.) enddo end do end do cwojt pi=acos(-1.) cwojt dtrs=0.3*qctr cwojt qcstr=pi/dtrs*(amin1(qctr+dtrs, amax1(qctr,qc(i,j,k)))-qctr) cwojt racl=rac*0.5*(1.-cos(qcstr)) do 30 k=1,l do 30 j=1,mp do 30 i=1,np dcol=2.*( rac*amax1(qc(i,j,k)-qctr, 0.) . + rc*qc(i,j,k)*amax1(0.,qr(i,j,k))**.875 ) dcol=amin1(dcol, 2.*dti*qc(i,j,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.,qr(i,j,k)) qvs=qv(i,j,k)/(1.+ss(i,j,k)) bottom=1.e-3*rhl(i,j,k)*(5.4e5 + 2.55e6/(presmb*qvs)) ventc=1.6+124.9*rhqr**.2046 devp=2.*ss(i,j,k)*ventc*rhqr**.525 / bottom devp=amax1(devp, -2.*dti*qr(i,j,k)-dcol) cc fqr(i,j,k)=devp+dcol fqc(i,j,k)=fqc(i,j,k)-dcol fqv(i,j,k)=fqv(i,j,k)-devp fth(i,j,k)=fth(i,j,k)+c*devp*thetme(i,j,k) 30 continue call update(qv, np,mp,l,np,mp) call update(qc, np,mp,l,np,mp) call update(th, np,mp,l,np,mp) call update(fqv,np,mp,l,np,mp) call update(fth,np,mp,l,np,mp) call update(fqc,np,mp,l,np,mp) call update(fqr,np,mp,l,np,mp) return end subroutine rain_snow( qr,ft,fqv,fqc,fqr,x0,y0,z0, . u,v,w,bx,by,bz,xr,yr,zr,n1,m1,l1 ) include 'param.nml' include 'param.misc' include 'msg.inc' dimension 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), . ft(1-ih:np+ih, 1-ih:mp+ih, l), . 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), . 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), . 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), . xr(1-ih:np+ih, 1-ih:mp+ih, l), . yr(1-ih:np+ih, 1-ih:mp+ih, l), . zr(1-ih:np+ih, 1-ih:mp+ih, l) parameter (nml=n*m*l,nm=n*m,ml=m*l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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/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/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) 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 common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf real lambdr,lambds,massr,masss cc statement functions: 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 pi=3.14159 ifirst=1 gc1=dt*dxi gc2=dt*dyi gc3=dt*dzi if(lagr.eq.0) then cc --------> treatment of rain in eulerian model: do k=2,l do j=1,mp do i=1,np dens= 0.5*(rho(i,j,k)+rho(i,j,k-1))*gi(i,j) qrv = 0.5*( qr(i,j,k)+ qr(i,j,k-1)) coe_l=comb(tme(i,j,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 fqv(i,j,k)=z0(i,j,k)-vtf*dens*gc3 end do end do end do compute boundary velocities for rain do j=1,mp do i=1,np dens1= 0.5*(rho(i,j,2)+rho(i,j,1))*gi(i,j) qrv1 = 0.5*( qr(i,j,2)+ qr(i,j,1)) coe_l=comb(tme(i,j,1),tdn,tup,0.,1.) ! liquid part qpr=qrv1*coe_l ! divide between rain and snow qps=qrv1-qpr ! divide between rain and snow lambdr=(ar*anor*gamb1r/dens1/(qpr+1.e-6))**(1./(1.+br)) ! lambda lambds=(as*anos*gamb1s/dens1/(qps+1.e-6))**(1./(1.+bs)) ! lambda vtr=cr*gambd1r/gamb1r / lambdr**dr ! terminal velocity vts=cs*gambd1s/gamb1s / lambds**ds ! terminal velocity bx(i,j,1) = coe_l*vtr+(1.-coe_l)*vts ! TERMINAL VELOCITY bx(i,j,1) = bx(i,j,1) * dens1*gc3 wbc(i,j,1) = wbc(i,j,1) - bx(i,j,1) densl= 0.5*(rho(i,j,l-1)+rho(i,j,l))*gi(i,j) qrvl = 0.5*( qr(i,j,l-1)+ qr(i,j,l)) coe_l=comb(tme(i,j,l),tdn,tup,0.,1.) ! liquid part qpr=qrvl*coe_l ! divide between rain and snow qps=qrvl-qpr ! divide between rain and snow lambdr=(ar*anor*gamb1r/densl/(qpr+1.e-6))**(1./(1.+br)) ! lambda lambds=(as*anos*gamb1s/densl/(qps+1.e-6))**(1./(1.+bs)) ! lambda vtr=cr*gambd1r/gamb1r / lambdr**dr ! terminal velocity vts=cs*gambd1s/gamb1s / lambds**ds ! terminal velocity bx(i,j,2) = coe_l*vtr+(1.-coe_l)*vts ! TERMINAL VELOCITY bx(i,j,2) = bx(i,j,2) * densl*gc3 wbc(i,j,2) = wbc(i,j,2) - bx(i,j,2) end do end do do k=1,l do j=1,mp do i=1,np c qr(i,j,k)=qr(i,j,k)+.5*fqr(i,j,k)*dt qr(i,j,k)=amax1(0.,qr(i,j,k)+.5*fqr(i,j,k)*dt) end do end do end do call advec(qr,x0,y0,fqv,8,ifirst) c recover original b.c. do j=1,mp do i=1,np wbc(i,j,1) = wbc(i,j,1) + bx(i,j,1) wbc(i,j,2) = wbc(i,j,2) + bx(i,j,2) end do end do else STOP 'not ready' endif return end subroutine water_ice(th,qv,qc,qr,fth,fqv,fqc,fqr, * n1,m1,l1,tau,rx,ry,ith,iqw,rhl,thetme, * rfl,ss) include 'param.nml' include 'param.misc' include 'msg.inc' dimension th(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), . fth(1-ih:np+ih, 1-ih:mp+ih, l), . 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), . tau(l, 1-ih:np+ih, 1-ih:mp+ih) dimension rx(n1), ry(m1) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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,hlatv,hlats,hlatf common/rainc/ 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) dimension rhl(1-ih:np+ih, 1-ih:mp+ih, l), . thetme(1-ih:np+ih, 1-ih:mp+ih, l), . rfl(1-ih:np+ih, 1-ih:mp+ih, l), . ss(1-ih:np+ih, 1-ih:mp+ih, l) 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 real lambdr,lambds,massr,masss cc statement functions: 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 condensation/evaporation pi=3.14159 a=rg/rv c=hlatv/cp b=hlats/rv d=hlatv/rv e=-cp/rg do 10 k=1,l do 100 j=1,mp do 100 i=1,np coe_l=comb(tme(i,j,k),tdn,tup,0.,1.) ! liquid contribution rhl(i,j,k)=rho(i,j,k)*gi(i,j) thetme(i,j,k)=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme(i,j,k)**e tt=th(i,j,k)/thetme(i,j,k) 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(i,j,k)/th(i,j,k) cf1=cf1*cf1 cf1=c*cf1*pre/(pre-esw)*d delta=(qv(i,j,k)-qvs)/(1.+qvs*cf1) c---> ccc one Newton-Raphson iteration is next: thn=th(i,j,k)+c*thetme(i,j,k)*delta tt=thn/thetme(i,j,k) 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=thetme(i,j,k)/thn 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 c---> delta=amin1( qv(i,j,k), amax1(qv(i,j,k)-qc(i,j,k),delta) ) qv(i,j,k)=qv(i,j,k)-delta qc(i,j,k)=qc(i,j,k)-qv(i,j,k) th(i,j,k)=th(i,j,k)+c*thetme(i,j,k)*delta delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) fqv(i,j,k)=-delta*2.*dti fth(i,j,k)=-c*thetme(i,j,k)*fqv(i,j,k) fqc(i,j,k)=-fqv(i,j,k) 100 continue 10 continue compute gravity wave absorber (implicit) do 20 k=1,l do 20 j=1,mp do 20 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp relt=rx(ia)+ry(ja)-rx(ia)*ry(ja) tth=ith*tau(k,i,j)*(1.-relt)+relt tqv=iqw*tau(k,i,j)*(1.-relt)+relt th(i,j,k)=(th(i,j,k)+tth*the(i,j,k)*dt*.5)/(1.+.5*tth*dt) qv(i,j,k)=(qv(i,j,k)+tqv*qve(i,j,k)*dt*.5)/(1.+.5*tqv*dt) qc(i,j,k)=(qc(i,j,k)+ 0. )/(1.+.5*tqv*dt) fth(i,j,k)=fth(i,j,k)-tth*(th(i,j,k)-the(i,j,k)) fqv(i,j,k)=fqv(i,j,k)-tqv*(qv(i,j,k)-qve(i,j,k)) fqc(i,j,k)=fqc(i,j,k)-tqv*(qc(i,j,k)- 0. ) c fqc(i,j,k)=-fqv(i,j,k) 20 continue compute moist forces update do 30 k=1,l do 300 j=1,mp do 300 i=1,np tt=th(i,j,k)/thetme(i,j,k) pre=1.e5*thetme(i,j,k)**e coe_l=comb(tme(i,j,k),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) ssw=qv(i,j,k) / qvsw ! saturation ratio ssi=qv(i,j,k) / qvsi ! saturation ratio qpr=qr(i,j,k)*coe_l ! divide between rain and snow qps=qr(i,j,k)-qpr ! divide between rain and snow qcc=qc(i,j,k)*coe_l ! divide between ice and water qci=qc(i,j,k)-qcc ! divide between ice and water lambdr=(ar*anor*gamb1r/rhl(i,j,k)/(qpr+1.e-6))**(1./(1.+br)) ! lambda lambds=(as*anos*gamb1s/rhl(i,j,k)/(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=tt-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)*(qpr+1.e-7) / conr ! mass masss=rhl(i,j,k)*(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 c thfun=1.e-7/(2.2*tme(i,j,k)/esw+2.2e-2/tme(i,j,k)) ! thermodynamic fun. thfun=1.e-7/(2.2*tme(i,j,k)/esw+2.2e2/tme(i,j,k)) 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) dep_r=conr * g_dep_r * qpr / (qpr + 1.e-9) dep_s=cons * g_dep_s * qps / (qps + 1.e-9) ACC= acc_r + acc_s ! growth by accretion DEP= dep_r + dep_s ! growth by deposition dcol=2.*(AUT + ACC) dcol=amin1(dcol, 2.*dti*qc(i,j,k)+fqc(i,j,k)) devp=2.*DEP devp=amax1(devp, -2.*dti*qr(i,j,k)-dcol) cc fqr(i,j,k)=devp+dcol fqc(i,j,k)=fqc(i,j,k)-dcol fqv(i,j,k)=fqv(i,j,k)-devp fth(i,j,k)=fth(i,j,k)+c*devp*thetme(i,j,k) 300 continue 30 continue call update(qv, np,mp,l,np,mp) call update(qc, np,mp,l,np,mp) call update(th, np,mp,l,np,mp) call update(fqv,np,mp,l,np,mp) call update(fth,np,mp,l,np,mp) call update(fqc,np,mp,l,np,mp) call update(fqr,np,mp,l,np,mp) return end #endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (MOISTMOD == 2) subroutine water(th,qv,qc,qr,fth,fqv,fqc,fqr, * n1,m1,l1,tau,rx,ry,ith,iqw) include 'param.nml' include 'param.misc' include 'msg.inc' dimension th(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), . fth(1-ih:np+ih, 1-ih:mp+ih, l), . 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), . tau(l, 1-ih:np+ih, 1-ih:mp+ih) dimension rx(n1), ry(m1) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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 /forc4/ thobs(l),qvobs(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,hlatv,hlats,hlatf common/rain2/ iberry,dconc,ddisp,rac,qctr,an0,colef common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/water_table/ eswt,esit,deswt,desit dimension eswt(-1000:1000),esit(-1000:1) dimension deswt(-1000:1000),desit(-1000:1) common/blank/ rhl(1-ih:np+ih,1-ih:mp+ih,l), . thetme(1-ih:np+ih,1-ih:mp+ih,l), . src9(1-ih:np+ih,1-ih:mp+ih,l, 8) real lambda finter(ep,a1,a2)=ep*a2+(1.-ep)*a1 condensation/evaporation epsil=rg/rv beta=hlatv/cp expon=-cp/rg do 10 k=1,l do 100 j=1,mp do 100 i=1,np rhl(i,j,k)=rho(i,j,k)*gi(i,j) thetme(i,j,k)=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme(i,j,k)**expon ccc two Newton-Raphson iterations: delta=0. cc first: theta=th(i,j,k)+beta*thetme(i,j,k)*delta temp=theta/thetme(i,j,k) temp_l=amax1(174.,amin1(372.,temp)) at1=(temp_l-273.16)*10. it1=at1 it2=it1+sign(1.,at1-1.e-5) eps=abs(at1-float(it1)) ew=finter(eps,eswt(it1),eswt(it2)) dew=finter(eps,deswt(it1),deswt(it2)) qvs=epsil*ew/(pre-ew) fff=qv(i,j,k)-delta-qvs fffp=-1.-beta*dew*epsil*pre/(pre-ew)**2 delta=delta-fff/fffp cc second: theta=th(i,j,k)+beta*thetme(i,j,k)*delta temp=theta/thetme(i,j,k) temp_l=amax1(174.,amin1(372.,temp)) at1=(temp_l-273.16)*10. it1=at1 it2=it1+sign(1.,at1-1.e-5) eps=abs(at1-float(it1)) ew=finter(eps,eswt(it1),eswt(it2)) dew=finter(eps,deswt(it1),deswt(it2)) qvs=epsil*ew/(pre-ew) fff=qv(i,j,k)-delta-qvs fffp=-1.-beta*dew*epsil*pre/(pre-ew)**2 delta=delta-fff/fffp ccc end of iterations; if required, it can be repeated 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)+beta*thetme(i,j,k)*delta delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) fqv(i,j,k)=-delta*2.*dti fth(i,j,k)=-beta*thetme(i,j,k)*fqv(i,j,k) 100 continue 10 continue compute gravity wave absorber (implicit) do 20 k=1,l do 20 j=1,mp do 20 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp relt=rx(ia)+ry(ja)-rx(ia)*ry(ja) tth=ith*tau(k,i,j)*(1.-relt)+relt tqv=iqw*tau(k,i,j)*(1.-relt)+relt c th(i,j,k)=(th(i,j,k)+tth*the(i,j,k)*dt*.5)/(1.+.5*tth*dt) c qv(i,j,k)=(qv(i,j,k)+tqv*qve(i,j,k)*dt*.5)/(1.+.5*tqv*dt) c fth(i,j,k)=fth(i,j,k)-tth*(th(i,j,k)-the(i,j,k)) c fqv(i,j,k)=fqv(i,j,k)-tqv*(qv(i,j,k)-qve(i,j,k)) cc relax towards observed profiles: th(i,j,k)=(th(i,j,k)+tth*thobs(k)*dt*.5)/(1.+.5*tth*dt) qv(i,j,k)=(qv(i,j,k)+tqv*qvobs(k)*dt*.5)/(1.+.5*tqv*dt) qc(i,j,k)=(qc(i,j,k)+ 0. )/(1.+.5*tqv*dt) fth(i,j,k)=fth(i,j,k)-tth*(th(i,j,k)-thobs(k)) fqv(i,j,k)=fqv(i,j,k)-tqv*(qv(i,j,k)-qvobs(k)) fqc(i,j,k)=-fqv(i,j,k) 20 continue ccc remove trace of water variables: do k=1,l do j=1,mp do i=1,np qc(i,j,k)=cvmgm(0.,qc(i,j,k),qc(i,j,k)-1.e-9) qr(i,j,k)=cvmgm(0.,qr(i,j,k),qr(i,j,k)-1.e-10) enddo enddo enddo c compute moist forces update do 30 k=1,l do 30 j=1,mp do 30 i=1,np pre=1.e5*thetme(i,j,k)**expon temp=th(i,j,k)/thetme(i,j,k) temp_l=amax1(174.,amin1(372.,temp)) at1=(temp_l-273.16)*10. it1=at1 it2=it1+sign(1.,at1-1.e-5) eps=abs(at1-float(it1)) ew=finter(eps,eswt(it1),eswt(it2)) qvs=epsil*ew/(pre-ew) ss=amin1(qv(i,j,k)/qvs-1., 0.) cc lambda in MP raindrop distribution: lambda=(3.14e3*an0/rhl(i,j,k)/(1.e-9+qr(i,j,k)))**.25 cc cc ------> autoconversion: cc Kessler: rsrc1=rac*amax1(qc(i,j,k)-qctr, 0.) cc Berry: del2=1.e3*rhl(i,j,k)*qc(i,j,k) del1=1./rhl(i,j,k)*1.67e-5*del2*del2 / 1 (5. + .0366*dconc/(ddisp*(del2+1.E-6))) rsrc2=amin1(.3*qc(i,j,k)*dti,del1) cc rsrc=float(iberry)*rsrc2 + float(1-iberry)*rsrc1 cc ------> collection: coll=5.78e2*an0*colef*qc(i,j,k)/lambda**3.5 coll=cvmgm(0.,coll,qr(i,j,k)-1.e-9) cc ------> evaporation: rrad=.5/lambda conc=an0/lambda vterm=130.*sqrt(2.*rrad) reynlds=vterm*2.*rrad/2.e-5 vent=amax1(1.,.71+.275*sqrt(reynlds)) bottom=2.2*tme(i,j,k)/ew + 2.2e2/tme(i,j,k) revp=1.26e-6/rhl(i,j,k)*conc*rrad*vent*ss/bottom cc dcol=2.*(coll+rsrc) dcol=amin1(dcol, 2.*dti*qc(i,j,k)+fqc(i,j,k)) devp=2.*revp devp=amax1(devp, -2.*dti*qr(i,j,k)-dcol) cc fqr(i,j,k)=devp+dcol fqc(i,j,k)=fqc(i,j,k)-dcol fqv(i,j,k)=fqv(i,j,k)-devp fth(i,j,k)=fth(i,j,k)+beta*devp*thetme(i,j,k) cc cc final adjustements: fqv(i,j,k)= amax1(fqv(i,j,k), -2.*qv(i,j,k)/dt ) fqc(i,j,k)= amax1(fqc(i,j,k), -2.*qc(i,j,k)/dt ) fqr(i,j,k)= amax1(fqr(i,j,k), -2.*qr(i,j,k)/dt ) 30 continue call update(qv, np,mp,l,np,mp) call update(qc, np,mp,l,np,mp) call update(th, np,mp,l,np,mp) call update(fqv,np,mp,l,np,mp) call update(fth,np,mp,l,np,mp) call update(fqc,np,mp,l,np,mp) call update(fqr,np,mp,l,np,mp) return end subroutine water_ice(th,qv,qc,qr,qia,qib,fth,fqv,fqc,fqr, * n1,m1,l1,fqia,fqib,tau,rx,ry,ith,iqw) include 'param.nml' include 'param.misc' include 'msg.inc' dimension th(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), . fth(1-ih:np+ih, 1-ih:mp+ih, l), . 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), . tau(l, 1-ih:np+ih, 1-ih:mp+ih) dimension rx(n1), ry(m1) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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 /forc4/ thobs(l),qvobs(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,hlatv,hlats,hlatf common/rain2/ iberry,dconc,ddisp,rac,qctr,an0,colef common/graupel/ an0g,gden common/mcfarq/ rho_ia,asma,bsma,cal1,cal2, * ami1,ami2,bmi1,bmi2,asi1,asi2,bsi1,bsi2 common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) real inia,inib1,inib2,melia,melib,lambdar,lambdag real iwc,iwc0,iwcl,iwcs,miu,mass_la,mass_sm cc common/water_table/ eswt,esit,deswt,desit dimension eswt(-1000:1000),esit(-1000:1) dimension deswt(-1000:1000),desit(-1000:1) common/koenig/ coef1(32),coef2(32) cc common/blank/ rhl(1-ih:np+ih,1-ih:mp+ih,l), . src9(1-ih:np+ih,1-ih:mp+ih,l, 9) cc cc rain fall formula: vtrmv(qq,rro)=sqrt(rh00/rro)*251.*(qq)**(-.5) cc cc linear interpolation: finter(ep,a1,a2)=ep*a2+(1.-ep)*a1 cc cc heterogeneous nucleation function (Fletcher-type), number/m**3: cc original Fletcher coef is 1.e-5 per liter or 1.e-2 per m**3 anucl(tempk)=cvmgm( 0., 1 amin1(1.e5,1.e-2*exp(.6*amax1(0.,273.16-tempk))),273.16-tempk) cc cc air viscosity visc=2.e-5 cc time scale for nucleation (both homo and hetero) is for numerical cc reasons: taunuc=10. condensation/evaporation epsil=rg/rv betav=hlatv/cp betas=hlats/cp betaf=hlatf/cp expon=-cp/rg do 10 k=1,l do 100 j=1,mp do 100 i=1,np rhl(i,j,k)=rho(i,j,k)*gi(i,j) thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**expon ccc two Newton-Raphson iterations: delta=0. cc first: theta=th(i,j,k)+betav*thetme*delta temp=theta/thetme temp_l=amax1(174.,amin1(372.,temp)) at1=(temp_l-273.16)*10. it1=at1 it2=it1+sign(1.,at1-1.e-5) eps=abs(at1-float(it1)) ew=finter(eps,eswt(it1),eswt(it2)) dew=finter(eps,deswt(it1),deswt(it2)) qvs=epsil*ew/(pre-ew) fff=qv(i,j,k)-delta-qvs fffp=-1.-betav*dew*epsil*pre/(pre-ew)**2 delta=delta-fff/fffp cc second: theta=th(i,j,k)+betav*thetme*delta temp=theta/thetme temp_l=amax1(174.,amin1(372.,temp)) at1=(temp_l-273.16)*10. it1=at1 it2=it1+sign(1.,at1-1.e-5) eps=abs(at1-float(it1)) ew=finter(eps,eswt(it1),eswt(it2)) dew=finter(eps,deswt(it1),deswt(it2)) qvs=epsil*ew/(pre-ew) fff=qv(i,j,k)-delta-qvs fffp=-1.-betav*dew*epsil*pre/(pre-ew)**2 delta=delta-fff/fffp ccc end of iterations; if required, it can be repeated 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)+betav*thetme*delta delta=amin1( qv(i,j,k), amax1(-qc(i,j,k),delta) ) fqv(i,j,k)=-delta*2.*dti fth(i,j,k)=-betav*thetme*fqv(i,j,k) fqc(i,j,k)=-fqv(i,j,k) 100 continue 10 continue c compute gravity wave absorber (implicit) do 20 k=1,l do 20 j=1,mp do 20 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp relt=rx(ia)+ry(ja)-rx(ia)*ry(ja) tth=ith*tau(k,i,j)*(1.-relt)+relt tqv=iqw*tau(k,i,j)*(1.-relt)+relt c th(i,j,k)=(th(i,j,k)+tth*the(i,j,k)*dt*.5)/(1.+.5*tth*dt) c qv(i,j,k)=(qv(i,j,k)+tqv*qve(i,j,k)*dt*.5)/(1.+.5*tqv*dt) c fth(i,j,k)=fth(i,j,k)-tth*(th(i,j,k)-the(i,j,k)) c fqv(i,j,k)=fqv(i,j,k)-tqv*(qv(i,j,k)-qve(i,j,k)) cc relax towards observed profiles: th(i,j,k)=(th(i,j,k)+tth*thobs(k)*dt*.5)/(1.+.5*tth*dt) qv(i,j,k)=(qv(i,j,k)+tqv*qvobs(k)*dt*.5)/(1.+.5*tqv*dt) qc(i,j,k)=(qc(i,j,k)+ 0. )/(1.+.5*tqv*dt) qr(i,j,k)=(qr(i,j,k)+ 0. )/(1.+.5*tqv*dt) qia(i,j,k)=(qia(i,j,k)+ 0. )/(1.+.5*tqv*dt) qib(i,j,k)=(qib(i,j,k)+ 0. )/(1.+.5*tqv*dt) c fth(i,j,k)=fth(i,j,k)-tth*(th(i,j,k)-thobs(k)) fqv(i,j,k)=fqv(i,j,k)-tqv*(qv(i,j,k)-qvobs(k)) fqc(i,j,k)=fqc(i,j,k)-tqv*(qc(i,j,k)-0.) fqr(i,j,k)=-tqv*(qr(i,j,k)-0.) fqia(i,j,k)=-tqv*(qia(i,j,k)-0.) fqib(i,j,k)=-tqv*(qib(i,j,k)-0.) 20 continue cc ccc remove trace of water variables: do k=1,l do j=1,mp do i=1,np qc(i,j,k)=cvmgm(0.,qc(i,j,k),qc(i,j,k)-1.e-9) qr(i,j,k)=cvmgm(0.,qr(i,j,k),qr(i,j,k)-1.e-10) qia(i,j,k)=cvmgm(0.,qia(i,j,k),qia(i,j,k)-1.e-9) qib(i,j,k)=cvmgm(0.,qib(i,j,k),qib(i,j,k)-1.e-10) enddo enddo enddo c compute moist forces update (rain + ice): iwc0=1.e-3 do k=1,l do j=1,mp do i=1,np cc setup temp, pre, qvs etc: thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**expon temp=th(i,j,k)/thetme presmb=pre/100. tempc=temp-273.16 CC RAIN PARAMETERS: cc lambda in MP raindrop distribution: lambdar=(3.14e3*an0/rhl(i,j,k)/(1.e-9+qr(i,j,k)))**.25 cc cc ICE A PARAMETERS (McFarquhar and Heymsfield parameterization): iwc=amax1(1.e-9,rhl(i,j,k)*qia(i,j,k)) cc small ice iwc cannot exceed iwc, always smaller than 1 g/m3 iwcs=amin1(1.e-3,iwc,asma*(iwc/iwc0)**bsma) iwcl=amax1(1.e-9,iwc-iwcs) cc mass of small ice A: alpha=amax1(1.e3,cal1-cal2*alog10(iwcs/iwc0)) mass_sm=6.28*rho_ia/alpha**3 cc below my simple formulas are used: diam_sm=sqrt(mass_sm/2.5e-2) vt_sm=4.* diam_sm**.25 cc mass of large ice A: ami=ami1+ami2*tempc bmi=bmi1+bmi2*tempc asi=asi1+asi2*tempc bsi=bsi1+bsi2*tempc alorat=alog10(iwcl/iwc0) miu=amax1(4.6,amin1(5.4,ami+bmi*alorat)) sig=amax1(0.,amin1(.5,asi+bsi*alorat)) exp_mas=3.*miu+4.5*sig**2 mass_la=5.24e-19*rho_ia*exp(exp_mas) cc below my simple formulas are used: diam_la=sqrt(mass_la/2.5e-2) vt_la=4.* diam_la**.25 cc mass weight mass, size and terminal velocity: coe5=iwcs/(iwcs+iwcl) arad =.5*finter(coe5,diam_la,diam_sm) amass= finter(coe5,mass_la,mass_sm) avel = finter(coe5, vt_la, vt_sm) * sqrt(rh00/rhl(i,j,k)) cc ICE B PARAMETERS (graupel, as in Rutledge and Hobbs): cc lambda in MP graupel distribution: lambdag=(3.14*gden*an0g/rhl(i,j,k)/(1.e-9+qib(i,j,k)))**.25 cc ice B particle size, mass, terminal velocity brad=.5/lambdag d3=6./lambdag**3 bmass=amax1(1.e-12,amin1(1.e-3,.52*gden*d3)) bvel=31.2/lambdag**.37 * sqrt(rh00/rhl(i,j,k)) cc saturated qv wrt water temp_l=amax1(174.,amin1(372.,temp)) at1=(temp_l-273.16)*10. it1=at1 it2=it1+sign(1.,at1-1.e-5) eps=abs(at1-float(it1)) ew=finter(eps,eswt(it1),eswt(it2)) qvsw=epsil*ew/(pre-ew) ss=amin1(qv(i,j,k)/qvsw-1., 0.) cc saturated qv wrt ice: temp_l=amax1(174.,temp) at1=amin1(0.,(temp_l-273.16)*10.) it1=at1 it2=it1+sign(1.,at1-1.e-5) eps=abs(at1-float(it1)) ei=finter(eps,esit(it1),esit(it2)) c dei=finter(eps,desit(it1),desit(it2)) qvsi=epsil*ei/(pre-ei) cc cc ------> rain autoconversion: cc Kessler: rsrc1=rac*amax1(qc(i,j,k)-qctr, 0.) cc Berry: del2=1.e3*rhl(i,j,k)*qc(i,j,k) del1=1./rhl(i,j,k)*1.67e-5*del2*del2 / 1 (5. + .0366*dconc/(ddisp*(del2+1.E-6))) rsrc2=amin1(.3*qc(i,j,k)*dti,del1) !<--- limiting the rate cc rsrc=float(iberry)*rsrc2 + float(1-iberry)*rsrc1 cc cc ------> rain collection: coll=5.78e2*an0*colef*qc(i,j,k)/lambdar**3.5 coll=cvmgm(0.,coll,qr(i,j,k)-1.e-9) cc cc add rain sources: rcol=coll+rsrc rcol=amin1(rcol, .3*dti*qc(i,j,k)) cc cc ------> rain evaporation: rrad=.5/lambdar conc=an0/lambdar vterm=130.*sqrt(2.*rrad) reynlds=vterm*2.*rrad/visc vent=amax1(1.,.71+.275*sqrt(reynlds)) bottom=2.2*tme(i,j,k)/ew + 2.2e2/tme(i,j,k) revp=1.26e-6/rhl(i,j,k)*conc*rrad*vent*ss/bottom revp=amax1(revp, -dti*qr(i,j,k)) cc cc ----> ice A nucleation: eterm=1.-exp(-dt/taunuc) ccc heterogeneous part: amas_n=amax1(1.e-12,amass) heter=amax1(0.,anucl(temp)*amas_n/rhl(i,j,k)-qia(i,j,k)) heter=amin1(qc(i,j,k),heter)*eterm ccc homogeneous part: temh=amax1(-60.,amin1(-40.,tempc)) coe3=1.+.9*(40.+temh)/20. ! 1 for -40, .1 for -60 qvh=coe3*qvsw + (1.-coe3)*qvsi homo1=amax1(0.,qv(i,j,k)-qvh) homo1=cvmgm(0.,homo1*eterm,-40.-tempc) homo2=cvmgm(0.,(qc(i,j,k)-heter)*eterm,-40.-tempc) heter=heter/dt homo1=homo1/dt homo2=homo2/dt inia=heter+homo1+homo2 cc cc ----> ice B nucleation (interaction of rain and ice A): vtr=vtrmv(lambdar,rhl(i,j,k)) rnum=cvmgm(0.,an0/lambdar,qr(i,j,k)-1.e-9) d2=2./lambdar**2 d3=6./lambdar**3 rmass=cvmgm(0.,.524e3*d3,qr(i,j,k)-1.e-9) inib2=0.785*rnum*d2*vtr*qia(i,j,k) inib1=inib2*rmass/amass inib2=cvmgm(amin1(inib2,qia(i,j,k)/dt),0.,tempc) inib1=cvmgm(amin1(inib1, qr(i,j,k)/dt),0.,tempc) cc cc ----> growth of ice A and B (notation as in Koenig MWR 1972): cc note that riming is taken as a difference between cc total growth and deposition growth c --> coeficients for deposition growth: ttcoe=amin1(-0.01,amax1(-30.99,tempc)) index1=ifix(-ttcoe)+1 index2=index1+1 del=-ttcoe-float(index1-1) coef22=(1.-del)*coef2(index1)+del*coef2(index2) coef11=(1.-del)*coef1(index1)+del*coef1(index2) exten=242.16/temp * (ew-ei)/(46.50-34.29) ! extension for -31C coef11=cvmgm(coef11,coef11*exten,-31.-tempc) c growth calculations; 1.e-3 comes from conversion g/sec into kg/sec rateb=coef11*(5.e-8)**coef22 c --------> ice A c --> coeficients for growth with riming (only qc considered for A): tang=1.+.1*alog(1.e3*rhl(i,j,k)*(qc(i,j,k)+1.e-10)) ! (3) ratec=rateb * (2.e3)**tang ! (6) rated=rhl(i,j,k)*(qc(i,j,k)+1.e-10) b2=alog(rated/ratec) / 9.2103 ! (7) c flag for growth by riming: rimfl=cvmgm(-1.,1.,rhl(i,j,k)*qc(i,j,k)-5.e-5) dmadt_ae=1.e-3*(qv(i,j,k)-qvsi)/(qvsw-qvsi) * * coef11*(1.e3*amass)**coef22 ! (1) dmadt_ae=cvmgm(dmadt_ae,0.,tempc) dmadt_bc=1.e-3 * rateb * (amass/5.e-11)**tang ! (4) dmadt_bc=cvmgm(dmadt_bc,0.,tempc) dmadt_bc=cvmgm(dmadt_ae,dmadt_bc,rimfl) dmadt_cd=1.e-3 * ratec * (amass*1.e7)**b2 ! (5) dmadt_cd=cvmgm(dmadt_cd,0.,tempc) dmadt_cd=cvmgm(dmadt_ae,dmadt_cd,rimfl) conca=qia(i,j,k)/amass depia=dmadt_ae*conca rimia= . cvmgm( 0.,conca*amax1(0.,dmadt_bc-dmadt_ae),amass-5.e-11) rimia= . cvmgm(rimia,conca*amax1(0.,dmadt_cd-dmadt_ae),amass-1.e-07) cc c --------> ice B c --> coeficients for growth with riming (qc and qr considered): tang=1.+.1*alog(1.e3*rhl(i,j,k)*(qc(i,j,k)+qr(i,j,k)+1.e-10)) ! (3) ratec=rateb * (2.e3)**tang ! (6) rated=rhl(i,j,k)*(qc(i,j,k)+qr(i,j,k)+1.e-10) b2=alog(rated/ratec) / 9.2103 ! (7) c flag for growth by riming: rimfl=cvmgm(-1.,1.,rhl(i,j,k)*(qc(i,j,k)+qr(i,j,k))-5.e-5) dmbdt_ae=1.e-3*(qv(i,j,k)-qvsi)/(qvsw-qvsi) * * coef11*(1.e3*bmass)**coef22 ! (1) dmbdt_ae=cvmgm(dmbdt_ae,0.,tempc) dmbdt_bc=1.e-3 * rateb * (bmass/5.e-11)**tang ! (4) dmbdt_bc=cvmgm(dmbdt_bc,0.,tempc) dmbdt_bc=cvmgm(dmbdt_ae,dmbdt_bc,rimfl) dmbdt_cd=1.e-3 * ratec * (bmass*1.e7)**b2 ! (5) dmbdt_cd=cvmgm(dmbdt_cd,0.,tempc) dmbdt_cd=cvmgm(dmbdt_ae,dmbdt_cd,rimfl) concb=qib(i,j,k)/bmass depib=dmbdt_ae*concb rimib= . cvmgm( 0.,concb*amax1(0.,dmbdt_bc-dmbdt_ae),bmass-5.e-11) rimib= . cvmgm(rimib,concb*amax1(0.,dmbdt_cd-dmbdt_ae),bmass-1.e-07) cc divide rimib between qc and qr sinks: coeqc=qc(i,j,k)/(qc(i,j,k)+qr(i,j,k)+1.e-10) rimibqc=coeqc*rimib rimibqr=(1.-coeqc)*rimib cc cc ----> melting of ice A and B: reyna=2.*avel*arad/visc reynb=2.*bvel*brad/visc venta=amax1(1.,.78+.275*sqrt(reyna)) ventb=amax1(1.,.78+.275*sqrt(reynb)) dmadt=9.e-7*arad*venta*amax1(0.,tempc) dmbdt=9.e-7*brad*ventb*amax1(0.,tempc) melia=amin1(qia(i,j,k)/dt,dmadt*qia(i,j,k)/amass) melib=amin1(qib(i,j,k)/dt,dmbdt*qib(i,j,k)/bmass) cc-----> cc ----> add all sources: cc ----> factor 2 compensates 0.5 when forces are applied fqv(i,j,k) = fqv(i,j,k)+2.*(-revp-depia-depib-homo1) fqc(i,j,k) = fqc(i,j,k)+2.*(-rcol-rimia-rimibqc-homo2-heter) fqr(i,j,k) = fqr(i,j,k)+2.*(revp+rcol+melia+melib-inib1-rimibqr) fqia(i,j,k)=fqia(i,j,k)+2.*(inia+depia+rimia-melia-inib2) fqib(i,j,k)=fqib(i,j,k)+2.*(inib1+inib2+depib+rimib-melib) fth(i,j,k) = fth(i,j,k)+2.*thetme* ( betav*revp + . betas*(depia+depib+homo1) + . betaf*(rimia+rimib+homo2+heter+inib1-melia-melib) ) cc fqv(i,j,k)= amax1(fqv(i,j,k), -2.*qv(i,j,k)/dt ) fqc(i,j,k)= amax1(fqc(i,j,k), -2.*qc(i,j,k)/dt ) fqr(i,j,k)= amax1(fqr(i,j,k), -2.*qr(i,j,k)/dt ) fqia(i,j,k)=amax1(fqia(i,j,k),-2.*qia(i,j,k)/dt) fqib(i,j,k)=amax1(fqib(i,j,k),-2.*qib(i,j,k)/dt) cc enddo enddo enddo call update(qv , np,mp,l,np,mp) call update(qc , np,mp,l,np,mp) call update(qr , np,mp,l,np,mp) call update(qia, np,mp,l,np,mp) call update(qib, np,mp,l,np,mp) call update(th , np,mp,l,np,mp) call update(fqv, np,mp,l,np,mp) call update(fth, np,mp,l,np,mp) call update(fqc, np,mp,l,np,mp) call update(fqr, np,mp,l,np,mp) call update(fqia,np,mp,l,np,mp) call update(fqib,np,mp,l,np,mp) return end subroutine prec_rain( qr,ft,fqv,fqc,fqr,x0,y0,z0, . u,v,w,bx,by,bz,xr,yr,zr) include 'param.nml' include 'param.misc' include 'msg.inc' dimension ft(1-ih:np+ih, 1-ih:mp+ih, l), . 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), . 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), . 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), . 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), . xr(1-ih:np+ih, 1-ih:mp+ih, l), . yr(1-ih:np+ih, 1-ih:mp+ih, l), . zr(1-ih:np+ih, 1-ih:mp+ih, l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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/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/rain2/ iberry,dconc,ddisp,rac,qctr,an0,colef real kappa,lambda vtrmv(qq,rro)=sqrt(rh00/rro)*251.*(qq)**(-.5) ifirst=1 gc1=dt*dxi gc2=dt*dyi gc3=dt*dzi cc below is for the old terminal velocity c gamma=-.3654 c kappa= .1346 gamma=-.375 kappa= .125 if(lagr.eq.0) then cc --------> treatment of rain in eulerian model: do k=2,l do j=1,mp do i=1,np dens= 0.5*(rho(i,j,k)+rho(i,j,k-1))*gi(i,j) qrv = 0.5*( qr(i,j,k)+ qr(i,j,k-1)) cc lambda in MP raindrop distribution: lambda=(3.14e3*an0/dens/(1.e-9+qrv))**.25 vtr=vtrmv(lambda,dens) fqv(i,j,k)=z0(i,j,k)-vtr*dens*gc3 end do end do end do compute boundary velocities for rain do i=1,np do j=1,mp dens1= 0.5*(rho(i,j,2)+rho(i,j,1))*gi(i,j) qrv1 = 0.5*( qr(i,j,2)+ qr(i,j,1)) lambda=(3.14e3*an0/dens1/(1.e-9+qrv1))**.25 vtr=vtrmv(lambda,dens1) bx(i,j,1) = vtr*dens1*gc3 wbc(i,j,1) = wbc(i,j,1) - bx(i,j,1) densl= 0.5*(rho(i,j,l-1)+rho(i,j,l))*gi(i,j) qrvl = 0.5*( qr(i,j,l-1)+ qr(i,j,l)) lambda=(3.14e3*an0/densl/(1.e-9+qrvl))**.25 vtr=vtrmv(lambda,densl) bx(i,j,2) = vtr*densl*gc3 wbc(i,j,2) = wbc(i,j,2) - bx(i,j,2) end do end do do k=1,l do j=1,mp do i=1,np qr(i,j,k)=amax1(0.,qr(i,j,k)+.5*fqr(i,j,k)*dt) end do end do end do call advec(qr,x0,y0,fqv,8,ifirst) c recover original b.c. do i=1,np do j=1,mp wbc(i,j,1) = wbc(i,j,1) + bx(i,j,1) wbc(i,j,2) = wbc(i,j,2) + bx(i,j,2) end do end do else cc --------> treatment of rain in lagrangian model: do k=1,l do j=1,mp do i=1,np dens=rho(i,j,k)*gi(i,j) lambda=(3.14e3*an0/dens/(1.e-9+qr(i,j,k)))**.25 fqv(i,j,k)=vtrmv(lambda,dens) enddo enddo enddo cc calculate betas: do k=1,l kp=min0(l,k+1) do i=1,np do j=1,mp bx(i,j,k)= -.5*gc3*(u(i,j,kp)-u(i,j,k)) by(i,j,k)= -.5*gc3*(v(i,j,kp)-v(i,j,k)) bz(i,j,k)=1.-.5*gc3*(w(i,j,kp)-w(i,j,k)) enddo enddo enddo cc compute rainfall rate source term (qr*vt)/rho * d/dz[rho/G]+Fs do k=2,l-1 do j=1,mp do i=1,np ft(i,j,k)=(1.+gamma)*dzi*fqv(i,j,k)*qr(i,j,k) . *gi(i,j)*( rho(i,j,k+1)-rho(i,j,k-1) ) . /( rho(i,j,k+1)+rho(i,j,k-1) ) . +0.5*fqr(i,j,k) enddo enddo enddo do i=1,np do j=1,mp ft(i,j,1)=(1.+gamma)*dzi*fqv(i,j,1)*qr(i,j,1) . *gi(i,j)*( rho(i,j,2)-rho(i,j,1) ) . /( rho(i,j,2)+rho(i,j,1) )*2. . +0.5*fqr(i,j,1) ft(i,j,l)=(1.+gamma)*dzi*fqv(i,j,l)*qr(i,j,l) . *gi(i,j)*( rho(i,j,l)-rho(i,j,l-1) ) . /( rho(i,j,l)+rho(i,j,l-1) ) . +0.5*fqr(i,j,l) enddo enddo do k=1,l do j=1,mp do i=1,np qr(i,j,k)=amax1(0., qr(i,j,k)+dt*ft(i,j,k)) fqv(i,j,k)=(1.+kappa)*fqv(i,j,k) enddo enddo enddo calculate departure point for rain; use ft, fqv, fqc and fqr as scratches compute first guess c ifgues=1 - simple approach; DEFAULT OPTION c ifgues=2 - full approach coded in 2D only ifgues=1 if(ifgues.eq.1) then CC SIMPLE APPROACH: do k=1,l kp=min0(l,k+1) do i=1,np do j=1,mp fqc(i,j,k)=( fqv(i,j,kp)-fqv(i,j,k ) )*dzi enddo enddo enddo do 392 k=1,l do 392 j=1,mp do 392 i=1,np xr(i,j,k)=x0(i,j,k)+gc1*gi(i,j)*bx(i,j,k)*fqv(i,j,k) yr(i,j,k)=y0(i,j,k)+gc2*gi(i,j)*by(i,j,k)*fqv(i,j,k) zr(i,j,k)=( z0(i,j,k)+gc3*gi(i,j)*bz(i,j,k)*( . fqv(i,j,k)-fqc(i,j,k)*(k-1)*dz) ) . /( 1.-dt*bz(i,j,k)*fqc(i,j,k) ) xr(i,j,k)=amax1(1.,amin1(float(n),xr(i,j,k))) yr(i,j,k)=amax1(1.,amin1(float(m),yr(i,j,k))) zr(i,j,k)=amax1(1.,amin1(float(l),zr(i,j,k))) 392 continue endif if(ifgues.eq.2) then CC FULL APPROACH: if(j3.eq.1) stop 'not ready' do k=1,l kp=min0(l,k+1) do i=1,np ip=min0(n,i+1) fqc(i,1,k)=( fqv(i,1,kp)-fqv(i,1,k ) )*dzi fqr(i,1,k)=( fqv(ip,1,k)-fqv(i,1,k ) )*dxi enddo enddo do 792 k=1,l do 792 i=1,np xx=x0(i,1,k)-float(i-1) zz=z0(i,1,k)-float(k-1) bottom=1.-dt*(bz(i,1,k)*fqc(i,1,k)-bx(i,1,k)*fqr(i,1,k)) xst=(xx*(1.-dt*bz(i,1,k)*fqc(i,1,k)) + 1 gc1*bx(i,1,k)*(fqv(i,1,k)+fqc(i,1,k)*zz))/bottom zst=(zz*(1.-dt*bx(i,1,k)*fqr(i,1,k)) + 1 gc3*bz(i,1,k)*(fqv(i,1,k)+fqr(i,1,k)*xx))/bottom xr(i,1,k)=xst+float(i-1) zr(i,1,k)=zst+float(k-1) xr(i,1,k)=amax1(1.,amin1(float(n),xr(i,1,k))) yr(i,1,k)=amax1(1.,amin1(float(m),yr(i,1,k))) zr(i,1,k)=amax1(1.,amin1(float(l),zr(i,1,k))) 792 continue endif cc corrector for rain departure point cc number of iteration (1 SHOULD BE DEFAULT) itera=1 if(itera.gt.1) then do k=1,l do j=1,mp do i=1,np ft(i,j,k)=fqv(i,j,k) enddo enddo enddo endif do itr=1,itera call advec(fqv,xr,yr,zr,8,ifirst) do 394 k=1,l do 394 j=1,mp do 394 i=1,np xr(i,j,k)=x0(i,j,k)+gc1*gi(i,j)*bx(i,j,k)*fqv(i,j,k) yr(i,j,k)=y0(i,j,k)+gc2*gi(i,j)*by(i,j,k)*fqv(i,j,k) zr(i,j,k)=z0(i,j,k)+gc3*gi(i,j)*bz(i,j,k)*fqv(i,j,k) xr(i,j,k)=amax1(1.,amin1(float(n),xr(i,j,k))) yr(i,j,k)=amax1(1.,amin1(float(m),yr(i,j,k))) zr(i,j,k)=amax1(1.,amin1(float(l),zr(i,j,k))) 394 continue if(itr.lt.itera) then do k=1,l do j=1,mp do i=1,np fqv(i,j,k)=ft(i,j,k) enddo enddo enddo endif enddo cc call advec(qr,xr,yr,zr,8,ifirst) cc --------> end of treatment of rain in lagrangian model endif return end subroutine prec_ice(qia,qib,ft,fqv,fqc,fqia,fqib,x0,y0,z0, . u,v,w,bx,by,bz,xr,yr,zr) include 'param.nml' include 'param.misc' include 'msg.inc' 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), . fqc(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . ft(1-ih:np+ih, 1-ih:mp+ih, l), . 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), . 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), . 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), . xr(1-ih:np+ih, 1-ih:mp+ih, l), . yr(1-ih:np+ih, 1-ih:mp+ih, l), . zr(1-ih:np+ih, 1-ih:mp+ih, l) parameter (nml=n*m*l,nm=n*m,ml=m*l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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/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/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z 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/mcfarq/ rho_ia,asma,bsma,cal1,cal2, * ami1,ami2,bmi1,bmi2,asi1,asi2,bsi1,bsi2 common/graupel/ an0g,gden real kappa,iwc,iwc0,iwcl,iwcs,miu,mass_la,mass_sm,lambda cc linear interpolation: finter(ep,a1,a2)=ep*a2+(1.-ep)*a1 cc ice A terminal velocity formula: vtamv(vel,rro)=vel*sqrt(0.3/rro) cc ice B (graupel) terminal velocity vtbmv(qq,rro)=sqrt(rh00/rro)*31.2*(qq)**(-.37) ifirst=1 gc1=dt*dxi gc2=dt*dyi gc3=dt*dzi gamma=-.5 kappa= 0. cc reference ice water content iwc0=1.e-3 if(lagr.eq.0) then cc --------> TREATMENT OF ICE IN EULERIAN MODEL: cc ice B (graupel): do k=2,l do j=1,mp do i=1,np dens= 0.5*(rho(i,j,k)+rho(i,j,k-1))*gi(i,j) qri = 0.5*( qib(i,j,k)+ qib(i,j,k-1)) lambda=(3.14*gden*an0g/dens/(1.e-9+qri))**.25 vtr=vtbmv(lambda,dens) fqv(i,j,k)=z0(i,j,k)-vtr*dens*gc3 end do end do end do compute boundary velocities for ice B do j=1,mp do i=1,np dens1= 0.5*(rho(i,j,2)+rho(i,j,1))*gi(i,j) qri1 = 0.5*(qib(i,j,2)+qib(i,j,1)) lambda=(3.14*gden*an0g/dens1/(1.e-9+qri1))**.25 bx(i,j,1) = vtbmv(lambda,dens1)*dens1*gc3 wbc(i,j,1) = wbc(i,j,1) - bx(i,j,1) densl= 0.5*(rho(i,j,l-1)+rho(i,j,l))*gi(i,j) qril = 0.5*(qib(i,j,l-1)+qib(i,j,l)) lambda=(3.14*gden*an0g/densl/(1.e-9+qril))**.25 bx(i,j,2) = vtbmv(lambda,densl)*densl*gc3 wbc(i,j,2) = wbc(i,j,2) - bx(i,j,2) end do end do do k=1,l do j=1,mp do i=1,np qib(i,j,k)=amax1(0.,qib(i,j,k)+.5*fqib(i,j,k)*dt) end do end do end do call advec(qib,x0,y0,fqv,11,ifirst) c recover original b.c. do j=1,mp do i=1,np wbc(i,j,1) = wbc(i,j,1) + bx(i,j,1) wbc(i,j,2) = wbc(i,j,2) + bx(i,j,2) end do end do cc ice A (small crystals, snow): do k=2,l do j=1,mp do i=1,np dens= 0.5*(rho(i,j,k)+rho(i,j,k-1))*gi(i,j) qi = 0.5*(qia(i,j,k)+qia(i,j,k-1)) iwc=amax1(1.e-9,dens*qi) iwcs=amin1(1.e-3,iwc,asma*(iwc/iwc0)**bsma) iwcl=amax1(1.e-9,iwc-iwcs) vt_sm=0.1 ! from Greg vt_la=amax1(0.4,0.9+0.1*alog10(1.e3*iwcl)) ! from Greg coe5=iwcs/(iwcs+iwcl) avel = finter(coe5, vt_la, vt_sm) vtr=vtamv(avel,dens) fqv(i,j,k)=z0(i,j,k)-vtr*dens*gc3 end do end do end do compute boundary velocities for ice A do j=1,mp do i=1,np dens = 0.5*(rho(i,j,2)+rho(i,j,1))*gi(i,j) qi = 0.5*(qia(i,j,2)+qia(i,j,1)) iwc=amax1(1.e-9,dens*qi) iwcs=amin1(1.e-3,iwc,asma*(iwc/iwc0)**bsma) iwcl=amax1(1.e-9,iwc-iwcs) vt_sm=0.1 ! from Greg vt_la=amax1(0.4,0.9+0.1*alog10(1.e3*iwcl)) ! from Greg coe5=iwcs/(iwcs+iwcl) avel = finter(coe5, vt_la, vt_sm) bx(i,j,1) = vtamv(avel,dens)*dens*gc3 wbc(i,j,1) = wbc(i,j,1) - bx(i,j,1) cc dens = 0.5*(rho(i,j,l-1)+rho(i,j,l))*gi(i,j) qi = 0.5*(qia(i,j,l-1)+qia(i,j,l)) iwc=amax1(1.e-9,dens*qi) iwcs=amin1(1.e-3,iwc,asma*(iwc/iwc0)**bsma) iwcl=amax1(1.e-9,iwc-iwcs) vt_sm=0.1 ! from Greg vt_la=amax1(0.4,0.9+0.1*alog10(1.e3*iwcl)) ! from Greg coe5=iwcs/(iwcs+iwcl) avel = finter(coe5, vt_la, vt_sm) bx(i,j,2) = vtamv(avel,densl)*densl*gc3 wbc(i,j,2) = wbc(i,j,2) - bx(i,j,2) end do end do do k=1,l do j=1,mp do i=1,np qia(i,j,k)=amax1(0.,qia(i,j,k)+.5*fqia(i,j,k)*dt) end do end do end do call advec(qia,x0,y0,fqv,10,ifirst) c recover original b.c. do j=1,mp do i=1,np wbc(i,j,1) = wbc(i,j,1) + bx(i,j,1) wbc(i,j,2) = wbc(i,j,2) + bx(i,j,2) end do end do else cc --------> TREATMENT OF ICE IN LAGRANGIAN MODEL: STOP 'PREC NOT READY' cc NOTE: simplfied rain logic, no otions for ice trajectory cc calculate betas: do k=1,l kp=min0(l,k+1) do j=1,mp do i=1,np bx(i,j,k)= -.5*gc3*(u(i,j,kp)-u(i,j,k)) by(i,j,k)= -.5*gc3*(v(i,j,kp)-v(i,j,k)) bz(i,j,k)=1.-.5*gc3*(w(i,j,kp)-w(i,j,k)) enddo enddo enddo cc ------------> ice A do k=1,l do j=1,mp do i=1,np dens=rho(i,j,k)*gi(i,j) fqv(i,j,k)=vtamv(avel,dens) enddo enddo enddo cc compute precip rate source term (qi*vt)/rho * d/dz[rho/G]+Fs do k=2,l-1 do j=1,mp do i=1,np ft(i,j,k)=(1.+gamma)*dzi*fqv(i,j,k)*qia(i,j,k) . *gi(i,j)*( rho(i,j,k+1)-rho(i,j,k-1) ) . /( rho(i,j,k+1)+rho(i,j,k-1) ) . +0.5*fqia(i,j,k) enddo enddo enddo do j=1,mp do i=1,np ft(i,j,1)=(1.+gamma)*dzi*fqv(i,j,1)*qia(i,j,1) . *gi(i,j)*( rho(i,j,2)-rho(i,j,1) ) . /( rho(i,j,2)+rho(i,j,1) )*2. . +0.5*fqia(i,j,1) ft(i,j,l)=(1.+gamma)*dzi*fqv(i,j,l)*qia(i,j,l) . *gi(i,j)*( rho(i,j,l)-rho(i,j,l-1) ) . /( rho(i,j,l)+rho(i,j,l-1) ) . +0.5*fqia(i,j,l) enddo enddo do k=1,l do j=1,mp do i=1,np qia(i,j,k)=amax1(0., qia(i,j,k)+dt*ft(i,j,k)) fqv(i,j,k)=(1.+kappa)*fqv(i,j,k) enddo enddo enddo calculate departure point for ice A; use ft, fqv, fqc and fqr as scratches compute first guess do k=1,l kp=min0(l,k+1) do j=1,mp do i=1,np fqc(i,j,k)=( fqv(i,j,kp)-fqv(i,j,k ) )*dzi enddo enddo enddo do 392 k=1,l do 392 j=1,mp do 392 i=1,np xr(i,j,k)=x0(i,j,k)+gc1*gi(i,j)*bx(i,j,k)*fqv(i,j,k) yr(i,j,k)=y0(i,j,k)+gc2*gi(i,j)*by(i,j,k)*fqv(i,j,k) zr(i,j,k)=( z0(i,j,k)+gc3*gi(i,j)*bz(i,j,k)*( . fqv(i,j,k)-fqc(i,j,k)*(k-1)*dz) ) . /( 1.-dt*bz(i,j,k)*fqc(i,j,k) ) 392 continue #if (SEMILAG == 1) call trajbc(xr,yr,zr,n,m,l) #endif cc corrector for ice A departure point call advec(fqv,xr,yr,zr,10,ifirst) do 394 k=1,l do 394 j=1,mp do 394 i=1,np xr(i,j,k)=x0(i,j,k)+gc1*gi(i,j)*bx(i,j,k)*fqv(i,j,k) yr(i,j,k)=y0(i,j,k)+gc2*gi(i,j)*by(i,j,k)*fqv(i,j,k) zr(i,j,k)=z0(i,j,k)+gc3*gi(i,j)*bz(i,j,k)*fqv(i,j,k) 394 continue #if (SEMILAG == 1) call trajbc(xr,yr,zr,n,m,l) #endif cc call advec(qia,xr,yr,zr,10,ifirst) cc --------> end of treatment of ice A in lagrangian model cc ------------> ice B do k=1,l do j=1,mp do i=1,np dens=rho(i,j,k)*gi(i,j) fqv(i,j,k)=vtamv(bvel,dens) enddo enddo enddo cc compute precip rate source term (qi*vt)/rho * d/dz[rho/G]+Fs do k=2,l-1 do j=1,mp do i=1,np ft(i,j,k)=(1.+gamma)*dzi*fqv(i,j,k)*qib(i,j,k) . *gi(i,j)*( rho(i,j,k+1)-rho(i,j,k-1) ) . /( rho(i,j,k+1)+rho(i,j,k-1) ) . +0.5*fqib(i,j,k) enddo enddo enddo do i=1,np do j=1,mp ft(i,j,1)=(1.+gamma)*dzi*fqv(i,j,1)*qib(i,j,1) . *gi(i,j)*( rho(i,j,2)-rho(i,j,1) ) . /( rho(i,j,2)+rho(i,j,1) )*2. . +0.5*fqib(i,j,1) ft(i,j,l)=(1.+gamma)*dzi*fqv(i,j,l)*qib(i,j,l) . *gi(i,j)*( rho(i,j,l)-rho(i,j,l-1) ) . /( rho(i,j,l)+rho(i,j,l-1) ) . +0.5*fqib(i,j,l) enddo enddo do k=1,l do j=1,mp do i=1,np qib(i,j,k)=amax1(0., qib(i,j,k)+dt*ft(i,j,k)) fqv(i,j,k)=(1.+kappa)*fqv(i,j,k) enddo enddo enddo calculate departure point for ice B; use ft, fqv, fqc and fqr as scratches compute first guess do k=1,l kp=min0(l,k+1) do j=1,mp do i=1,np fqc(i,j,k)=( fqv(i,j,kp)-fqv(i,j,k ) )*dzi enddo enddo enddo do 492 k=1,l do 492 j=1,mp do 492 i=1,np xr(i,j,k)=x0(i,j,k)+gc1*gi(i,j)*bx(i,j,k)*fqv(i,j,k) yr(i,j,k)=y0(i,j,k)+gc2*gi(i,j)*by(i,j,k)*fqv(i,j,k) zr(i,j,k)=( z0(i,j,k)+gc3*gi(i,j)*bz(i,j,k)*( . fqv(i,j,k)-fqc(i,j,k)*(k-1)*dz) ) . /( 1.-dt*bz(i,j,k)*fqc(i,j,k) ) 492 continue #if (SEMILAG == 1) call trajbc(xr,yr,zr,n,m,l) #endif cc corrector for ice B departure point call advec(fqv,xr,yr,zr,11,ifirst) do 494 k=1,l do 494 j=1,mp do 494 i=1,np xr(i,j,k)=x0(i,j,k)+gc1*gi(i,j)*bx(i,j,k)*fqv(i,j,k) yr(i,j,k)=y0(i,j,k)+gc2*gi(i,j)*by(i,j,k)*fqv(i,j,k) zr(i,j,k)=z0(i,j,k)+gc3*gi(i,j)*bz(i,j,k)*fqv(i,j,k) 494 continue #if (SEMILAG == 1) call trajbc(xr,yr,zr,n,m,l) #endif cc call advec(qib,xr,yr,zr,11,ifirst) cc --------> end of treatment of ice B in lagrangian model cc --------> END OF TREATMENT OF ICE IN LAGRANGIAN MODEL endif return end Cendif MOISTMOD == 2 #endif Cendif MOISTMOD > 0 #endif Cendif ANALIZE == 0 #endif ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #if (MOISTMOD > 0) #if (MOISTMOD == 2) subroutine h2ovapor cc this subroutine calculates saturated water vapor pressures (Pa) and cc its derivatives based on Wexler formulas cc (see Flatau et al., JAM 1992, 1507-1513). dimension eswt(-1000:1000),esit(-1000:1) dimension deswt(-1000:1000),desit(-1000:1) common/water_table/ eswt,esit,deswt,desit c cc Wexler expressions (2.1 to 2.4) dimension gg(0:7),kk(0:5) real kk data gg /-.29912729e4,-.60170128e4,.1887643854e2,-.28354721e-1, 1 .17838301e-4,-.84150417e-9,.44412543e-12,.2858487e1/ data kk /-.58653696e4,.2224103300e2,.13749042e-1,-.34031775e-4, 1 .26967687e-7,.6918651/ cc Wexler formulas: svpw(t) = exp (1./t**2 * * ( gg(0)+(gg(1)+(gg(2)+gg(7)*log(t)+(gg(3)+(gg(4)+ * (gg(5)+gg(6)*t)*t)*t)*t)*t)*t ) ) svpi(t) = exp (1./t * * ( kk(0)+(kk(1)+kk(5)*log(t)+(kk(2)+(kk(3)+ * kk(4)*t)*t)*t)*t ) ) dsvpw(ew,t)=ew/t**3 * * (((gg(7)+(gg(3)+(2.*gg(4)+(3.*gg(5)+4.*gg(6)*t)*t)*t)*t)*t * -gg(1))*t-2.*gg(0)) dsvpi(ei,t)=ei/t**2 * * ((kk(5)+(kk(2)+(2.*kk(3)+3.*kk(4)*t)*t)*t)*t-kk(0)) cc cc setup the table: do it=-1000,1000 tk=float(it)/10. + 273.16 eswt(it)=svpw(tk) deswt(it)=dsvpw(eswt(it),tk) enddo do it=-1000,0 tk=float(it)/10. + 273.16 esit(it)=svpi(tk) desit(it)=dsvpi(esit(it),tk) enddo esit(1)=esit(0) desit(1)=desit(0) return end subroutine init_ice cc coefficients in Koenig parameterization of depositional growth cc of ice crystals common/koenig/ coef1(32),coef2(32) data coef1/.79E-8,.7939E-7,.7841E-6,.3369E-5,.4336E-5,.5285E-5, * .3728E-5,.1852E-5,.2991E-6,.4248E-6,.7434E-6,.1812E-5, * .4394E-5,.9145E-5,.1725E-4,.3348E-4,.1725E-4,.9175E-5, * .4412E-5,.2252E-5,.9115E-6,.4876E-6,.3473E-6,.4758E-6, * .6306E-6,.8573E-6,.7868E-6,.7192E-6,.6515E-6,.5956E-6, * .533E-6,.4834E-6/ data coef2/.4006,.4006,.4831,.5320,.5307,.5319,.5249,.4888, * .3894,.4047,.4318,.4771,.5183,.5463,.5651,.5813, * .5655,.5478,.5203,.4906,.4447,.4126,.3960,.4149, * .4320,.4506,.4483,.4460,.4433,.4413,.4382,.4361/ cc cc parameters for McFarquahar and Heymsfield parameterization cc - asma, bsma - formula for small crustal IWC cc cal1, cal2 - coefficients for ALPHA cc ami1, ami2 cc bmi1, bmi2 - coefficients for MIU cc asi1, asi2 cc bsi1, bsi2 - coefficients for SIGMA common/mcfarq/ rho_ia,asma,bsma,cal1,cal2, * ami1,ami2,bmi1,bmi2,asi1,asi2,bsi1,bsi2 data rho_ia,asma,bsma,cal1,cal2 * /9.1e2,2.52e-4,.837,4.99e3,4.94e4/ data ami1,ami2,bmi1,bmi2,asi1,asi2,bsi1,bsi2 * /5.20,1.3e-3,.026,-1.2e-3,0.47,2.1e-3,.018,-2.1e-4/ c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c The following is summary of mass, diameter and terminal velocity c relationships that can be used to setup model parameters: c Several types of ice particles are considered for the ice A, and two c types for the ice B. M is the mass of ice particle (kg), d is its c size (meters), i.e., diameter for spherical or platelike, lenghth for c columnar, etc, (see Locatelli and Hobbs 1974), and V is the terminal c velocity in m/sec. c c ********* ICE A: ******************************************** c c -- SMALL CRYSTALS (10-100 microns, Kajikawa 1973) c * mass: c platelike or columnar: c M = 8.1e-3 d**2.1 ! 2.5e-13 kg for d=10 microns c ! 3.3e-11 kg for d=100 microns c * terminal velocity: c platelike c V = 4.44e2 (d-1.e-5) + 1.e-2 ! 1 cm/sec for 10 microns c ! 5 cm/sec for 100 microns c columnar: c V = 1.e3 (d-1.e-5) + 1.e-2 ! 1 cm/sec for 10 microns c ! 10 cm/sec for 100 microns c c -- LARGE CRYSTALS (100-1000 microns, 0.1-1 mm, Kajikawa 1972) c * mass: c platelike c M = 1.20 d**2.64 ! 3.3e-11 kg for d=100 microns c ! 1.4e-8 kg for d=1000 microns c columnar: c M = 33.3 d**3 ! 3.3e-11 kg for d=100 microns c ! 3.3e-8 kg for d=1000 microns c * terminal velocity: c platelike c V = 5.e2 (d-1.e-4) + 5.e-2 ! 5 cm/sec for 100 microns c ! 50 cm/sec for 1000 microns c columnar: c V = 2.25e3 (d-1.e-4) + 1.e-1 ! 10 cm/sec for 100 microns c ! 100 cm/sec for 500 microns c c -- SNOW CRYSTALS (.5-5 mm); my fit to Locatelli/Hobbs data as c published in PAGEOPH: c * mass: c M = 2.5e-2 d**2 ! 6.3e-9 kg for d=500 microns c ! 6.3e-7 kg for d=5000 microns c * terminal velocity: c V = 4.0 d**0.25 ! 60 cm/sec for 500 microns c ! 106 cm/sec for 5000 microns c ***************************************************************** c c ********* ICE B: *********************************************** c c Locatelli and Hobbs data: c c -- LUMP GRAUPEL (1-3 milimeters) c * mass: c M = 19.6 d**2.8 ! 7.8e-8 kg for d=1 mm c ! 1.7e-6 kg for d=3 mm c * terminal velocity: c V = 1.24e2 d**.66 ! 1.3 m/sec for 1 mm c ! 2.7 m/sec for 3 mm c c -- AGGREGATES OF DENSLY RIMED ASSEMBLEGES OF DENDRITES c OR DENDRITES (2-12 milimeters) c * mass: c M = 1.85e-2 d**1.9 ! 1.3e-7 kg for d=2 mm c ! 4.2e-6 kg for d=12 mm c * terminal velocity: c V = 5.1 d**.27 ! 0.95 m/sec for 2 mm c ! 1.55 m/sec for 12 mm c c References: c c Grabowski, W. W., PAGEOPH vol 127 (1988), 79. c Kajikawa, M., JMSJ vol 50 (1972), 577. c Kajikawa, M., JMSJ vol 51 (1973), 263. c Locatelli, J. D., and P. V. Hobbs, JGR vol. 79 (1974), 2185. ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc return end Cendif MOISTMOD == 2 #endif subroutine rhfld(th,qv,n1,m1,l1,ipr,rhf) include 'param.nml' include 'param.misc' include 'msg.inc' dimension th(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) dimension rhf(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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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 real globmax,globmin #if (MOISTMOD == 2) common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf common/water_table/ eswt,esit,deswt,desit dimension eswt(-1000:1000),esit(-1000:1) dimension deswt(-1000:1000),desit(-1000:1) finter(ep,a1,a2)=ep*a2+(1.-ep)*a1 #else common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf #endif rhmx=-1.e15 rhmn= 1.e15 #if (MOISTMOD == 2) epsil=rg/rv b=hlatv/(rv*t00) c=hlatv/cp d=hlatv/rv exp1=-cp/rg do 1 k=1,l do 11 j=1,mp do 11 i=1,np thetme=the(i,j,k)/tme(i,j,k) temp=th(i,j,k)/thetme pre=1.e5*thetme**exp1 temp_l=amax1(174.,amin1(372.,temp)) at1=(temp_l-273.16)*10. it1=at1 it2=it1+sign(1.,at1-1.e-5) eps=abs(at1-float(it1)) ew=finter(eps,eswt(it1),eswt(it2)) qvs=epsil*ew/(pre-ew) 11 rhf(i,j,k)=qv(i,j,k)/qvs 1 continue #else a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg do 1 k=1,l do 11 j=1,mp do 11 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) 11 rhf(i,j,k)=qv(i,j,k)/qvs 1 continue #endif rhmx=amax1(rhmx,globmax(rhf,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp, . 1,l)) rhmn=amin1(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) end if return end Cendif MOISTMOD > 0 #endif subroutine rhngck(rho,n1,m1,l1) include 'param.nml' include 'param.misc' c dimension rho(n,m,l) include 'msg.inc' dimension rho(1-ih:np+ih, 1-ih:mp+ih, l) dimension temp(1-ih:np+ih, 1-ih:mp+ih, l) real globmax,globmin checks for negative density in the profile rhmn= 1.e15 rhmx=-1.e15 do k=1,l do j=1,mp do i=1,np temp(i,j,k)=rhmx end do end do end do if (leftedge.eq.1 .and. botedge.eq.1) then do k=1,l temp(1,1,k)=rho(1,1,k) end do end if rhmx=amax1(rhmx,globmax(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp, . 1,l)) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=rhmn end do end do end do if (leftedge.eq.1 .and. botedge.eq.1) then do k=1,l temp(1,1,k)=rho(1,1,k) end do end if rhmn=amin1(rhmn,globmin(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp, . 1,l)) if (mype.eq.0) then print 266, rhmn,rhmx 266 format(2x,'rhmin, rhmax:',2e11.4) if(rhmn.le.0.) stop 'rho(z).le.0' end if return end subroutine rhprof(rh0,z,l,iflg) dimension rh0(l),z(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u0,v0,u0z,v0z c common/pblc/ HB1,HB2,STS,HT,HS do 10 k=1,l 10 rh0(k)=rh00 if(iflg.lt.0) return capi=1./cap if(iflg.eq.1) then cs=g/(cp*tt00*st) sd=2.e-4*alog(10.)/3. do 1 k=1,l exs=exp(-st*z(k)) rh0(k)=rh00*exs*(1.-cs*(1.-exs))**(capi-1.) c rh0(k)=rh00*exp(-sd*z(k)) c rh0(k)=rh00*exp(-1.51e-4*z(k)) rh0(k)=amax1(rh0(k),1.E-7) c print *,k,'rh0(k)=',rh0(k),' exs=',exs 1 continue else cs0=g/(cp*tt00) do 2 k=1,l rh0(k)=rh00*(1.-cs0*z(k))**(capi-1.) 2 continue endif return end subroutine rhsdiv(u,v,w,d,r,n1,m1,l1,iflg) include 'param.nml' include 'param.misc' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(n,m),tt,tend 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) call update(u,np,mp,l,np,mp) call update(v,np,mp,l,np,mp) call update(w,np,mp,l,np,mp) call update(d,np,mp,l,np,mp) nm=n*m ml=m*l nml=n*m*l do 200 k=1,l do 200 j=1,mp do 200 i=1,np 200 r(i,j,k)=0. if(tt.le.tend .and. tt.ne.0.) then corporate time dependent lower boundary into mass continuity equation do 100 k=1,l do 100 j=1,mp do 100 i=1,np ia=(npos-1)*np + i ja=(mpos-1)*mp + j zbrdt=-gmul(k)/zb*gi(i,j)*zsd(ia,ja) 100 w(i,j,k)=w(i,j,k)-zbrdt call update(w,np,mp,l,np,mp) endif if(igrid.eq.0) then dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi illim = 1 + 1*leftedge iulim = np - 1*rightedge 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 (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 if(j3.eq.1) then 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 (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 endif 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 else dxil=.25*dxi dyil=.25*dyi dzil=.25*dzi if(iflg.eq.0) then if(j3.eq.1) then illim = 1 + 1*leftedge iulim = np jllim = 1 + j3*botedge julim = mp do 5 k=2,l do 5 j=jllim,julim do 5 i=illim,iulim r(i,j,k)=dxil*( 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*( 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*( 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 illim = 1 + 1*leftedge iulim = np do 51 k=2,l do 51 i=illim,np r(i,1,k)=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 illim = 1 + 1*leftedge iulim = np jllim = 1 + j3*botedge julim = mp do 6 k=2,l do 6 j=jllim,julim do 6 i=illim,iulim r(i,j,k)=dxil*( 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*( 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*( 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 illim = 1 + 1*leftedge iulim = np do 61 k=2,l do 61 i=illim,iulim r(i,1,k)=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 endif if(tt.le.tend .and. tt.ne.0.) then come back to original meaning of omega (inverse loop 100) do 111 k=1,l do 111 j=1,mp do 111 i=1,np ia=(npos-1)*np + i ja=(mpos-1)*mp + j zbrdt=-gmul(k)/zb*gi(i,j)*zsd(ia,ja) 111 w(i,j,k)=w(i,j,k)+zbrdt endif call update(w,np,mp,l,np,mp) call update(r,np,mp,l,np,mp) return end subroutine sumcns(a,b,d,n1,n2,n3,sumv,iflg) include 'param.nml' include 'param.misc' dimension sx(m,l),sxy(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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) dimension temp(np) real globsum do k=1,l do j=1,m sx(j,k)=0. do i=1,np temp(i)=0. end do if (leftedge.eq.1) then illim=1+ibcx else illim=1 end if jpos=(j-1)/mp + 1 if (mpos.eq.jpos) then do i=illim,np jm=j - (mpos-1)*mp temp(i)=(a(i,jm,k)-iflg*b(i,jm,k))*d(i,jm,k) end do end if #if (PARALLEL > 0) sx(j,k)=globsum(temp,1,np,1,1,1,1,1,np,1,1,1,1) #else do i=1,np sx(j,k)=sx(j,k)+temp(i) end do #endif c print *,'sx(j,k)=',sx(j,k) c sx(j,k)=fsum1d(temp,np) c sx(j,k)=sx(j,k)-.5*( (a(1,j,k)-iflg*b(1,j,k))*d(1,j,k) c . +(a(n,j,k)-iflg*b(n,j,k))*d(n,j,k) ) enddo enddo if(j3.eq.1) then do k=1,l sxy(k)=0. do j=1+ibcy,m sxy(k)=sxy(k)+sx(j,k) enddo c sxy(k)=sxy(k)-.5*(sx(1,k)+sx(m,k)) enddo else do k=1,l sxy(k)=sx(1,k) enddo endif sumv=0. do k=1,l sumv=sumv+sxy(k) enddo sumv=sumv-.5*(sxy(1)+sxy(l)) return end subroutine teprof(tm0,z,l,iflg) dimension tm0(l),z(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z if(iflg.lt.1) return cs=g/(cp*tt00*st) do 1 k=1,l exs=exp(-st*z(k)) 1 tm0(k)=tt00/exs*(1.-cs*(1.-exs)) return end subroutine thprof(th0,z,l,iflg) dimension th0(l),z(l) common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z if(iflg.eq.1) then thst0=th00 do 1 k=1,l th0(k)=th00*exp(st*z(k)) 1 continue else do 2 k=1,l 2 th0(k)=th00 endif return end subroutine tinit_r(z,tau,lipps) calculate initial profiles when starting from real sounding include 'param.nml' include 'param.misc' include 'msg.inc' parameter (nml=n*m*l,nm=n*m,ml=m*l) dimension tau(l, 1-ih:np+ih, 1-ih:mp+ih) dimension z(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,u0,v0,u0z,v0z common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf 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/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/davies/ zab,towx,towy,towz,nrx,nry,relx(n),rely(m), 1 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), . itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm C data relx/n*0./,rely/m*0./ c davies coefficients c data relx/1.,0.98,0.9,0.5,0.1,0.02/ c data rely/1.,0.98,0.9,0.5,0.1,0.02/ dimension rho1(l),tme1(l),the1(l),qve1(l),ue1(l),ve1(l) dimension zz(l) check absorber thickness if(nrx.gt.n.or.(nry*j3).gt.m) stop 'absorber thicker than domain' nz=l a=rg/rv c=hlatv/cp b=hlats/rv d=hlatv/rv e=-cp/rg pi=4.*atan(1.) cc input sounding: cap=rg/cp capi=1./cap cc surface data: the1(1) =th00 tme1(1) =tt00 rho1(1) =rh00 zz(1)=0. tt=tme1(1) pres=1.e3 delt=(tt-t00)/(tt*t00) esw=ee0*exp(d * delt) qvsw=a * esw /(pres*1.e2-esw) qvs=qvsw qve1(1)=qvs ue1(1)=0. ve1(1)=0. c cs=g/(cp*tme1(1)*st) do k=2,nz zz(k)=float(k-1)*dz exs=exp(-st*zz(k)) the1(k)=the1(1) qve1(k)=qve1(1) rho1(k)=rho1(1) ! *exs*(1.-cs*(1.-exs))**(capi-1.) tme1(k)=tme1(1) ! /exs*(1.-cs*(1.-exs)) pres=1.e3*(the1(k)/tme1(k))**(-cp/rg) ue1(k)=ue1(1) ve1(k)=ve1(1) print*,' k,z,th,qv,rho: ',k,zz(k),the1(k),qve1(k),rho1(k) print*,' ux, uy: ',ue1(k),ve1(k) end do create environmental profiles; topography is now considered: do i=1,np do j=1,mp do k=1,l zcr(k)=z(k)/gi(i,j)+zs(i,j) end do c if (moist.eq.1) then c do k=1,l c kk=zcr(k)/dz+1 c kk=min(l,max(1,kk)) c kkp=min(l,kk+1) c coe=(zcr(k)-z(kk))/dz c tme(i,j,k)=coe*tme1(kkp)+(1.-coe)*tme1(kk) c qve(i,j,k)=coe*qve1(kkp)+(1.-coe)*qve1(kk) c the(i,j,k)=coe*the1(kkp)+(1.-coe)*the1(kk) c ue(i,j,k)=coe*ue1(kkp)+(1.-coe)*ue1(kk) c ve(i,j,k)=coe*ve1(kkp)+(1.-coe)*ve1(kk) c end do c 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) tme(i,j,k)=the(i,j,k) ! p=1.e5 assumed qve(i,j,k)=coe*qve1(kkp)+(1.-coe)*qve1(kk) ue(i,j,k)=coe*ue1(kkp)+(1.-coe)*ue1(kk) ve(i,j,k)=coe*ve1(kkp)+(1.-coe)*ve1(kk) th0(i,j,k)=the(i,j,k) rho(i,j,k)=coe*rho1(kkp)+(1.-coe)*rho1(kk) rho(i,j,k)=rho(i,j,k)/gi(i,j) end do c endif compute reference state vertical profiles for every x,y point c call thprof(tau(1,i,j),zcr,l,lipps) c do k=1,l c th0(i,j,k)=tau(k,i,j) c end do c call rhprof(tau(1,i,j),zcr,l,lipps) c do k=1,l c rho(i,j,k)=tau(k,i,j)/gi(i,j) c end do end do end do compute upper and lateral boundary absorbers c --- compute absorbers at x boundaries toli=1./towx do i=1,nrx t1=float(nrx-i+1) relb=toli*t1/float(nrx) relx(i)=irlx*relb relx(n-i+1)=irlx*relb end do c --- compute absorbers at y boundaries toli=1./towy nrj=(nry-1)*j3+1 do j=1,nrj t1=float(nry-j+1) relb=toli*t1/float(nry) rely(j)=irly*relb rely(m-j+1)=irly*relb end do c --- compute absorbers at upper boundary towi=1./towz do k=1,l do j=1,mp do i=1,np zl=z(k)/gi(i,j)+zs(i,j) t1=iab*amax1(0.,zl-zab) tau(k,i,j)=towi*t1/(zb-zab) end do end do end do call update(th0,np,mp,l,np,mp) call update(rho,np,mp,l,np,mp) call update(the,np,mp,l,np,mp) call update(ve, np,mp,l,np,mp) call update(ue, np,mp,l,np,mp) if (nmsp.eq.np) then call update(qve,np,mp,l,np,mp) call update(tme,np,mp,l,np,mp) end if create flux and roughness fields Z.S. do 30 j=1,mp do 30 i=1,np 30 hfx(i,j)=hf00 ! heat flux in K*m/s 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 return end subroutine tinit_r_dflt(z,tau,lipps) calculate initial profiles when starting from real sounding include 'param.nml' include 'param.misc' include 'msg.inc' parameter (nml=n*m*l,nm=n*m,ml=m*l) dimension tau(l, 1-ih:np+ih, 1-ih:mp+ih) dimension z(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,u0,v0,u0z,v0z common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf 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/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/davies/ zab,towx,towy,towz,nrx,nry,relx(n),rely(m), 1 iab,iabth,iabqw C data relx/n*0./,rely/m*0./ c davies coefficients c data relx/1.,0.98,0.9,0.5,0.1,0.02/ c data rely/1.,0.98,0.9,0.5,0.1,0.02/ 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 check absorber thickness if(nrx.gt.n.or.(nry*j3).gt.m) stop 'absorber thicker than domain' 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 zcr(k)=z(k)/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),zcr,l,lipps) do k=1,l th0(i,j,k)=tau(k,i,j) end do call rhprof(tau(1,i,j),zcr,l,lipps) do k=1,l rho(i,j,k)=tau(k,i,j)/gi(i,j) end do end do end do compute upper and lateral boundary absorbers c --- compute absorbers at x boundaries toli=1./towx do i=1,nrx t1=float(nrx-i+1) relb=toli*t1/float(nrx) relx(i)=irlx*relb relx(n-i+1)=irlx*relb end do c --- compute absorbers at y boundaries toli=1./towy nrj=(nry-1)*j3+1 do j=1,nrj t1=float(nry-j+1) relb=toli*t1/float(nry) rely(j)=irly*relb rely(m-j+1)=irly*relb end do c --- compute absorbers at upper boundary towi=1./towz do k=1,l do j=1,mp do i=1,np zl=z(k)/gi(i,j)+zs(i,j) t1=iab*amax1(0.,zl-zab) tau(k,i,j)=towi*t1/(zb-zab) end do end do end do call update(th0,np,mp,l,np,mp) call update(rho,np,mp,l,np,mp) call update(the,np,mp,l,np,mp) call update(ve, np,mp,l,np,mp) call update(ue, np,mp,l,np,mp) if (nmsp.eq.np) then call update(qve,np,mp,l,np,mp) call update(tme,np,mp,l,np,mp) end if return end subroutine tinit_i(z,xcr,ycr,ne,me,tau,lipps) calculate initial profiles when starting from idealized sounding include 'param.nml' include 'param.misc' include 'msg.inc' parameter (ll1=12, ll2=7, ll3=65) dimension z1(ll1),th1(ll1),tm1(ll1),rt1(ll1),press(ll1) dimension z2(ll2), u2(ll2), v2(ll2) dimension z3(ll3), rh3(ll3) real delta11,delta1,delta,delta21,delta2 common/initpr/ U_e(l),V_e(l),T_e(l),T_m(l),H_e(l) dimension z(l),xcr(ne),ycr(me) dimension relhum(l),relhuf(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,u0,v0,u0z,v0z common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf 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/profc/qce(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common/therbal/ fcor3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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), . itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/davies/ zab,towx,towy,towz,nrx,nry,relx(n),rely(m), 1 iab,iabth,iabqw dimension tau(l, 1-ih:np+ih, 1-ih:mp+ih) common /forc3/ thsrf,qvsrf,coeth,coeqv #if (MOISTMOD == 2) common/water_table/ eswt,esit,deswt,desit dimension eswt(-1000:1000),esit(-1000:1) dimension deswt(-1000:1000),desit(-1000:1) finter(ep,a1,a2)=ep*a2+(1.-ep)*a1 #endif compute vertical profiles for every x,y point open (unit=1, file='ztr.dat', status='old') do ii=1,ll1 READ (1,*) z1(ii),th1(ii),rt1(ii) c if(mype.eq.0) print *, z1(ii),th1(ii),rt1(ii) enddo close(1) thsrf=th1(1) qvsrf=rt1(1) c if(mype.eq.0) print * open (unit=2, file='zuv.dat', status='old') do ii=1,ll2 READ (2,*) z2(ii),u2(ii),v2(ii) c if(mype.eq.0) print *, z2(ii),u2(ii),v2(ii) enddo close(2) c if(mype.eq.0) print * open (unit=3, file='zrh.dat', status='old') do ii=1,ll3 READ (3,*) ii3,z3(ii),rh3(ii) rh3(ii)=rh3(ii)*0.01 c if(mype.eq.0) print *, ii3,z3(ii),rh3(ii) enddo close(3) c if(mype.eq.0) print * compute approximate pressure of height levels: press(1)=pr00/100. tm1(1)=th1(1)*(1000./press(1))**(-rg/cp) do k=2,ll1 km=k-1 tempk =th1(k ) tempkm=th1(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*(z1(k)-z1(km))/cp )**rci tm1(k)=th1(k)*(1000./press(k))**(-rg/cp) enddo c if(mype.eq.0) then c do ii=1,ll1 c print *, z1(ii),press(ii),tm1(ii),th1(ii),rt1(ii) c enddo c print * c endif compute th00,tt00,pr00,rh00 and average stability for base state profiles th00=th1(1) tt00=tm1(1) tvirt=tm1(1)*(1.+.6*rt1(1)) rh00=press(1)*100./(rg*tvirt) pr00=press(1)*100. if(mype.eq.0) then print *,'Surface P0,T0,Th0,Thv0,Rho0: ',pr00,tt00,th00,tvirt,rh00 print * print *,'########################################################' print * endif compute also environmental th=the, and u=ue profiles do 9 j=1,mp do 9 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp do 11 k=1,l 11 zcr(k)=z(k)/gi(i,j)+zs(i,j) call thprof(tau(1,i,j),zcr,l,lipps) do 12 k=1,l 12 th0(i,j,k)=tau(k,i,j) call rhprof(tau(1,i,j),zcr,l,lipps) do 13 k=1,l 13 rho(i,j,k)=tau(k,i,j)/gi(i,j) 9 continue do 10 j=1,mp do 10 i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp do 111 k=1,l 111 zcr(k)=z(k)/gi(i,j)+zs(i,j) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do k=1,l delta1=1.e10 zr=zcr(k) do kk=1,ll3 del=abs(zr-z3(kk)) if(del.lt.delta1) then kin=kk zstrkin=z3(kin) delta1=del endif enddo if((zstrkin.gt.zr).and.(kin.gt.1).and.(kin.le.ll3)) then delta2=abs(z3(kin-1)-zr) delta=delta2+delta1 delta11=1.-delta1/delta delta21=1.-delta2/delta relhuf(k)=delta11*rh3(kin)+delta21*rh3(kin-1) C if((i.eq.1).and.(j.eq.1).and.(k.gt.36).and.(k.lt.41)) then C b(i,j,k)=delta11*a(i,j,kin)+delta21*a(i,j,kin-1) C if(i.eq.1.and.j.eq.1) C . print *,'A:',i,j,k,relhuf(k), C . zr,kin,zstrkin,delta1,delta2,delta11,delta21 C endif elseif((zstrkin.gt.zr).and.(kin.eq.1)) then delta2=abs(z3(kin+1)-zr) delta=delta1/delta2 relhuf(k)=rh3(kin)-delta*(rh3(kin+1)-rh3(kin)) c if((i.eq.1).and.(j.eq.1).and.(k.gt.36).and.(k.lt.41)) then C b(i,j,k)=a(i,j,kin)- C . (a(i,j,kin+1)-a(i,j,kin))*delta c if(i.eq.1.and.j.eq.1) c . print *,'B:',i,j,k,relhuf(k), c . zr,kin,zstrkin,delta1,delta2,delta c endif elseif((zstrkin.lt.zr).and.(kin.ge.1).and.(kin.lt.ll3)) then delta2=abs(z3(kin+1)-zr) delta=delta2+delta1 delta11=1.-delta1/delta delta21=1.-delta2/delta relhuf(k)=delta11*rh3(kin)+delta21*rh3(kin+1) C if((i.eq.1).and.(j.eq.1).and.(k.gt.36).and.(k.lt.41)) then C b(i,j,k)=delta11*a(i,j,kin)+delta21*a(i,j,kin+1) C if(i.eq.1.and.j.eq.1) C . print *,'C:',i,j,k,relhuf(k), C . zr,kin,zstrkin,delta1,delta2,delta11,delta21 C endif elseif((zstrkin.lt.zr).and.(kin.eq.ll3)) then delta2=abs(z3(kin-1)-zr) delta=delta1/delta2 relhuf(k)=rh3(kin)-delta*(rh3(kin-1)-rh3(kin)) c if((i.eq.1).and.(j.eq.1).and.(k.gt.36).and.(k.lt.41)) then C b(i,j,k)=a(i,j,kin)- C . (a(i,j,kin-1)-a(i,j,kin))*delta c if(i.eq.1.and.j.eq.1) c . print *,'D:',i,j,k,relhuf(k), c . zr,kin,zstrkin,delta1,delta2,delta c endif elseif(zstrkin.eq.zr) then relhuf(k)=rh3(kin) c if((i.eq.1).and.(j.eq.1).and.(k.gt.36).and.(k.lt.41)) then c if(i.eq.1.and.j.eq.1) print *,'E:',i,j,k,relhuf(k), c . zr,kin,zstrkin,delta1 C b(i,j,k)=a(i,j,k) c endif else c print *,'ERROR:',i,j,k,zr,kin,zstrkin,delta1 endif enddo if((mype.eq.0).and.(i.eq.1).and.(j.eq.1)) then print * print *,'Environmental profile relhuf:' do k=1,l c print *,k,zcr(k),relhuf(k) enddo endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do k=1,l delta1=1.e10 zr=zcr(k) do kk=1,ll1 del=abs(zr-z1(kk)) if(del.lt.delta1) then kin=kk zstrkin=z1(kin) delta1=del endif enddo if((zstrkin.gt.zr).and.(kin.gt.1).and.(kin.le.ll1)) then delta2=abs(z1(kin-1)-zr) delta=delta2+delta1 delta11=1.-delta1/delta delta21=1.-delta2/delta T_e(k)=delta11*th1(kin)+delta21*th1(kin-1) T_m(k)=delta11*tm1(kin)+delta21*tm1(kin-1) H_e(k)=delta11*rt1(kin)+delta21*rt1(kin-1) C b(i,j,k)=delta11*a(i,j,kin)+delta21*a(i,j,kin-1) C if(i.eq.1.and.j.eq.1) C . print *,'A:',i,j,k,zr,kin,zstrkin,delta1,delta2,delta11,delta21 elseif((zstrkin.gt.zr).and.(kin.eq.1)) then delta2=abs(z1(kin+1)-zr) delta=delta1/delta2 T_e(k)=th1(kin)-delta*(th1(kin+1)-th1(kin)) T_m(k)=tm1(kin)-delta*(tm1(kin+1)-tm1(kin)) H_e(k)=rt1(kin)-delta*(rt1(kin+1)-rt1(kin)) C b(i,j,k)=a(i,j,kin)- C . (a(i,j,kin+1)-a(i,j,kin))*delta C if(i.eq.1.and.j.eq.1) C . print *,'B:',i,j,k,zr,kin,zstrkin,delta1,delta2,delta elseif((zstrkin.lt.zr).and.(kin.ge.1).and.(kin.lt.ll1)) then delta2=abs(z1(kin+1)-zr) delta=delta2+delta1 delta11=1.-delta1/delta delta21=1.-delta2/delta T_e(k)=delta11*th1(kin)+delta21*th1(kin+1) T_m(k)=delta11*tm1(kin)+delta21*tm1(kin+1) H_e(k)=delta11*rt1(kin)+delta21*rt1(kin+1) C b(i,j,k)=delta11*a(i,j,kin)+delta21*a(i,j,kin+1) C if(i.eq.1.and.j.eq.1) C . print *,'C:',i,j,k,zr,kin,zstrkin,delta1,delta2,delta11,delta21 elseif((zstrkin.lt.zr).and.(kin.eq.ll1)) then delta2=abs(z1(kin-1)-zr) delta=delta1/delta2 T_e(k)=th1(kin)-delta*(th1(kin-1)-th1(kin)) T_m(k)=tm1(kin)-delta*(tm1(kin-1)-tm1(kin)) H_e(k)=rt1(kin)-delta*(rt1(kin-1)-rt1(kin)) C b(i,j,k)=a(i,j,kin)- C . (a(i,j,kin-1)-a(i,j,kin))*delta C if(i.eq.1.and.j.eq.1) C . print *,'D:',i,j,k,zr,kin,zstrkin,delta1,delta2,delta elseif(zstrkin.eq.zr) then T_e(k)=th1(kin) T_m(k)=tm1(kin) H_e(k)=rt1(kin) C if(i.eq.1.and.j.eq.1)print *,'E:',i,j,k,zr,kin,zstrkin,delta1 C b(i,j,k)=a(i,j,k) else c print *,'ERROR:',i,j,k,zr,kin,zstrkin,delta1 endif c if((i.eq.1).and.(j.eq.1)) then c print * c print *,'Environmental profile:' c print *,k,zcr(k),T_e(k),T_m(k),H_e(k) c endif enddo cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do k=1,l delta1=1.e10 zr=zcr(k) do kk=1,ll2 del=abs(zr-z2(kk)) if(del.lt.delta1) then kin=kk zstrkin=z2(kin) delta1=del endif enddo if((zstrkin.gt.zr).and.(kin.gt.1).and.(kin.le.ll2)) then delta2=abs(z2(kin-1)-zr) delta=delta2+delta1 delta11=1.-delta1/delta delta21=1.-delta2/delta U_e(k)=delta11*u2(kin)+delta21*u2(kin-1) V_e(k)=delta11*v2(kin)+delta21*v2(kin-1) C print *,'one',k,U_e(k),V_e(k) C b(i,j,k)=delta11*a(i,j,kin)+delta21*a(i,j,kin-1) C if(i.eq.1.and.j.eq.1) C . print *,'A:',i,j,k,zr,kin,zstrkin,delta1,delta2,delta11,delta21 elseif((zstrkin.gt.zr).and.(kin.eq.1)) then delta2=abs(z2(kin+1)-zr) delta=delta1/delta2 U_e(k)=u2(kin)-delta*(u2(kin+1)-u2(kin)) V_e(k)=v2(kin)-delta*(v2(kin+1)-v2(kin)) C print *,'two',k,U_e(k),V_e(k) C b(i,j,k)=a(i,j,kin)- C . (a(i,j,kin+1)-a(i,j,kin))*delta C if(i.eq.1.and.j.eq.1) C . print *,'B:',i,j,k,zr,kin,zstrkin,delta1,delta2,delta elseif((zstrkin.lt.zr).and.(kin.ge.1).and.(kin.lt.ll2)) then delta2=abs(z2(kin+1)-zr) delta=delta2+delta1 delta11=1.-delta1/delta delta21=1.-delta2/delta U_e(k)=delta11*u2(kin)+delta21*u2(kin+1) V_e(k)=delta11*v2(kin)+delta21*v2(kin+1) C print *,'three',k,U_e(k),V_e(k) C b(i,j,k)=delta11*a(i,j,kin)+delta21*a(i,j,kin+1) C if(i.eq.1.and.j.eq.1) C . print *,'C:',i,j,k,zr,kin,zstrkin,delta1,delta2,delta11,delta21 elseif((zstrkin.lt.zr).and.(kin.eq.ll2)) then delta2=abs(z2(kin-1)-zr) delta=delta1/delta2 U_e(k)=u2(kin)-delta*(u2(kin-1)-u2(kin)) V_e(k)=v2(kin)-delta*(v2(kin-1)-v2(kin)) C print *,'four',k,U_e(k),V_e(k) C b(i,j,k)=a(i,j,kin)- C . (a(i,j,kin-1)-a(i,j,kin))*delta C if(i.eq.1.and.j.eq.1) C . print *,'D:',i,j,k,zr,kin,zstrkin,delta1,delta2,delta elseif(zstrkin.eq.zr) then U_e(k)=u2(kin) V_e(k)=v2(kin) C print *,'five',k,U_e(k),V_e(k) C if(i.eq.1.and.j.eq.1)print *,'E:',i,j,k,zr,kin,zstrkin,delta1 C b(i,j,k)=a(i,j,k) else c print *,'ERROR:',i,j,k,zr,kin,zstrkin,delta1 endif c if((i.eq.1).and.(j.eq.1)) then c print * c print *,'Environmental profile:' c print *,k,zcr(k),U_e(k),V_e(k) c endif enddo cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do 141 k=1,l ue(i,j,k)=U_e(k) ve(i,j,k)=V_e(k) the(i,j,k)=T_e(k) qve(i,j,k)=H_e(k) 141 continue convenient place to load environmental profile c do 14 k=1,l COLD ue(i,j,k)=u0 COLD ve(i,j,k)=v0 c COLD the(i,j,k)=th0(i,j,k) COLD if(lipps.ne.1) the(i,j,k)=th00*(1.+ st*zcr(k)) COLD the(i,j,k)= the(i,j,k) COLD . +(fcor3*th0(i,j,k)/g)*(v0z*xcr(ia)-u0z*ycr(ja)) c 14 continue if(moist.eq.1) then do 16 k=1,l 16 tme(i,j,k)=T_m(k) #if (MOISTMOD == 2) epsil=rg/rv exp1=-cp/rg kbase=0 do 17 k=1,l cccccccccccccccccc thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**exp1 temp=tme(i,j,k) temp_l=amax1(174.,amin1(372.,temp)) at1=(temp_l-273.16)*10. it1=at1 it2=it1+sign(1.,at1-1.e-5) eps=abs(at1-float(it1)) ew=finter(eps,eswt(it1),eswt(it2)) qvs=epsil*ew/(pre-ew) relhum(k)=qve(i,j,k)/qvs c qve(i,j,k)=qvs*relhuf(k) if(relhuf(k).gt.0.999) relhuf(k)=1.0 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DETERMINE INITIAL QC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c if(relhuf(k).eq.1.) qce(i,j,k)=0.2e-3 if(relhuf(k).eq.1.) then if(kbase.eq.0) then kbase=k tbase=tme(i,j,k)-273.16 Cw=-4.25e-7*tbase**2+5.36e-5*tbase+1.4e-3 endif qce(i,j,k)=Cw*(zcr(k)-zcr(kbase))*1.e-3 c qce(i,j,k)=amin1(Cw*(zcr(k)-zcr(kbase)),0.3)*1.e-3 endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 17 continue #else cccccccccccccccccc a=rg/rv b=hlat/(rv*t00) c=hlat/cp d=hlat/rv e=-cp/rg kbase=0 do 18 k=1,l thetme=the(i,j,k)/tme(i,j,k) pre=1.e5*thetme**e thi=1./the(i,j,k) y=b*thetme*t00*thi ees=ee0*exp(b-y) qvs=a*ees/(pre-ees) relhum(k)=qve(i,j,k)/qvs qve(i,j,k)=qvs*relhuf(k) if(relhuf(k).gt.0.999) relhuf(k)=1.0 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DETERMINE INITIAL QC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c if(relhuf(k).eq.1.) qce(i,j,k)=0.2e-3 if(relhuf(k).eq.1.) then if(kbase.eq.0) then kbase=k tbase=tme(i,j,k)-273.16 Cw=-4.25e-7*tbase**2+5.36e-5*tbase+1.4e-3 endif qce(i,j,k)=Cw*(zcr(k)-zcr(kbase))*1.e-3 c qce(i,j,k)=amin1(Cw*(zcr(k)-zcr(kbase)),0.3)*1.e-3 endif CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 18 continue #endif endif 10 continue c if (mype.eq.0) then c print * c print *,'Environmental profile:' c do k=1,l c print *,k,zcr(k),ue(1,1,k),ve(1,1,k) c enddo c print * c print *,'Environmental profile the qve Rh_e:' c do k=1,l c print *,k,zcr(k),the(1,1,k),qve(1,1,k),relhum(k) c enddo c print * c print *,'Environmental hum profile: H_e qve RH_e Rh' do k=1,l print *,k,zcr(k),H_e(k),qve(1,1,k),relhum(k),relhuf(k) enddo c endif compute upper and lateral boundary absorbers c --- compute absorbers at x boundaries toli=1./towx do i=1,nrx t1=float(nrx-i+1) relb=toli*t1/float(nrx) relx(i)=irlx*relb relx(n-i+1)=irlx*relb end do c --- compute absorbers at y boundaries toli=1./towy nrj=(nry-1)*j3+1 do j=1,nrj t1=float(nry-j+1) relb=toli*t1/float(nry) rely(j)=irly*relb rely(m-j+1)=irly*relb end do c --- compute absorbers at upper boundary towi=1./towz do k=1,l do j=1,mp do i=1,np zl=z(k)/gi(i,j)+zs(i,j) t1=iab*amax1(0.,zl-zab) tau(k,i,j)=towi*t1/(zb-zab) end do end do end do call update(th0,np,mp,l,np,mp) call update(rho,np,mp,l,np,mp) call update(the,np,mp,l,np,mp) call update(ve, np,mp,l,np,mp) call update(ue, np,mp,l,np,mp) if (nmsp.eq.np) then call update(qve,np,mp,l,np,mp) call update(tme,np,mp,l,np,mp) end if create flux and roughness fields Z.S. do 30 j=1,mp do 30 i=1,np 30 hfx(i,j)=hf00 ! heat flux in K*m/s 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 return end #if (CAPEPL == 1) subroutine parcel(z,th,qv,qc,qr,it) include 'param.nml' include 'param.misc' include 'msg.inc' dimension th(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) dimension z(l),thp(l),qvp(l),qcp(l),buo(l),pre(l) common/wypor/cape(np,0:nth-1),cin(np,0:nth-1) 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,u0,v0,u0z,v0z common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf 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/therbal/ fcor3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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), . itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/davies/ zab,towx,towy,towz,nrx,nry,relx(n),rely(m), 1 iab,iabth,iabqw C data hlatv,hlats /2.53e6,2.84e6/ a=rg/rv c=hlatv/cp b=hlats/rv d=hlatv/rv e=-cp/rg rdcp=rg/cp epsb=rv/rg-1. do 10 i=1,np do 11 j=20,20 ia=i+(npos-1)*np ja=j+(mpos-1)*mp cccc parcel analysis: thp(1)=th(i,j,1) qvp(1)=qv(i,j,1) qcp(1)=0. buo(1)=0. compute height levels and approximate pressure: do 12 k=1,l zcr(k)=z(k)/gi(i,j)+zs(i,j) pre(k)=1.e5*(tme(i,j,k)/the(i,j,k))**(cp/rg) 12 continue do k=2,l nzlast=k-1 thp(k)=thp(k-1) qvp(k)=qvp(k-1) qcp(k)=qcp(k-1) c condensation; loop with linear formula: coe=(pre(k)*1.e-5)**rdcp tmpe=th(i,j,k)*coe rhoe=pre(k)/(rg*tmpe*(1.+.61*qv(i,j,k))) do iter=1,3 tmp=thp(k)*coe cc saturated mixing ration: Clarks model approaximation: cc qvsw=611./(rhoe*rv*tmp)*exp(d*(tmp-273.16)/(tmp*273.16)) cc saturated mixing ration: Eulag model: delt=(tmp-t00)/(tmp*t00) esw=ee0*exp(d * delt) qvsw=a * esw /(pre(k)-esw) cc saturated mixing ratio qvs=qvsw bottom=1. + qvs*hlat/(cp*coe*thp(k))*(hlat/(rv*coe*thp(k))-1.) delta=(qvp(k)-qvs)/bottom delta=amax1(delta,-qcp(k)) cc adjustement: qvp(k)=qvp(k)-delta qcp(k)=qcp(k)+delta thp(k)=thp(k)+delta*hlat/cp/coe enddo ! end of iteration loop cc calculate buoyancy: buo(k)=(thp(k)-th(i,j,k))/th(i,j,k) 1 + epsb*(qvp(k)-qv(i,j,k)) - qc(i,j,k)-qr(i,j,k) buo(k)=buo(k)*g enddo ccc cape and conv. inhibition calculation: kci=nint(3000./dz) ! 3000. is height with buo always is positive cin(i,it)=0 cape(i,it)=0 do k=1,l-1 aint=.5*(buo(k)+buo(k+1))*dz cape(i,it)=cape(i,it)+amax1(0.,aint) if(k.lt.kci) cin(i,it)= cin(i,it)+amin1(0.,aint) enddo 11 continue 10 continue return end #endif subroutine filtprf(a,n3,ifl1,ifl2) dimension a(n3) include 'param.nml' dimension sz(l) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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 return end c.....7..0.........0.........0.........0.........0.........0.........012 subroutine topo(x,y,ne,me) dimension x(ne),y(me) include 'param.nml' include 'param.misc' include 'msg.inc' common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(n,m),tt,tend common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly create mountain create mountain common/gora/ xml,yml,amp,xml0,yml0 data xml,yml,amp,xml0,yml0/ 10.e3,1.e3,0.,0.,0./ 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 data tend/-1.e10/ construct fortran statement functions for the boundary shape rd(xx,yy)=sqrt(((xx-xml0)/xml)**2+j3*((yy-yml0)/yml)**2) c fi (rad)=amp*.5*(1.+cos(pi*rad)) fi (rad)=amp/(1.+rad**2) fid(rad)=0. pi=acos(-1.) compute topografy do 1 j=1,mp do 1 i=1,np ia=i + (npos-1)*np ja=j + (mpos-1)*mp x7=x(ia) y7=y(ja) c print*,'x7,y7: ',x7,y7,rd(x7,y7) r18=rd(x(ia),y(ja)) c zs(i,j)=0. c zs(i,j)=cvmgm(0.,fi(r),1.-r) zs(i,j)=fi(r18) 1 continue compute lateral boundary conditions call update(zs,np,mp,1,np,mp) if (leftedge.eq.1) then do j=1,mp zs(1,j)=zs(2,j)*(1-ibcx)+zs(0,j)*ibcx end do end if call update(zs,np,mp,1,np,mp) if (rightedge.eq.1) then do j=1,mp zs(np,j)=zs(np-1,j)*(1-ibcx)+zs(np+1,j)*ibcx end do end if call update(zs,np,mp,1,np,mp) if (botedge.eq.1) then do i=1,np zs(i,1)=zs(i,1+j3)*(1-ibcy)+zs(i,0)*ibcy end do end if call update(zs,np,mp,1,np,mp) if (topedge.eq.1) then do i=1,np zs(i,mp)=zs(i,mp-j3)*(1-ibcy)+zs(i,mp+1)*ibcy end do end if call update(zs,np,mp,1,np,mp) if(tt.gt.tend) return compute time-derivatives of lower boundary do 2 j=1,m do 2 i=1,n r=rd(x(i),y(j)) zsd(i,j)=fid(r) 2 continue compute lateral boundary conditions do 21 j=1,m zsd(1,j)=zsd(2,j)*(1-ibcx)+zsd(n,j)*ibcx 21 zsd(n,j)=zsd(n-1,j)*(1-ibcx)+zsd(1,j)*ibcx do 22 i=1,n zsd(i,1)=zsd(i,1+j3)*(1-ibcy)+zsd(i,m)*ibcy 22 zsd(i,m)=zsd(i,m-j3)*(1-ibcy)+zsd(i,1)*ibcy return end #if (ANALIZE == 0) subroutine vbcad(d,n1,m1,l1) include 'param.nml' include 'param.misc' 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(n,m),tt,tend common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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 dimension d(1-ih:np+ih, 1-ih:mp+ih, l) dimension tub(1-ih:mp+ih, l, 2), . tvb(1-ih:np+ih, l, 2) . ,wgx(np),wgy(mp),wgz(l) dimension temp(1-ih:np+ih, 1-ih:mp+ih, l) real globsum pp(xx)=amax1(xx,0.) pn(xx)=amin1(xx,0.) if(ibcx.eq.1.and.ibcy.eq.1) return call update(d,np,mp,l,np,mp) 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 temp(i,j,k)=0. end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp temp(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))) end do end do end if uout=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=0. end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp temp(1,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))) end do end do end if uinf=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=0. end do end do end do if (rightedge.eq.1) then do k=1,l do j=1,mp temp(1,j,k)=wgz(k)*wgy(j)*(d(np,j,k)+d(np+1,j,k)) end do end do end if udb=globsum(temp,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 temp(i,j,k)=0. end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np temp(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))) end do end do end if vout=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=0. end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np temp(i,1,k)=wgz(k)*wgx(i)* . (d(i,mp,k)*pn(vb(i,k,2))-d(i,mp+1,k)*pp(vb(i,k,1))) end do end do end if vinf=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=0. end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np temp(i,1,k)=wgz(k)*wgx(i)*(d(i,mp,k) + d(i,mp+1,k)) end do end do end if vdb=globsum(temp,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 temp(i,j,k)=0. end do end do end do do j=1,mp do i=1,np temp(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))) end do end do oout = globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,1) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=0. end do end do end do do j=1,mp do i=1,np temp(i,j,1)=wgx(i)*wgy(j)* . (d(i,j,l)*pn(ob(i,j,2))-d(i,j,1)*pp(ob(i,j,1))) end do end do oinf = globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,1) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=0. end do end do end do do j=1,mp do i=1,np temp(i,j,1) = wgx(i)*wgy(j)*(d(i,j,l)+d(i,j,1)) end do end do odb = globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,1) endif do k=1,l do j=1,mp do i=1,np temp(i,j,k)=0. end do end do end do do j=1,mp do i=1,np ia=i+(npos-1)*np ja=j+(mpos-1)*mp temp(i,j,1) = d(i,j,1)*(-gmul(1)/zb*gi(i,j)*zsd(ia,ja)) end do end do tflx=globsum(temp,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 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 do 33 j=1,mp do 33 i=1,np ob(i,j,2)=pn(ob(i,j,2))+epsim*pp(ob(i,j,2))+epsia 33 ob(i,j,1)=pp(ob(i,j,1))+epsim*pn(ob(i,j,1))-epsia return end subroutine velprd(u,v,w,o,fo,n1,m1,l1,gc1,gc2,gc3,itraj1, . eppr,itpr,ox,oy,oz,q,nts1,mts1,lts1) include 'param.nml' include 'param.misc' include 'msg.inc' dimension u(1-ih:np+ih, 1-ih:mp+ih, l1,0:2), . v(1-ih:np+ih, 1-ih:mp+ih, l1,0:2), . w(1-ih:np+ih, 1-ih:mp+ih, l1,0:1), 1 o(1-ih:np+ih, 1-ih:mp+ih, l1,0:2), . fo(1-ih:ntsp+ih, 1-ih:mtsp+ih, lts), . ox(1-ih:np+ih, 1-ih:mp+ih, l1), . oy(1-ih:np+ih, 1-ih:mp+ih, l1), . oz(1-ih:np+ih, 1-ih:mp+ih, l1), . q(1-ih:np+ih, 1-ih:mp+ih, l1) parameter(lc=0,io=0,iw=1-io, icont0=0) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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), . dv(1-ih:np+ih,1-ih:mp+ih,l) #if (PARALLEL == 0) dimension wk0(1-ih:np+ih,1-ih:mp+ih,0:l+1) dimension wk1(1-ih:np+ih,1-ih:mp+ih,0:l+1) #else dimension wk0(1,1,1) dimension wk1(1,1,1) #endif c.......... c common/special/ p0(1-ih:np+ih,1-ih:mp+ih,l) c parameter(np0=(np+2*ih)*(mp+2*ih)*l) c data p0/np0*0./ c.......... nm=n*m ml=m*l nml=n*m*l if(itraj1.eq.0) then do k=1,l do j=1,mp do i=1,np u(i,j,k,1)=2.*u(i,j,k,0)*(lagr+ieul*rho(i,j,k))-u(i,j,k,2) v(i,j,k,1)=2.*v(i,j,k,0)*(lagr+ieul*rho(i,j,k))-v(i,j,k,2) o(i,j,k,1)=2.*o(i,j,k,0)*(lagr+ieul*rho(i,j,k))-o(i,j,k,2) enddo end do end do else 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)) o(i,j,k,1)=o(i,j,k,0)+0.5*dt*(fo(i,j,k)-o(i,j,k,1)) enddo end do end do if(ieul.eq.0) go to 777 do k=1,l do j=1,mp do i=1,np w(i,j,k,1)=w(i,j,k,0)+0.5*dt*(fz(i,j,k)-w(i,j,k,1)) o(i,j,k,1)=io*o(i,j,k,1 )+iw*w(i,j,k,1 ) q(i,j,k) =io*o(i,j,k,lc)+iw*w(i,j,k,lc) enddo end do end do compute velocity derivatives call update(u(1-ih,1-ih,1,lc),np,mp,l,np,mp) call update(v(1-ih,1-ih,1,lc),np,mp,l,np,mp) call update(q(1-ih,1-ih,1),np,mp,l,np,mp) illim = 1 + 1*leftedge iulim = np - 1*rightedge do 1 i=illim,iulim do 1 j=1,mp do 1 k=1,l cp=0.5*gc1*amax1(0., u(i,j,k,0)) cn=0.5*gc1*amin1(0., u(i,j,k,0)) ux(i,j,k)= cp*(u(i,j,k,lc)-u(i-1,j,k,lc)) . +cn*(u(i+1,j,k,lc)-u(i,j,k,lc)) vx(i,j,k)= cp*(v(i,j,k,lc)-v(i-1,j,k,lc)) . +cn*(v(i+1,j,k,lc)-v(i,j,k,lc)) ox(i,j,k)= cp*(q(i,j,k )-q(i-1,j,k )) . +cn*(q(i+1,j,k )-q(i,j,k )) 1 continue if (leftedge.eq.1) then do j=1,mp do k=1,l c1p=0.5*gc1*amax1(0., u(1,j,k,0)) c1n=0.5*gc1*amin1(0., u(1,j,k,0)) ux(1,j,k)= c1n*(u(2,j,k,lc)-u(1,j,k,lc)) 1 +ibcx*c1p*(u(1,j,k,lc)-u(-1,j,k,lc)) vx(1,j,k)= c1n*(v(2,j,k,lc)-v(1,j,k,lc)) 1 +ibcx*c1p*(v(1,j,k,lc)-v(-1,j,k,lc)) ox(1,j,k)= c1n*(q(2,j,k )-q(1,j,k )) 1 +ibcx*c1p*(q(1,j,k )-q(-1,j,k )) enddo end do end if if (rightedge.eq.1) then do j=1,mp do k=1,l cnp=0.5*gc1*amax1(0., u(np,j,k,0)) cnn=0.5*gc1*amin1(0., u(np,j,k,0)) ux(np,j,k)= cnp*(u(np,j,k,lc)-u(np-1,j,k,lc)) 1 +ibcx*cnn*(u(np+2,j,k,lc)-u(np,j,k,lc)) vx(np,j,k)= cnp*(v(np,j,k,lc)-v(np-1,j,k,lc)) 1 +ibcx*cnn*(v(np+2,j,k,lc)-v(np,j,k,lc)) ox(np,j,k)= cnp*(q(np,j,k )-q(np-1,j,k )) 1 +ibcx*cnn*(q(np+2,j,k )-q(np,j,k )) enddo end do end if if(j3.eq.1) then jllim = 1 + j3*botedge julim = mp - j3*topedge do 2 k=1,l do 2 i=1,np do j=jllim,julim cp=0.5*gc2*amax1(0., v(i,j,k,0)) cn=0.5*gc2*amin1(0., v(i,j,k,0)) uy(i,j,k)= cp*(u(i,j,k,lc)-u(i,j-j3,k,lc)) . +cn*(u(i,j+j3,k,lc)-u(i,j,k,lc)) vy(i,j,k)= cp*(v(i,j,k,lc)-v(i,j-j3,k,lc)) . +cn*(v(i,j+j3,k,lc)-v(i,j,k,lc)) oy(i,j,k)= cp*(q(i,j,k )-q(i,j-j3,k )) . +cn*(q(i,j+j3,k )-q(i,j,k )) enddo if (botedge.eq.1) then c1p=0.5*gc2*amax1(0., v(i,1,k,0)) c1n=0.5*gc2*amin1(0., v(i,1,k,0)) uy(i,1,k)= c1n*(u(i,1+j3,k,lc)-u(i,1,k,lc)) 1 +ibcy*c1p*(u(i,1,k,lc)-u(i,-j3,k,lc)) vy(i,1,k)= c1n*(v(i,1+j3,k,lc)-v(i,1,k,lc)) 1 +ibcy*c1p*(v(i,1,k,lc)-v(i,-j3,k,lc)) oy(i,1,k)= c1n*(q(i,1+j3,k )-q(i,1,k )) 1 +ibcy*c1p*(q(i,1,k )-q(i,-j3,k )) end if if (topedge.eq.1) then cmp=0.5*gc2*amax1(0., v(i,mp,k,0)) cmn=0.5*gc2*amin1(0., v(i,mp,k,0)) uy(i,mp,k)= cmp*(u(i,mp,k,lc)-u(i,mp-j3,k,lc)) 1 +ibcy*cmn*(u(i,mp+1+j3,k,lc)-u(i,mp,k,lc)) vy(i,mp,k)= cmp*(v(i,mp,k,lc)-v(i,mp-j3,k,lc)) 1 +ibcy*cmn*(v(i,mp+1+j3,k,lc)-v(i,mp,k,lc)) oy(i,mp,k)= cmp*(q(i,mp,k )-q(i,mp-j3,k )) 1 +ibcy*cmn*(q(i,mp+1+j3,k )-q(i,mp,k )) end if 2 continue else do k=1,l do j=1,mp do i=1,np uy(i,j,k)=0. vy(i,j,k)=0. oy(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=0.5*gc3*amax1(0., o(i,j,k,0)) cn=0.5*gc3*amin1(0., o(i,j,k,0)) uz(i,j,k)= cp*(u(i,j,k,lc)-u(i,j,k-1,lc)) . +cn*(u(i,j,k+1,lc)-u(i,j,k,lc)) vz(i,j,k)= cp*(v(i,j,k,lc)-v(i,j,k-1,lc)) . +cn*(v(i,j,k+1,lc)-v(i,j,k,lc)) oz(i,j,k)= cp*(q(i,j,k )-q(i,j,k-1 )) . +cn*(q(i,j,k+1 )-q(i,j,k )) 3 continue do j=1,mp do i=1,np c1p=0.5*gc3*amax1(0., o(i,j,1,0)) c1n=0.5*gc3*amin1(0., o(i,j,1,0)) clp=0.5*gc3*amax1(0., o(i,j,l,0)) cln=0.5*gc3*amin1(0., o(i,j,l,0)) uz(i,j,1)= c1n*(u(i,j,2,lc)-u(i,j,1,lc)) uz(i,j,l)= clp*(u(i,j,l,lc)-u(i,j,l-1,lc)) vz(i,j,1)= c1n*(v(i,j,2,lc)-v(i,j,1,lc)) vz(i,j,l)= clp*(v(i,j,l,lc)-v(i,j,l-1,lc)) oz(i,j,1)= c1n*(q(i,j,2 )-q(i,j,1 )) oz(i,j,l)= clp*(q(i,j,l )-q(i,j,l-1 )) enddo end do do k=1,l do j=1,mp do i=1,np u(i,j,k,1)=u(i,j,k,1)-ux(i,j,k)-uy(i,j,k)-uz(i,j,k) v(i,j,k,1)=v(i,j,k,1)-vx(i,j,k)-vy(i,j,k)-vz(i,j,k) o(i,j,k,1)=o(i,j,k,1)-ox(i,j,k)-oy(i,j,k)-oz(i,j,k) enddo end do end do if(iw.eq.1) then do k=1,l do j=1,mp do i=1,np g13=gmul(k)*c13(i,j) g23=gmul(k)*c23(i,j) o(i,j,k,1)=gi(i,j)*o(i,j,k,1)+g13*u(i,j,k,1)+g23*v(i,j,k,1) enddo enddo end do endif 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. c w(i,j,k,1)=p0(i,j,k) u(i,j,k,2)=1. v(i,j,k,2)=0. o(i,j,k,2)=0. enddo end do end do epp=1.e-2*eppr call gcrk(w(1-ih,1-ih,1,1),pfx,pfy,pfz, 1 u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1),o(1-ih,1-ih,1,1), 1 u(1-ih,1-ih,1,2),v(1-ih,1-ih,1,2),o(1-ih,1-ih,1,2), . n,m,l,itpr,epp,1,ux,uy,uz) call prforc(w(1-ih,1-ih,1,1),pfx,pfy,pfz, 1 u(1-ih,1-ih,1,1),v(1-ih,1-ih,1,1),o(1-ih,1-ih,1,1), 1 u(1-ih,1-ih,1,2),v(1-ih,1-ih,1,2),o(1-ih,1-ih,1,2), . n,m,l,wy,wz,dv) do k=1,l do j=1,mp do i=1,np u(i,j,k,1)=pfx(i,j,k) v(i,j,k,1)=pfy(i,j,k) o(i,j,k,1)=pfz(i,j,k) c p0(i,j,k) = w(i,j,k,1) enddo end do end do endif endif if(ieul.eq.1) then if(itraj1.eq.0) then do k=1,l do j=1,mp do i=1,np u(i,j,k,1)=0.5*(u(i,j,k,1)+u(i,j,k,0)*rho(i,j,k))*gc1 v(i,j,k,1)=0.5*(v(i,j,k,1)+v(i,j,k,0)*rho(i,j,k))*gc2 o(i,j,k,1)=0.5*(o(i,j,k,1)+o(i,j,k,0)*rho(i,j,k))*gc3 enddo end do end do else do k=1,l do j=1,mp do i=1,np u(i,j,k,1)=u(i,j,k,1)*rho(i,j,k)*gc1 v(i,j,k,1)=v(i,j,k,1)*rho(i,j,k)*gc2 o(i,j,k,1)=o(i,j,k,1)*rho(i,j,k)*gc3 enddo end do end do endif Create staggered advective velocities for A or B grid ibxo=1-ibcx ibyo=1-ibcy call update(u(1-ih,1-ih,1,1),np,mp,l,np,mp) call update(v(1-ih,1-ih,1,1),np,mp,l,np,mp) call update(o(1-ih,1-ih,1,1),np,mp,l,np,mp) if (igrid.eq.0) then c------------------------> A grid do k=2,l do j=1,mp do i=1,np z0(i,j,k)=0.5*(o(i,j,k,1)+o(i,j,k-1,1)) enddo enddo enddo if(ibcz.eq.0) then do j=1,mp do i=1,np wbc(i,j,1)=2.*o(i,j,1,1)-z0(i,j,2) wbc(i,j,2)=2.*o(i,j,l,1)-z0(i,j,l) enddo enddo else do j=1,mp do i=1,np wbc(i,j,1)=z0(i,j,l) wbc(i,j,2)=z0(i,j,2) enddo enddo endif jllim = 1 + j3*botedge julim = mp do k=1,l do j=jllim,julim do i=1,np y0(i,j,k)=0.5*(v(i,j,k,1)+v(i,j-j3,k,1)) enddo enddo enddo call update(y0,np,mp,l,np,mp) if (botedge.eq.1) then do k=1,l do i=1,np vbc(i,k,1)=ibcy*y0(i,0,k)+ibyo*(2.*v(i,1,k,1)- . y0(i,1+j3,k)) vbc(i,k,2)=ibcy*y0(i,1+j3,k)+ibyo*(2.*v(i,0,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,1)=ibcy*y0(i,mp,k)+ibyo*(2.*v(i,mp+1,k,1)- . y0(i,mp+1+j3,k)) vbc(i,k,2)=ibcy*y0(i,mp+1+j3,k)+ibyo*(2.*v(i,mp,k,1)- . y0(i,mp,k)) end do end do end if illim = 1 + 1*leftedge do k=1,l do j=1,mp do i=illim,np x0(i,j,k)=0.5*(u(i,j,k,1)+u(i-1,j,k,1)) enddo enddo enddo call update(x0,np,mp,l,np,mp) if (leftedge.eq.1) then do k=1,l do j=1,mp ubc(j,k,1)=ibcx*x0(0,j,k)+ibxo*(2.*u(1,j,k,1)-x0(2,j,k)) ubc(j,k,2)=ibcx*x0(2,j,k)+ibxo*(2.*u(0,j,k,1)-x0(0,j,k)) enddo enddo end if if (rightedge.eq.1) then do k=1,l do j=1,mp ubc(j,k,1)=ibcx*x0(np,j,k)+ibxo*(2.*u(np+1,j,k,1)- . x0(np+2,j,k)) ubc(j,k,2)=ibcx*x0(np+2,j,k)+ibxo*(2.*u(np,j,k,1)- . x0(np,j,k)) enddo enddo end if c------------------------. A grid else #if (PARALLEL == 0) c------------------------> B grid if(j3.eq.0) then c-------> 2D c: U velocity do k=1,l do i=1,np wk0(i,1,k)=u(i,1,k,1) end do end do do k=1,l if (leftedge.eq.1 .and. botedge.eq.1) then wk0(0,1,k)=ibcx*u(-1,1,k,1)+ibxo*(2.*u(1,1,k,1)-u(2,1,k,1)) end if if (rightedge.eq.1 .and. botedge.eq.1) then wk0(np+1,1,k)=ibcx*u(np+2,1,k,1)+ibxo*(2.*u(np,1,k,1)- . u(np-1,1,k,1)) end if end do if (botedge.eq.1) then do i=0,n+1 wk0(i,1, 0 )=wk0(i,1, 2 ) wk0(i,1,l+1)=wk0(i,1,l-1) end do end if c: B-grid average if (botedge.eq.1) then iulim = np + 1*rightedge 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 end if c: C-grid x velocities do k=1,l if (botedge.eq.1) then illim = 1 + 1*leftedge do i=illim,np x0(i,1,k)=0.5*(wk1(i,1,k)+wk1(i,1,k+1)) enddo end if if (botedge.eq.1 .and. leftedge.eq.1) then 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)) end if if (botedge.eq.1 .and. rightedge.eq.1) then ubc(1,k,1)=0.5*(wk1( np+1+1,1,k)+wk1( np+1+1 ,1,k+1)) ubc(1,k,2)=0.5*(wk1( np+1,1,k) +wk1( np+1,1,k+1)) end if enddo c: W velocity do k=1,l do i=1,np wk0(i,1,k)=o(i,1,k,1) end do end do if (leftedge.eq.1) then do k=1,l wk0(0 ,1,k)=ibcx*o(-1,1,k,1)+ibxo*o(2,1,k,1) end do end if if (rightedge.eq.1) then do k=1,l wk0(np+1,1,k)=ibcx*o(np+2,1,k,1)+ibxo*o(np-1,1,k,1) end do end if if (botedge.eq.1) then illim = 1 - 1*leftedge iulim = np + 1*rightedge do i=illim,iulim wk0(i,1, 0 )=2.*wk0(i,1,1)-wk0(i,1, 2 ) wk0(i,1,l+1)=2.*wk0(i,1,l)-wk0(i,1,l-1) end do end if c: B-grid average if (botedge.eq.1) then iulim = np + 1*rightedge 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 end if c: C-grid z velocities if (botedge.eq.1) then 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 end if c-------. 2D else c-------> 3D c: U velocity do 10 k=1,l do 10 j=1,mp do 10 i=1,np 10 wk0(i,j,k)=u(i,j,k,1) if (leftedge.eq.1) then do k=1,l do j=1,mp wk0(0 ,j,k)=ibcx*u(-1,j,k,1)+ibxo*(2.*u(1,j,k,1)- . u(2,j,k,1)) end do end do end if if (rightedge.eq.1) then do k=1,l do j=1,mp wk0(np+1,j,k)=ibcx*u(np+2,j,k,1)+ibxo*(2.*u(np,j,k,1)- . u(np-1,j,k,1)) end do end do end if if (botedge.eq.1) then illim = 1 - 1*leftedge iulim = np + 1*rightedge do k=1,l do i=illim,iulim wk0(i,1-j3,k)=ibcy*wk0(i,-j3-1,k)+ibyo*wk0(i,1+j3,k) end do end do end if if (topedge.eq.1) then illim = 1 - 1*leftedge iulim = np + 1*rightedge do k=1,l do i=illim,iulim wk0(i,mp+j3,k)=ibcy*wk0(i,mp+1+1+j3,k)+ . ibyo*wk0(i,mp-j3,k) end do end do end if jllim = 1 - j3*botedge julim = mp + j3*topedge illim = 1 - 1*leftedge iulim = np + 1*rightedge do 13 j=jllim,julim do 13 i=illim,iulim wk0(i,j, 0 )=wk0(i,j, 2 ) 13 wk0(i,j,l+1)=wk0(i,j,l-1) c: B-grid average do k=1,l+1 do j=1,m+j3 do i=1,n+1 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 c: C-grid x velocities do k=1,l do j=1,m do i=2,n 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 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(n+1,j ,k)+wk1(n+1,j ,k+1) . +wk1(n+1,j+j3,k)+wk1(n+1,j+j3,k+1) ) enddo enddo c: V velocity do 20 k=1,l do 20 j=1,m do 20 i=1,n 20 wk0(i,j,k)=v(i,j,k,1) do 21 k=1,l do 21 j=1,m wk0(0 ,j,k)=ibcx*v(n-1,j,k,1)+ibxo*v(2,j,k,1) 21 wk0(n+1,j,k)=ibcx*v(2,j,k,1)+ibxo*v(n-1,j,k,1) do 22 k=1,l do 22 i=0,n+1 wk0(i,1-j3,k)= ibcy*wk0(i,m-j3,k) . +ibyo*(2.*wk0(i,1,k)-wk0(i,1+j3,k)) 22 wk0(i,m+j3,k)= ibcy*wk0(i,1+j3,k) . +ibyo*(2.*wk0(i,m,k)-wk0(i,m-j3,k)) do 23 j=1-j3,m+j3 do 23 i=0,n+1 wk0(i,j, 0 )=wk0(i,j, 2 ) 23 wk0(i,j,l+1)=wk0(i,j,l-1) c: B-grid average do k=1,l+1 do j=1,m+j3 do i=1,n+1 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 c: C-grid y velocities do j=1+j3,m do k=1,l do i=1,n 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 do k=1,l do i=1,n 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 ,m+j3,k)+wk1(i ,m+j3,k+1) . +wk1(i+1,m+j3,k)+wk1(i+1,m+j3,k+1) ) enddo enddo c: W velocity do 30 k=1,l do 30 j=1,m do 30 i=1,n 30 wk0(i,j,k)=o(i,j,k,1) do 31 k=1,l do 31 j=1,m wk0(0 ,j,k)=ibcx*o(n-1,j,k,1)+ibxo*o(2,j,k,1) 31 wk0(n+1,j,k)=ibcx*o(2,j,k,1)+ibxo*o(n-1,j,k,1) do 32 k=1,l do 32 i=0,n+1 wk0(i,1-j3,k)=ibcy*wk0(i,m-j3,k)+ibyo*wk0(i,1+j3,k) 32 wk0(i,m+j3,k)=ibcy*wk0(i,1+j3,k)+ibyo*wk0(i,m-j3,k) do 33 j=1-j3,m+j3 do 33 i=0,n+1 wk0(i,j, 0 )=2.*wk0(i,j,1)-wk0(i,j,2) 33 wk0(i,j,l+1)=2.*wk0(i,j,l)-wk0(i,j,l-1) c: B-grid average do k=1,l+1 do j=1,m+j3 do i=1,n+1 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 c: C-grid z velocities do k=2,l do j=1,m do i=1,n 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,m do i=1,n 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-------. 3D endif c------------------------> B grid #endif endif endif if(lagr.eq.1) then call update(u(1-ih,1-ih,1,1),np,mp,l,np,mp) call update(v(1-ih,1-ih,1,1),np,mp,l,np,mp) call update(o(1-ih,1-ih,1,1),np,mp,l,np,mp) endif return end Cendif ANALIZE == 0 #endif C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c stress code c subroutine rical(u,v,w,th,qv,qc,ismoth) C-grid Richardson number include 'param.nml' include 'param.misc' 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) 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, 6) 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/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(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/ ivis,irid,itstr,noutp,diagstr(8) common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf 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 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), . itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm real dqv,qva,dThd,N2unsat,ee,Tk,Tkm1,Ta,qwk,qwkm1,dqw, 1 rgam,c1,c2,c3,N2sat c compute some local constants nm=n*m ml=m*l nml=n*m*l 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 do k=1,l do j=1,mp do i=1,np ri(i,j,k)=0. stab(i,j,k)=0. defsq(i,j,k)=0. d33(i,j,k)=0. enddo enddo enddo do k=1,l do j=1,mp+1 do i=1,np+1 d11(i,j,k)=0. d12(i,j,k)=0. enddo enddo enddo do k=1,l do j=1,mp+1 do i=1,np d22(i,j,k)=0. enddo enddo enddo do k=1,l+1 do j=1,mp+1 do i=1,np d23(i,j,k)=0. enddo enddo enddo do k=1,l+1 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 vtang=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*vtang*rho(i,j,1) enddo end do 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 call update(u,np,mp,l,np,mp) call update(v,np,mp,l,np,mp) call update(w,np,mp,l,np,mp) jllim = 1 + (j3-ibcy)*botedge julim = mp + (ibcy-j3)*topedge do j=jllim,julim 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 c jp1=(j+j3-j/m*(m-1))*ibcy+(1-ibcy)*min0(j+j3,m) c 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 c if((ibcy.eq.0) .and. (j.eq.1.or.j.eq.m) ) dyil=dyi do i=1,np 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 c ip1=(i+1-i/n*(n-1))*ibcx+(1-ibcx)*min0(i+1,n) c 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 c if((ibcx.eq.0) .and. (i.eq.1.or.i.eq.n) ) dxil=dxi 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) call update(s13,np,mp,1,np,mp) if (rightedge.eq.0 .and. topedge.eq.0) then call update2(dv,np,mp,l+1,np+1,mp+1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update2(dv,np+1,mp,l+1,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update2(dv,np,mp+1,l+1,np+1,mp+1) else call update2(dv,np+1,mp+1,l+1,np+1,mp+1) end if if (rightedge.eq.0) then call update(d13,np,mp,l+1,np+1,mp) else call update(d13,np+1,mp,l+1,np+1,mp) end if do k=1,l do j=1,mp illim = 1 + 1*leftedge iulim = np 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 (rightedge.eq.0 .and. topedge.eq.0) then call updatelr(d11,np,mp,l,np+1,mp+1) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(d11,np+1,mp,l,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(d11,np,mp+1,l,np+1,mp+1) else call updatelr(d11,np+1,mp+1,l,np+1,mp+1) end if if (leftedge.eq.1) then do k=1,l do j=1,mp 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 k=1,l do j=1,mp d11(np+1,j,k) =(ibcx-1)*d11(np,j,k) + ibcx*d11(np+3,j,k) end do end do end if 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) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(d11,np+1,mp,l,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(d11,np,mp+1,l,np+1,mp+1) else call updatelr(d11,np+1,mp+1,l,np+1,mp+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 c 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 c add in d22, d12, d23 if 3D problem call update(s23,np,mp,1,np,mp) if (topedge.eq.0) then call update(d23,np,mp,l+1,np,mp+1) else call update(d23,np,mp+1,l+1,np,mp+1) end if if (j3.eq.1) then compute d22 at (i, j +- 1/2, k) jllim = 1 + j3*botedge julim = mp do k=1,l do i=1,np do j=jllim,julim 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 - dva/dii ) end do end do end do if (topedge.eq.0) then call updatebt(d22,np,mp,l,np,mp+1) else call updatebt(d22,np,mp+1,l,np,mp+1) 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 compute contribution of d22 to def**2 if (topedge.eq.0) then call updatebt(d22,np,mp,l,np,mp+1) else call updatebt(d22,np,mp+1,l,np,mp+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 c compute d12 at (i +- 1/2, j+- 1/2, k) jllim = 1 + j3*botedge julim = mp illim = 1 + 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-1,k))+(u(i,j,k)-u(i,j-1,k))) vxa=hdxi*((v(i,j-1,k)-v(i-1,j-1,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 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) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(d12,np+1,mp,l,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(d12,np,mp+1,l,np+1,mp+1) else call updatelr(d12,np+1,mp+1,l,np+1,mp+1) 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) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(d12,np+1,mp,l,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(d12,np,mp+1,l,np+1,mp+1) else call updatebt(d12,np+1,mp+1,l,np+1,mp+1) 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 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) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(d12,np+1,mp,l,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(d12,np,mp+1,l,np+1,mp+1) else call update(d12,np+1,mp+1,l,np+1,mp+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 c compute d23 at (i, j +- 1/2, k +- 1/2) c note d23 is logically equivalenced to vz so j loop must descend call update(gi,np,mp,1,np,mp) 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) else call updatebt(d23,np,mp+1,l+1,np,mp+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 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) else call updatebt(d23,np,mp+1,l+1,np,mp+1) 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 compute contribution of d23 to def**2 if (topedge.eq.0) then call updatebt(d23,np,mp,l+1,np,mp+1) else call updatebt(d23,np,mp+1,l+1,np,mp+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 c 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 + 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) else call updatelr(d13,np+1,mp,l+1,np+1,mp) 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 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) else call updatelr(d13,np+1,mp,l+1,np+1,mp) 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 compute contribution of d13 to def**2 if (rightedge.eq.0) then call updatelr(d13,np,mp,l+1,np+1,mp) else call updatelr(d13,np+1,mp,l+1,np+1,mp) 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 c 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)*cvmgm(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 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 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,n1,n2,n3) 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) enddo end do end do c c smooth resultant Ri field if(ismoth.ge.1) then call filstr(ri,n1,n2,n3) endif call update(ri,np,mp,l,np,mp) return end #if (ANALIZE == 0) subroutine dissip(u0,v0,w0,th, qv, qc, qr, qia, qib, tke, 1 fx,fy,fz,ft,fqv,fqc,fqr,fqia,fqib,ftke, 2 fo,pfx,pfy,pfz,u1,v1,w1,o1,scalar_id) include 'param.nml' include 'param.misc' 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 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 fo(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), . o1(1-ih:np+ih,1-ih:mp+ih,l) common/stresd/ ivis,irid,itstr,noutp,diagstr(8) 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,qv,qc,qr,qia,qib, !diffusive rhs 1 fx,fy,fz,fo,u1,v1,w1,o1, 1 ft,fqv,fqc,fqr,fqia,fqib,pfx,pfy,pfz, 1 scalar_id) 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 'param.misc' 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), . scr5(1-ih:np+ih, 1-ih:mp+ih, l, 6) 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) dimension temp(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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00,u0z,v0z common/stresd/ ivis,irid,itstr,noutp, * primx,primn,priav,prisd, * kmmx,kmmn,kmav,kmsd 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), . 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 nml=n*m*l nm=n*m 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 c epkm=1.e-3*grkm epkm=1.e-4*grkm do k=1,l do j=1,mp do i=1,np 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 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 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 do j=1,mp do i=1,np Km(i,j,1)= Km(i,j,2) tke(i,j,1)= tke(i,j,2) ftke(i,j,1)= ftke(i,j,2) Prinv(i,j,1)=Prinv(i,j,2) 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 end do end do 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,l do j=1,mp do i=1,np 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-4*grkm do k=1,l do j=1,mp do i=1,np 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) Km(i,j,k)=Kmij tke(i,j,k)=Kmij/(cm*lambda) ! sqrt(E)=Km/(c*L) enddo enddo enddo if(ibcz.eq.0) then do j=1,mp do i=1,np Km(i,j,1)= Km(i,j,2) tke(i,j,1)=tke(i,j,2) enddo enddo endif endif compute diagnostics kmmax=globmax(Km,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) dcr1=kmmax*dt*(dxi**2+j3*dyi**2+dzi**2) if(dcr1.gt.0.5) then print 201,itstr,dcr1 201 format(2x,'it, difcr:',i5,e11.4) stop 'tkefrc cfl' endif c if((itstr/noutp)*noutp.eq.itstr) then 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) priav = priav/float(nml) 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) 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 return end subroutine stress(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, 1 scalar_id) include 'param.nml' include 'param.misc' 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), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 6) 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(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/ ivis,irid,itstr,noutp,diagstr(8) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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), . itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm real cd,den,Kma,tau13,tau23,tau33,tc nm=n*m ml=m*l nml=n*m*l 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) call update(rho,np,mp,l,np,mp) illim = 1 + 1*leftedge iulim = np 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 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) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(f11,np+1,mp,l,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(f11,np,mp+1,l,np+1,mp+1) else call updatelr(f11,np+1,mp+1,l,np+1,mp+1) 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 compute G*tau12=d*km*d12 at (i +- 1/2, j+- 1/2, k) jllim = 1 + j3*botedge julim = mp illim = 1 + 1*leftedge iulim = np 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 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) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(f12,np+1,mp,l,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(f12,np,mp+1,l,np+1,mp+1) else call updatelr(f12,np+1,mp+1,l,np+1,mp+1) 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) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatebt(f12,np+1,mp,l,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatebt(f12,np,mp+1,l,np+1,mp+1) else call updatebt(f12,np+1,mp+1,l,np+1,mp+1) 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 compute G*tau13=d*km*d13 at (i +- 1/2, j, k +- 1/2) illim = 1 + 1*leftedge iulim = np 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 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) else call updatelr(f13,np+1,mp,l+1,np+1,mp) 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 compute G*tau22=d*km*d22 at (i, j +- 1/2, k) if (j3.eq.1) then jllim = 1 + j3*botedge julim = mp 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 create boundary conditions at j=1 and m+1 if (topedge.eq.0) then call updatebt(f22,np,mp,l,np,mp+1) else call updatebt(f22,np,mp+1,l,np,mp+1) 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 else jllim = 1 julim = mp + 1*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) jllim = 1 + j3*botedge julim = mp 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 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) else call updatebt(f23,np,mp+1,l+1,np,mp+1) 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 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) else call updatelr(f13,np+1,mp,l+1,np+1,mp) end if if (topedge.eq.0) then call updatebt(f23,np,mp,l+1,np,mp+1) else call updatebt(f23,np,mp+1,l+1,np,mp+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 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) else if (rightedge.eq.1 .and. topedge.eq.0) then call updatelr(f11,np+1,mp,l,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call updatelr(f11,np,mp+1,l,np+1,mp+1) else call updatelr(f11,np+1,mp+1,l,np+1,mp+1) end if if (rightedge.eq.0 .and. topedge.eq.0) then call update(f12,np,mp,l,np+1,mp+1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(f12,np+1,mp,l,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(f12,np,mp+1,l,np+1,mp+1) else call update(f12,np+1,mp+1,l,np+1,mp+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) else call updatebt(f22,np,mp+1,l,np,mp+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 complete with boundary condition if(ibcz.eq.0) then 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 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 end do end do 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 end do end do endif 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,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) enddo end do end do 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 end do end do 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 end do end do 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 end do #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 endif #endif end if c call update(fu,np,mp,l,np,mp) call update(fv,np,mp,l,np,mp) call update(fw,np,mp,l,np,mp) call update(ft,np,mp,l,np,mp) if (moist.eq.1) then call update(fqv,np,mp,l,np,mp) call update(fqc,np,mp,l,np,mp) call update(fqr,np,mp,l,np,mp) #if (MOISTMOD == 2) if(iceab.eq.1) then call update(fqia,np,mp,l,np,mp) call update(fqib,np,mp,l,np,mp) endif #endif end if return end Cendif ANALIZE == 0 #endif subroutine lapdf(p,r,c,Prinv,hx,hy,hz,pz,itf) include 'param.nml' include 'param.misc' 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . s13(1-ih:np+ih,1-ih:mp+ih), . s23(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 common/stresd/ ivis,irid,itstr,noutp,diagstr(8) 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), . itkes nml=n*m*l nm=n*m 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) 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 end do else if (itf.eq.-1) then ! moisture, do j=1,mmsp do i=1,nmsp srff(i,j)=qfx(i,j) enddo end do else do j=1,mp do i=1,np srff(i,j)=0. enddo end do endif do j=1,mp do i=1,np g33=(s13(i,j)*gmul(1))**2+(s23(i,j)*gmul(1))**2+gi(i,j)**2 srff(i,j) = sqrt(g33)*srff(i,j)/(pri*c(i,j,1)) enddo enddo call update(p,np,mp,l,np,mp) jllim = 1 + (j3-ibcy)*botedge julim = mp + (ibcy-j3)*topedge do 21 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 c jp1=j+j3-j/m*(m-1) c jm1=j-j3+(m-j)/(m-j3)*(m-j3) illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge do 21 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 c ip1=i+1-i/n*(n-1) c im1=i-1+(n-i)/(n-1)*(n-1) g13=s13(i,j)*gmul(1) g23=s23(i,j)*gmul(1) 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(ibcx.eq.0) then illim = 1*leftedge + np*(1-leftedge) iulim = np*rightedge + 1*(1-rightedge) do 211 i=illim,iulim,np-1 jllim = 1 + (j3-ibcy)*botedge julim = mp + (ibcy-j3)*topedge 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 c jp1=j+j3-j/m*(m-1) c jm1=j-j3+(m-j)/(m-j3)*(m-j3) g13=s13(i,j)*gmul(1) g23=s23(i,j)*gmul(1) 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) do 212 j=jllim,julim,mp-j3 illim = 1 + (1-ibcx)*leftedge iulim = np + (ibcx-1)*rightedge 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 c ip1=i+1-i/n*(n-1) c im1=i-1+(n-i)/(n-1)*(n-1) g13=s13(i,j)*gmul(1) g23=s23(i,j)*gmul(1) 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 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(s13,np,mp,1,np,mp) call update(c, np,mp,l,np,mp) call update(rho,np,mp,l,np,mp) if (rightedge.eq.0 .and. topedge.eq.0) then call update(pz,np,mp,l+1,np+1,mp+1) else if (rightedge.eq.1 .and. topedge.eq.0) then call update(pz,np+1,mp,l+1,np+1,mp+1) else if (rightedge.eq.0 .and. topedge.eq.1) then call update(pz,np,mp+1,l+1,np+1,mp+1) else call update(pz,np+1,mp+1,l+1,np+1,mp+1) end if compute x-flux at (i+-1/2,j,k) do j=1,mp illim = 1 + 1*leftedge iulim = np do i=illim,iulim do k=1,l g13=0.5*gmul(k)*(s13(i-1,j)+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)=( pxa + g13*pza )*coef end do end do end do create boundary conditions at i=1 call update(hx,np,mp,l,np,mp) if (leftedge.eq.1) then do j=1,mp do k=1,l hx(1,j,k) = (ibcx-1)*hx(2,j,k) + ibcx*hx(0,j,k) end do end do end if c call update(s13,np,mp,1,np,mp) compute y-flux at (i,j+-1/2,k) if (j3.eq.1) then do i=1,np jllim = 1 + j3*botedge julim = mp do j=jllim,julim do k=1,l g23=0.5*gmul(k)*(s23(i,j-j3)+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)=( pya + g23*pza )*coef end do end do end do create boundary conditions at j=1 call update(hy,np,mp,l,np,mp) 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 compute z-flux at (i,j,k+-1/2) call update(hx,np,mp,l,np,mp) ! i) include the dh/dx and dh/dz terms do k=2,l do j=1,mp illim = 1 iulim = np - 1*rightedge do i=illim,iulim g13=0.5*(gmul(k)+gmul(k-1))*s13(i,j) 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 if (rightedge.eq.1) then corporate b.c. for hx on i=n+1 g13=0.5*(gmul(k)+gmul(k-1))*s13(np,j) 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 if end do end do ! ii) include the dh/dy term if 3D if(j3.eq.1) then call update(hy,np,mp,l,np,mp) do k=2,l do i=1,np jllim = 1 julim = mp - 1*topedge do j=jllim,julim g23=0.5*(gmul(k)+gmul(k-1))*s23(i,j) 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 (topedge.eq.1) then do k=2,l do i=1,np corporate b.c. for hy on j=m+1 g23=0.5*(gmul(k)+gmul(k-1))*s23(i,mp) 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 end if 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 g33=(s13(i,j)*gmul(1))**2+(s23(i,j)*gmul(1))**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 g33=(s13(i,j)*gmul(1))**2+(s23(i,j)*gmul(1))**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 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) do k=1,l do j=1,mp illim = 1 iulim = np - 1*rightedge do i=illim,iulim r(i,j,k) = dxi*(hx(i+1,j,k)-hx(i,j,k)) end do end do end do create boundary conditions on hx at i=n+1 if (rightedge.eq.1) then do k=1,l do j=1,mp 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 c for 3D problem compute d/dy(dh/dy) and add to r if(j3.eq.1) then do k=1,l do i=1,np jllim = 1 julim = mp - 1*topedge do j=jllim,julim r(i,j,k) = r(i,j,k) + dyi*(hy(i,j+1,k)-hy(i,j,k)) end do end do end do if (topedge.eq.1) then do k=1,l do i=1,np create boundary conditions at j=m+1 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 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 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) return end CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C------> D E T E R M I N E S U R F A C E F L U X E S <-------C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC subroutine surf_flux(th,qv,uu,vv,fth,fqv,iinav) include 'param.nml' include 'param.misc' include 'msg.inc' cc simple surface flux routine dimension th(1-ih:np+ih, 1-ih:mp+ih, l), . fth(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:np+ih, 1-ih:mp+ih, l), . fqv(1-ih:np+ih, 1-ih:mp+ih, l), . uu(1-ih:np+ih, 1-ih:mp+ih, l), . vv(1-ih:np+ih, 1-ih:mp+ih, l) common /surface/ thsrf(1-ih:np+ih, 1-ih:mp+ih), . qvsrf(1-ih:np+ih, 1-ih:mp+ih), . thsfl(1-ih:np+ih, 1-ih:mp+ih), . qvsfl(1-ih:np+ih, 1-ih:mp+ih) common /forc3/ thsrf0,qvsrf0,coeth,coeqv 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), . itkes common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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/cyclbc/ ibcx,ibcy,ibcz,irlx,irly dimension ss1(1-ih:np+ih, 1-ih:mp+ih, l), . ss2(1-ih:np+ih, 1-ih:mp+ih, l) ccc ccc coeth=1.e-3 !<-- bulk exchange coef. h_dis=500. !<-- e-folding scale for surface flux top=1000. !<-- PBL height. hpbl=1000. !<-- height of the PBL top=float(iinav-1)*dz hpbl=top do j=1,mp do i=1,np thsrf(i,j)=thsrf0 qvsrf(i,j)=qvsrf0 enddo enddo cc simple formulas for surface fluxes: k=1 do j=1,mp do i=1,np wind=sqrt(uu(i,j,k)**2+vv(i,j,k)**2) alf=coeth*((thsrf(i,j)-th(i,j,k))/the(i,j,1) + 1 .61*(qvsrf(i,j)-qv(i,j,k))) w_star=sqrt(abs(g*top*alf)) wind=sqrt(wind*wind+w_star*w_star) cccccccccccccccccccccccccccccccccccccccccc wind=amax1(wind,2.) cccccccccccccccccccccccccccccccccccccccc cc units below are Km/s and g/g m/s; multiply by rho cp and cc rho hlat to convert into W/m**2 thsfl(i,j)= 1 coeth*wind*(thsrf(i,j)-th(i,j,k)) ! sensible flux qvsfl(i,j)= 1 coeth*wind*(qvsrf(i,j)-qv(i,j,k)) ! latent flux c hfx(i,j)=thsfl(i,j) c qfx(i,j)=qvsfl(i,j) enddo enddo Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc Ccc adjust surface fluxes so constant values are applied Ccc across the domain (we use globsum in a tricky way) C do i=1,np C do j=1,mp C ss1(i,j,1)=thsfl(i,j) C ss2(i,j,1)=qvsfl(i,j) C do k=2,l C ss1(i,j,k)=0. C ss2(i,j,k)=0. C enddo C enddo C enddo C anorm=float(np*mp*nprocx*nprocy) C avsf=globsum(ss1,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)/anorm C avlf=globsum(ss2,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l)/anorm C do i=1,np C do j=1,mp C thsfl(i,j)=avsf C qvsfl(i,j)=avlf C enddo C enddo CCCCCCCCCCCCCCCCCCCCCC C print*,' s. fluxes: ',avsf*1.18*1004.,avlf*1.18*2.5e6 CCCCCCCCCCCCCCCCCCCCCC ccccccccccccccccccccccccccccccccccccccccccccccccccccccc do k=1,l cc note shift of flux positions: zz=(k-1)*dz+.5*dz c expfun=exp(-zz/h_dis) c fun=expfun fun=amax1(0.,(hpbl-zz)/hpbl) c print *,k,zz,'EXPF:',expfun,'F:',fun do j=1,mp do i=1,np ss1(i,j,k)=thsfl(i,j)*fun ss2(i,j,k)=qvsfl(i,j)*fun enddo enddo enddo cc dirty random numbers: im=139968 ia=3877 ic=29573 c first guess: use time to randomize jran=nint(time*1.237) do j=1,mp do i=1,np jran=mod(jran*ia+ic,im) rand0=float(jran)/float(im) r1= 1. + 0.02* 2.*(rand0-.5) jran=mod(jran*ia+ic,im) rand0=float(jran)/float(im) r2= 1. + 0.02* 2.*(rand0-.5) cc first level above the ground: fth(i,j,1)=fth(i,j,1)-(ss1(i,j,1)-thsfl(i,j))/(0.5*dz) 1 * 2. * r1 fqv(i,j,1)=fqv(i,j,1)-(ss2(i,j,1)-qvsfl(i,j))/(0.5*dz) 1 * 2. * r2 cc higher levels: do k=2,l-1 fth(i,j,k)=fth(i,j,k)-(ss1(i,j,k)-ss1(i,j,k-1))/dz 1 * 2. * r1 fqv(i,j,k)=fqv(i,j,k)-(ss2(i,j,k)-ss2(i,j,k-1))/dz 1 * 2. * r2 enddo enddo enddo cc cyclicity: call update(fth,np,mp,l,np,mp) call update(fqv,np,mp,l,np,mp) if (rightedge.eq.1) then do k=1,l do j=1,mp fth(np,j,k)=fth(np+1,j,k) fqv(np,j,k)=fqv(np+1,j,k) enddo enddo end if c if(j3.eq.1) then c call update(fth,np,mp,l,np,mp) c call update(fqv,np,mp,l,np,mp) c if (topedge.eq.1) then c do k=1,l c do i=1,np c fth(i,mp,k)=fth(i,mp+1,k) c fqv(i,mp,k)=fqv(i,mp+1,k) c enddo c end do c end if c endif return end subroutine surf_flux_fair(th,qv,uu,vv,fth,fqv,index,iinav) include 'param.nml' include 'param.misc' include 'msg.inc' dimension th(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . fth(1-ih:np+ih, 1-ih:mp+ih, l), . fqv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . uu(1-ih:np+ih, 1-ih:mp+ih, l), . vv(1-ih:np+ih, 1-ih:mp+ih, l), . ss1(np,mp,l),ss2(np,mp,l), . us(np,mp),vs(np,mp) dimension thsrf1(np,mp),qvsrf1(np,mp),u1(np,mp), . v1(np,mp),th1(np,mp),qv1(np,mp) dimension thsfl(np, mp), . qvsfl(np, mp) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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/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), . itkes common /forc3/ thsrf,qvsrf,coeth,coeqv 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/rain2/ iberry,dconc,ddisp,rac,qctr,an0,colef common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common /thqvbt/vthflx(1-ih:np+ih, 1-ih:mp+ih,l), . vqvflx(1-ih:np+ih, 1-ih:mp+ih,l), . sthflx(1-ih:np+ih, 1-ih:mp+ih,l), . sqvflx(1-ih:np+ih, 1-ih:mp+ih,l), . ceterm(1-ih:np+ih, 1-ih:mp+ih,l), . dsterm(1-ih:np+ih, 1-ih:mp+ih,l), . fmterm(1-ih:np+ih, 1-ih:mp+ih,l), . thlsf(l),qvlsf(l), . radlwh(1-ih:np+ih, 1-ih:mp+ih,l), . radswh(1-ih:np+ih, 1-ih:mp+ih,l) common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf c hpbl=1000. !<-- height of the PBL hpbl=float(iinav-1)*dz delz=10. !<-- height used in the flux formula c do j=1,mp do i=1,np thsrf1(i,j)=thsrf qvsrf1(i,j)=qvsrf u1(i,j)=uu(i,j,1) v1(i,j)=vv(i,j,1) th1(i,j)=th(i,j,1) qv1(i,j)=qv(i,j,1) enddo enddo cc call routine to get surface fluxes: cc -- flux returns from fairall in cc -- units of Km/s and g/g m/s; multiply by rho cp and cc -- rho hlat to convert into W/m**2 call fairall(u1,v1,th1,qv1,delz,thsrf1,qvsrf1, * us,vs,thsfl,qvsfl,np*mp) c cc apply flux to the model if(index.eq.0) return cMIREKA write (58) thsfl c write (59) qvsfl do k=1,l cc note shift of flux positions: zz=(k-1)*dz+.5*dz fun=amax1(0.,(hpbl-zz)/hpbl) do j=1,mp do i=1,np ss1(i,j,k)=thsfl(i,j)*fun ss2(i,j,k)=qvsfl(i,j)*fun c hfx(i,j)=thsfl(i,j) c qfx(i,j)=qvsfl(i,j) enddo enddo enddo do j=1,mp do i=1,np cc first level above the ground: fth(i,j,1)=fth(i,j,1)-(ss1(i,j,1)-thsfl(i,j))/(0.5*dz) * 2. fqv(i,j,1)=fqv(i,j,1)-(ss2(i,j,1)-qvsfl(i,j))/(0.5*dz) * 2. sthflx(i,j,1)=sthflx(i,j,1)-(ss1(i,j,1)-thsfl(i,j))/(0.5*dz) sqvflx(i,j,1)=sqvflx(i,j,1)-(ss2(i,j,1)-qvsfl(i,j))/(0.5*dz) cc higher levels: do k=2,l-1 fth(i,j,k)=fth(i,j,k)-(ss1(i,j,k)-ss1(i,j,k-1))/dz * 2. fqv(i,j,k)=fqv(i,j,k)-(ss2(i,j,k)-ss2(i,j,k-1))/dz * 2. sthflx(i,j,k)=sthflx(i,j,k)-(ss1(i,j,k)-ss1(i,j,k-1))/dz sqvflx(i,j,k)=sqvflx(i,j,k)-(ss2(i,j,k)-ss2(i,j,k-1))/dz enddo enddo enddo return end subroutine fairall(uu,vv,th,qv,ZU,th0,qv0,ustr,vstr, 1 thfl,qvfl,n) dimension uu(n),vv(n),th(n),qv(n),thfl(n),qvfl(n),th0(n),qv0(n) dimension ustr(n),vstr(n) ccc arrays from routine LKB DIMENSION A(9,2),B(9,2),RAN(9) DATA A/0.177,1.376,1.376,1.026,1.625,4.661,34.904,1667.19,5.88E5, 10.292,1.808,1.808,1.393,1.956,4.994,30.709,1448.68,2.98E5/ DATA B/0.,0.929,0.929,-0.599,-1.018,-1.475,-2.067,-2.907,-3.935, 10.,0.826,0.826,-0.528,-0.870,-1.297,-1.845,-2.682,-3.616/ DATA RAN/0.11,.16,1.00,3.0,10.0,30.0,100.,300.,1000./ cc zi=600. ! m c--------------------------- Factors ------------------------------- Beta=1.2 ! evaluated from Fairalls low windspeed turbulence data Von=0.4 ! von Karman's "constant" fdg=1.00 ! Fairall's LKB rr to von karman adjustment toK=273.16 ! Celsius to Kelvin grav=9.72 ! gravity equatorial value (ref. IGPP-SIO) c--------------------------- Air constants --------------------------- Rgas=287.1 ! J/kg/K gas const. dry air hl=2.40*1e+6 ! J/kg latent heat of vaporization Cpa=1004.67 ! J/kg/K specific heat of dry air (Businger 1982) c rhoa=P*100./(Rgas*(T+toK)*(1.+.61*Q)) ! kg/m3 Moist air density ( " ) rhoa=1.137 ! above evaluated for T=30, q=18.e-3 c visa=1.326e-5*(1+6.542e-3*T+8.301e-6*T*T-4.84e-9*T*T*T) ! m2/s visa=1.596e-5 ! above evaluated for T=30. c Kinematic viscosity of dry air - Andreas (1989) CRREL Rep. 89-11 c--------------------------Iteration accuracy ------------------------ cc epsf is constant to define iteration accuracy for flux in W/m**2 epsf=.05 ! conergence constant c--------------------------------------------------------------------- C TO EVALUATE SURFACE FLUXES, SURFACE ROUGHNESS AND STABILITY OF C THE ATMOSPHERIC SURFACE LAYER FROM BULK PARAMETERS BASED ON C LIU ET AL. (79) JAS 36 1722-1735 c---------------------------- Initial guesses --------------------------- do 203 i=1,n ZL=0. US=0. !surface current = 0. Wg=0.5 !Gustiness factor initial guess ZO=.0005 !roughness initial guess U=sqrt(uu(i)**2 + vv(i)**2) DU=U-US DU_Wg=(DU**2.+Wg**2.)**.5 !include gustiness in wind spd. difference T=th(i)-.0098*ZU-toK Q=qv(i) DT=th(i)-th0(i) DQ=qv(i)-qv0(i) USR=.04*DU_Wg ! TSR=.04*DT !initial guesses QSR=.04*DQ ! TA=T+toK TV=TA*(1.+0.61*Q) RI=grav*ZU*(DT+0.61*TA*DQ)/(TA*DU_Wg**2) c HF=-USR*TSR EF=-USR*QSR c ----------------------------- Iterate 20 times ------------------------ do index=1,20 C C EVALUATE OBUKHOVS STABILITY PARAMETER Z/L FROM AVERAGE C TEMP T IN DEG C, AVERAGE HUMIDITY Q IN GM/GM, HEIGHT IN M, C AND FRICTIONAL VEL,TEMP.,HUM. IN MKS UNITS C SEE LIU ET AL. (1979) C TVSR=TSR*(1.+0.61*Q)+0.61*TA*QSR c OB=TV*USR*USR/(grav*VON*(TVSR+1.e-8)) if(abs(TVSR).le.1.e-6) TVSR=1.e-6 OB=TV*USR*USR/(grav*VON*TVSR) ZL=ZU/OB IF(abs(TVSR).LE.1.E-6) ZL=0 PUZ=PSI(1,ZL) PTZ=PSI(2,ZL) PQZ=PSI(2,ZL) ZO=0.011*USR*USR/grav + 0.11*visa/USR !after Smith 1988 USR=DU_Wg*von/(ALOG(ZU/ZO)-PUZ) !Gustiness effect incl. RR=ZO*USR/visa C DETERMINE THE LOWER BOUNDARY VALUE RT OF THE C LOGARITHMIC PROFILES OF TEMPERATURE (IFLAG=1) C OR HUMIDITY (IFLAG=2) IN THE ATMOSPHERE FROM ROUGHNESS C REYNOLD NUMBER RR BETWEEN 0 AND 1000. OUT OF RANGE C RR BROUGHT BACK TO 0 OT 1000, MESSAGE PRINTED. C BASED ON LIU ET AL.(1979) JAS 36 1722-1723 c New scalar RR relation from Moana Wave data. C IR=1 RR_L=amax1(1.e-4,amin1(999.,RR)) 10 CONTINUE IF(RR_L.LE.RAN(IR)) GOTO 20 IR=IR+1 GOTO 10 20 RT=A(IR,1)*RR_L**B(IR,1) RQ=A(IR,2)*RR_L**B(IR,2) zot=rt*visa/usr zoq=rq*visa/usr S = (ALOG(ZU/zot)-PTZ)/(von*fdg) !coeff fdg=1.04 included following D = (ALOG(ZU/zoq)-PQZ)/(von*fdg) !Fairall observations during COARE !NOTE coeff changed to 1. tsr=dt/S !! modify qsr=dq/D !! fluxes TVSR=TSR*(1.+0.61*Q)+(0.61*TA*QSR) Bf=-grav/TA*USR*TVSR if(Bf.gt.0) then Wg=Beta*(Bf*zi)**0.333 else Wg=0.01 endif DU_Wg=(DU**2.+Wg**2.)**.5 !include gustiness in wind spd. c HFO=HF EFO=EF HF=-USR*TSR EF=-USR*QSR cc stop iterations if flux small or small change from previous one if(amax1(1.e3*abs(HF-HFO),2.e6*abs(EF-EFO)).le.epsf) go to 204 if(amax1(1.e3*abs(HF),2.e6*abs(EF)).le.10.*epsf) go to 204 end do c-------------------------------- End iterations ----------------------------- c 204 continue thfl(i)=HF qvfl(i)=EF ustr(i)=usr**2*uu(i)/(u+1.e-3) vstr(i)=usr**2*vv(i)/(u+1.e-3) 203 continue c return end FUNCTION PSI(ID,ZL) C C TO EVALUATE THE STABILITY FUNCTION PSI FOR WIND SPEED (IFLAG=1) C OR FOR TEMPERATURE AND HUMIDITY PROFILES FROM STABILITY C PARAMETER ZL. SEE LIU ET AL (1979). c Modified to include convective form following Fairall (Unpublished) C IF(ZL)10,20,30 10 F=1./(1+zl*zl) CHIK=(1.-16.*ZL)**0.25 IF(ID.EQ.1) GOTO 11 PSIK=2.*ALOG((1.+CHIK*CHIK)/2.) GOTO 12 11 PSIK=2.*ALOG((1.+CHIK)/2.)+ALOG((1.+CHIK*CHIK)/2.) 1 -2.*ATAN(CHIK)+2.*ATAN(1.) 12 CHIC=(1.-12.87*ZL)**.333 !for very unstable conditions PSIC=1.5*ALOG((CHIC*CHIC+CHIC+1.)/3.) & -(3.**.5)*ATAN((2*CHIC+1.)/(3.**.5)) & +4.*ATAN(1.)/(3.**0.5) c c match Kansas and free-conv. forms with weighting F c PSI= F*PSIK+(1-F)*PSIC goto 99 20 PSI=0. GOTO 99 30 continue PSI=-4.7*ZL 99 RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C------> E N D O F S U R F A C E F L U X E S <-------C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ccc subroutines for CRM runs: subroutine ls_forc(iflag,timein) include 'param.nml' cc below is the setup for 8-day run; data every 6 hrs PARAMETER(NTIND=8*4 + 1,nz=l) cc velocity components, th and qv profiles, forcings and time array: dimension uugate(nz,ntind), vvgate(nz,ntind), 1 thgate(nz,ntind), qvgate(nz,ntind), 1 dthgate(nz,ntind),dqvgate(nz,ntind), 2 thsst(ntind),qvsst(ntind),tigate(ntind) common /gate/ uugate,vvgate,thgate,qvgate, 1 dthgate,dqvgate,thsst,qvsst,tigate CC COMMONS USED TO COMMUNICATE WITH THE MODEL: cc forc1: varying in time ux and uy profiles common /forc1/ uxnu(nz),uynu(nz) cc forc2: advective effects for theta (K/sec) qv (kg/kg/sec) common /forc2/ dthls(nz),dqvls(nz) cc forc3: sea surface potential temperature (K) and water vapor cc mixing ratio (kg/kg) common /forc3/ thsrf,qvsrf,coeth,coeqv cc forc4: varying in time profiles of theta and qv: cc units are K and kg/kg common /forc4/ thobs(nz),qvobs(nz) cc if(iflag.eq.0) then do iread=1,ntind cc velocity profiles read(35,801) timeaa, 1 (uugate(k,iread),k=1,nz),(vvgate(k,iread),k=1,nz) 801 format(10f8.3) cc time will be in seconds: tigate(iread)=timeaa*3600. cc profiles for l-s forcing terms (fort.37) read(37,802) timebb, 1 (dthgate(k,iread),k=1,nz),(dqvgate(k,iread),k=1,nz) 802 format(8e12.4) cc ocean surface theta and qv at surface (fort.39) read(39,803) timecc,thsst(iread),qvsst(iread) 803 format(3e16.5) cc theta and qv profiles (fort.41) read(41,804) timedd, 1 (thgate(k,iread),k=1,nz),(qvgate(k,iread),k=1,nz) 804 format(8e13.5) diff=timeaa-timebb+timedd-timecc if(diff.gt..001) then print*,' ***** INCONSISTENT TIMES ON INPUT TAPE.' STOP 'INPUT' endif enddo print*,' *** DATA READ FROM INPUT TAPES!! ***' return endif if(iflag.eq.1) then cc call during run to load wind profles, ls forcing terms and SST data: timef=timein*60 ! time in seconds cc velocities and surface data - find time just larger in gate dataset: do itt=2,ntind itim=itt if(tigate(itt).ge.timef) go to 204 enddo print*,' error 1 in setting up ls forc. STOP' stop 'error 1' 204 continue cc interpolate: coe=(tigate(itim)-timef)/(tigate(itim)-tigate(itim-1)) do k=1,nz uxnu(k)=coe*uugate(k,itim-1)+(1.-coe)*uugate(k,itim) uynu(k)=coe*vvgate(k,itim-1)+(1.-coe)*vvgate(k,itim) thobs(k)=coe*thgate(k,itim-1)+(1.-coe)*thgate(k,itim) qvobs(k)=coe*qvgate(k,itim-1)+(1.-coe)*qvgate(k,itim) thsrf=coe*thsst(itim-1)+(1.-coe)*thsst(itim) qvsrf=coe*qvsst(itim-1)+(1.-coe)*qvsst(itim) enddo cc ls forcing - find closest time and take constant value to cc keep changes consistent with forcings: dtlsf=tigate(2)-tigate(1) half=.50001*dtlsf do itt=1,ntind itim=itt if(abs(tigate(itt)-timef).le.half) go to 304 enddo print*,' error 2 in setting up ls forc. STOP' stop 'error 2' 304 continue do k=1,nz dthls(k)=dthgate(k,itim) dqvls(k)=dqvgate(k,itim) enddo endif return end subroutine horave(aa,bb,nx,ny,nz,icx,icy,id3) include 'param.nml' include 'param.misc' include 'msg.inc' dimension aa(1-ih:np+ih,1-ih:mp+ih,l),bb(nz) j1= 1 j2=(ny-icy)*id3+1-id3 i1= 1 i2=nx-icx anorm=float((j2-j1+1)*(i2-i1+1)) do k=1,nz bb(k)=0. bb(k)=globsum(aa,1-ih,np+ih,1-ih,mp+ih,1,l,i1,i2,j1,j2,k,k) bb(k)=bb(k)/anorm enddo return end subroutine noise(th,qv,dz,ibcx,ibcy) include 'param.nml' include 'param.misc' include 'msg.inc' dimension th(1-ih:np+ih, 1-ih:mp+ih, l), . qv(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) cc add random pert to the temperature and moisture fields: tampl=.1 qampl=.1e-3 do k=2,l-1 acoe=1. heigh=(k-1)*dz if(heigh.gt.1.e3) acoe=0. do j=1,mp do i=1,np rand1=tampl * 2.*(rand()-.5) th(i,j,k)=th(i,j,k)+acoe*rand1 rand2=qampl * 2.*(rand()-.5) qv(i,j,k)=qv(i,j,k)+acoe*rand2 enddo enddo enddo cc cyclicity: if(ibcx.eq.1) then call update(th,np,mp,l,np,mp) if (rightedge.eq.1) then do k=1,l do j=1,mp th(np,j,k)=th(np+1,j,k) enddo enddo end if endif if(ibcy.eq.1) then call update(th,np,mp,l,np,mp) if (topedge.eq.1) then do k=1,l do i=1,np th(i,mp,k)=th(i,mp+1,k) enddo end do end if endif if(ibcx.eq.1) then call update(qv,np,mp,l,np,mp) if (rightedge.eq.1) then do k=1,l do j=1,mp qv(np,j,k)=qv(np+1,j,k) enddo enddo end if endif if(ibcy.eq.1) then call update(qv,np,mp,l,np,mp) if (topedge.eq.1) then do k=1,l do i=1,np qv(i,mp,k)=qv(i,mp+1,k) enddo end do end if endif return end CCCCCCCCC PUT YOURS CCCCCCC subroutine integxy(a,j3) include 'param.nml' include 'param.misc' include 'msg.inc' common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly dimension a(1-ih:np+ih, 1-ih:mp+ih, l) dimension sx(np), sy(mp+1) call update(a,np,mp,l,np,mp) illim = 1 + 1*leftedge iulim = np - 1*rightedge 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 (leftedge.eq.1) then sx(1)=ibcx*0.25*(a(2,j,k)+2.*a(1,j,k)+a(-1,j,k)) . +(1-ibcx)*.5*(a(1,j,k)+a(2,j,k)) end if if (rightedge.eq.1) then sx(np)=ibcx*0.25*(a(np+2,j,k)+2.*a(np+1,j,k)+a(np-1,j,k)) . +(1-ibcx)*.5*(a(np-1,j,k)+a(np,j,k)) end if do i=1,np a(i,j,k)=sx(i) enddo enddo enddo call update(a,np,mp,l,np,mp) if(j3.eq.1) then jllim=1 + j3*botedge julim=mp - j3*topedge 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 (botedge.eq.1) then sy(1)=ibcy*0.25*(a(i,1+j3,k)+2.*a(i,1,k)+a(i,-j3,k)) . +(1-ibcy)*.5*(a(i,1,k)+a(i,1+j3,k)) end if if (topedge.eq.1) then sy(mp)=ibcy*0.25*(a(i,mp+1+j3,k)+2.*a(i,mp+1,k)+ . a(i,mp-j3,k)) +(1-ibcy)*.5*(a(i,mp-1,k)+ . a(i,mp,k) ) end if do j=1,mp a(i,j,k)=sy(j) enddo enddo enddo endif return end subroutine xyfilt(ui,vi,wi,uo,vo,wo,n1,n2,n3,j3) c c Filter the fields using 17points filter (fewer near the boundary). c include 'param.nml' include 'param.misc' include 'msg.inc' dimension ui(1-ih:np+ih, 1-ih:mp+ih, l), * vi(1-ih:np+ih, 1-ih:mp+ih, l), * wi(1-ih:np+ih, 1-ih:mp+ih, l), * uo(1-ih:np+ih, 1-ih:mp+ih, l), * vo(1-ih:np+ih, 1-ih:mp+ih, l), * wo(1-ih:np+ih, 1-ih:mp+ih, l) do k=1,l do j=1,mp do i=1,np uo(i,j,k)=ui(i,j,k) enddo enddo enddo CALL FILTER(uo,1,n,1,m,l,j3) do k=1,l do j=1,mp do i=1,np uo(i,j,k)=uo(i,j,k)-ui(i,j,k) enddo enddo enddo do k=1,l do j=1,mp do i=1,np vo(i,j,k)=vi(i,j,k) enddo enddo enddo CALL FILTER(vo,1,n,1,m,l,j3) do k=1,l do j=1,mp do i=1,np vo(i,j,k)=vo(i,j,k)-vi(i,j,k) enddo enddo enddo do k=1,l do j=1,mp do i=1,np wo(i,j,k)=wi(i,j,k) enddo enddo enddo CALL FILTER(wo,1,n,1,m,l,j3) do k=1,l do j=1,mp do i=1,np wo(i,j,k)=wo(i,j,k)-wi(i,j,k) enddo enddo enddo return end #if(PARALLEL > 0) SUBROUTINE FILTER(datarr,L0,LN,K0,KN,MZ,j3) include 'param.nml' include 'param.misc' include 'msg.inc' include 'trparam.h' #include "msg.lnk" #include "msg.lnp" real WORK(10000) CCC FOR PARALLEL WE NEED THIS CCCCCCCCCCCCCCCCCCCC dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) real wp1( p1_mx,p1_my,p1_mz ) , . wp2( p2_mx,p2_my,p2_mz ) , . wp3( p3_mx,p3_my,p3_mz ) , . wp4( p1_mx,p1_my,p1_mz ) ip1 = p1_mx*p1_my*p1_mz ip2 = p2_mx*p2_my*p2_mz ip3 = p3_mx*p3_my*p3_mz do i=1,ip1 wp1(i,1,1)=0. wp4(i,1,1)=0. enddo do i=1,ip2 wp2(i,1,1)=0. enddo do i=1,ip3 wp3(i,1,1)=0. enddo do k=1,l do j=1,mp do i=1,np wp1(i,j,k)=datarr(i,j,k) enddo enddo enddo call transpose_x_z ( 1, 2, wp1, wp2 ) DO 5 I=1,10000 WORK(I)=0. 5 CONTINUE DO 10 M1=1,p2_nk DO 12 K1=1,p2_nj DO 14 L1=L0,n WORK(L1)=wp2(L1,K1,M1) 14 CONTINUE DO 12 L1=L0+1,n-1 wp2(L1,K1,M1)=PP(L1,n,WORK) 12 CONTINUE 10 CONTINUE if(j3.eq.1) then do i=1,10000 WORK(I)=0. enddo call transpose_x_y ( 2, 3, wp2, wp3 ) DO 100 M1=1,p2_nk DO 22 L1=L0,p3_ni DO 24 K1=K0,m WORK(K1)=wp3(L1,K1,M1) 24 CONTINUE DO 22 K1=K0+1,m-1 wp3(L1,K1,M1)=PP(K1,m,WORK) 22 CONTINUE 100 CONTINUE call transpose_x_y ( 3, 2, wp2, wp3 ) endif call transpose_x_z ( 2, 1, wp4, wp2 ) do k=1,l do j=1,mp do i=1,np datarr(i,j,k)=wp4(i,j,k) enddo enddo enddo RETURN END #else SUBROUTINE FILTER(datarr,L0,LN,K0,KN,MZ,j3) include 'param.nml' include 'param.misc' include 'msg.inc' #if(PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif DIMENSION FLD(n,m,l), * WORK(10000) CCC FOR PARALLEL WE NEED THIS CCCCCCCCCCCCCCCCCCCC dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) dimension tmparray(np,mp,l) nmlp=np*mp*l cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, getting their data and transferring it cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(mype.eq.0) then ccccccccccccccccccccccccccccccccccccccccccccc c transfer processor 0 data to big array ccccccccccccccccccccccccccccccccccccccccccccc do k=1,l do j=1,mp do i=1,np FLD(i,j,k)=datarr(i,j,k) end do end do end do CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC #if (PARALLEL > 0) do iproc=1,(nprocx*nprocy - 1) #if (PARALLEL == 2) call MPI_Recv(tmparray, nmlp, DC_TYPE, iproc, 99, . MPI_COMM_WORLD, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi2 in FILTER' 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 FLD(((npos1-1)*np + i), ((mpos1-1)*mp + j), k)= . tmparray(i,j,k) end do end do end do end do #endif else ! mype.ne.0 #if (PARALLEL>0) 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 == 2) call MPI_Send(tmparray, nmlp, DC_TYPE, 0, 99, . MPI_COMM_WORLD, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in writeitk' stop end if #endif cccccccccccccccccccccccc c endif (PARALLEL > 0) cccccccccccccccccccccccc #endif endif if(mype.eq.0) then DO 5 I=1,10000 WORK(I)=0. 5 CONTINUE DO 10 M1=1,MZ DO 12 K1=K0,KN DO 14 L1=L0,LN WORK(L1)=FLD(L1,K1,M1) 14 CONTINUE DO 12 L1=L0+1,LN-1 FLD(L1,K1,M1)=PP(L1,LN,WORK) 12 CONTINUE if(j3.eq.1) then DO 22 L1=L0,LN DO 24 K1=K0,KN WORK(K1)=FLD(L1,K1,M1) 24 CONTINUE DO 22 K1=K0+1,KN-1 FLD(L1,K1,M1)=PP(K1,KN,WORK) 22 CONTINUE endif 10 CONTINUE endif ! mype=0 did job call mybarrier() CCCCCCCCCC NOW SEND DATA BACK TO PROCESSORS CCCCCCCC if(mype.eq.0) then #if (PARALLEL > 0) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, sending them their data ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 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) = . FLD(((npos1-1)*np + i), ((mpos1-1)*mp + j), k) end do end do end do #if (PARALLEL == 2) call MPI_Send(tmparray, nmlp, DC_TYPE, iproc, 98, . MPI_COMM_WORLD, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in FILT' stop end if #endif end do #endif do k=1,l do j=1,mp do i=1,np datarr(i,j,k)=FLD(i,j,k) end do end do end do else ! mype > 0 #if (PARALLEL > 0) #if (PARALLEL == 2) call MPI_Recv(tmparray, nmlp, DC_TYPE, 0, 98, . MPI_COMM_WORLD, status, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in FILT' stop end if #endif #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 endif RETURN END #endif FUNCTION PP(I,IDIM,FLD) DIMENSION FLD(IDIM),E0(8) DATA E0/0.5,0.375,0.3125,0.2734375,0.24609375, * 0.2255859375,0.20947265625,0.196380615234375/ N=MIN0(I-1,8,IDIM-I) E=E0(N) PP=(1.0-E)*FLD(I) DO 2000 IR=1,N E=-E*FLOAT(N-IR+1)/FLOAT(N+IR) 2000 PP=PP-E*(FLD(I+IR)+FLD(I-IR)) RETURN END subroutine sounding(p,t,q) parameter(KK=121) dimension p(KK),t(KK),q(KK),z(KK),td(KK),theta(KK),rh(KK) key=1 a=0. thetas=300. thetat=343. tt=213. QV0=14. zt=12000. ps=98000. p(1)=ps*1.e-2 g=9.81 cp=1004. rd=287. do 100 k=1,KK z(k)=float(k-1)*300. if(z(k).le.zt) then theta(k)=thetas+(thetat-thetas)*(z(k)/zt)**(5./4.) rh(k)=.95-.75*(z(k)/zt)**(5./4.) rh(k)=1.-.75*(z(k)/zt)**(5./4.) else theta(k)=thetat*exp(g*(z(k)-zt)/cp/tt) rh(k)=.2 rh(k)=.25 endif 100 continue do 200 k=2,KK p(k)=(p(k-1)**(rd/cp)-g*1000.**(rd/cp)/cp/((theta(k)+theta(k-1)) & /2.)*(z(k)-z(k-1)))**(cp/rd) 200 continue do 250 k=1,KK t(k)=theta(k)*(p(k)/1000.)**(rd/cp)-273.16 250 continue do 300 k=1,KK if(key.eq.1) then qs=6.11/p(k)*EXP(2.5E10/4.615E6*t(k)/((t(k)+273.16)*273.16)) q(k)=qs*287./461.5*1000.*rh(k) endif if(key.eq.2) then qs=6.11/p(k)*EXP(17.27*t(k)/(t(k)+273.16-35.86)) q(k)=qs*287./461.5*1000.*rh(k) endif if(key.eq.3) then ap=p(k) at=t(k)+273.16 call qstar(ap,at,qs) q(k)=qs*1000.*rh(k) endif q(k)=amin1(qv0,q(k)) 300 continue do 400 k=1,KK xx=alog(q(k)/1000.*p(k)/6.11*461.5/287.) xx=xx*4.615E6*273.16/2.5E10 td(k)=273.16*xx/(1.-xx) 400 continue return end subroutine qstar (p,ta,qs) C COMPUTE SATURATION MIXING RATIO (G/G) PS = 1013.246 TS = 373.16 F5 = ALOG10(PS) 10 E1 = 11.344*(1.0 - TA/TS) E2 = -3.49149*(TS/TA - 1.0) F1 = -7.90298*(TS/TA - 1.0) F2 = 5.02808*ALOG10(TS/TA) F3 = -1.3816*(10.0**E1 -1.0)/10000000.0 F4 = 8.1328*(10.0**E2 - 1.0)/1000.0 F = F1 + F2 + F3 + F4 + F5 ES = 10.0**F QS=0.622*ES/(P-ES) return end #if(PARALLEL > 0) subroutine transpose_x_z ( from, to, wp1, wp2 ) c implicit none include 'trparam.h' integer from, to real wp1(p1_mx,p1_my,p1_mz) real wp2(p2_mx,p2_my,p2_mz) * Select communication mode: COLLECT call transpose_x_z_gata ( from, to, wp1, wp2 ) return end subroutine transpose_x_z_gata ( from, to, wp1, wp2 ) * Data transposition: Global all-to-all c implicit none #include "msg.lnk" include 'trparam.h' integer from, to real wp1(p1_mx,p1_my,p1_mz) real wp2(p2_mx,p2_my,p2_mz) integer i, j, k integer sender, receiver, px * real temp1, temp21 * pointer (patemp1, temp1(p1_mx,p1_my,p2_mz,0:npx-1)), * $ (patemp21, temp21(p1_mx,p2_my,p2_mz,0:npx-1)) real :: temp1(p1_mx,p1_my,p2_mz,0:npx-1) real :: temp21(p1_mx,p2_my,p2_mz,0:npx-1) * call stkmemw ( p1_mx*p1_my*p2_mz*npx, patemp1 ) * call stkmemw ( p1_mx*p2_my*p2_mz*npx, patemp21 ) * Collective communications: all-to-all gather/scatter if ( from .eq. 1 .and. to .eq. 2 ) then do px = 0, npx-1 receiver = px + mypy*npx do k = 1, rp2_nk(receiver) do j = 1, p1_nj do i = 1, p1_ni temp1(i,j,k,px) = wp1(i,j,k+rp2_kstart(receiver)-1) enddo enddo enddo enddo * Assume: p1_my = p2_my call MPI_alltoall ( temp1, p2_mz*p1_my*p1_mx, dc_type, > temp21, p2_mz*p2_my*p1_mx, dc_type, > commslice_x, ierr ) do px = 0, npx-1 sender = px + mypy*npx do k = 1, p2_nk do j = 1, p2_nj do i = 1, rp1_ni(sender) wp2(i+rp1_istart(sender)-1,j,k) = temp21(i,j,k,px) enddo enddo enddo enddo endif if ( from .eq. 2 .and. to .eq. 1 ) then do px = 0, npx-1 receiver = px + mypy*npx do k = 1, p2_nk do j = 1, p2_nj do i = 1, rp1_ni(receiver) temp21(i,j,k,px) = wp2(i+rp1_istart(receiver)-1,j,k) enddo enddo enddo enddo * Assume: p1_my = p2_my call MPI_alltoall ( temp21, p2_mz*p2_my*p1_mx, dc_type, > temp1, p2_mz*p1_my*p1_mx, dc_type, > commslice_x, ierr ) do px = 0, npx-1 sender = px + mypy*npx do k = 1, rp2_nk(sender) do j = 1, p2_nj do i = 1, p1_ni wp1(i,j,k+rp2_kstart(sender)-1) = temp1(i,j,k,px) enddo enddo enddo enddo endif return end subroutine transpose_x_y ( from, to, wp2, wp3 ) implicit none include 'trparam.h' integer from, to real wp2(p2_mx,p2_my,p2_mz) real wp3(p3_mx,p3_my,p3_mz) call transpose_x_y_gata ( from, to, wp2, wp3 ) return end subroutine transpose_x_y_gata ( from, to, wp2, wp3 ) * Data transposition: Global all-to-all implicit none #include "msg.lnk" include 'trparam.h' integer from, to real wp2(p2_mx,p2_my,p2_mz) real wp3(p3_mx,p3_my,p3_mz) integer i, j, k integer sender, receiver, py * real temp23, temp3 * pointer (patemp23, temp23(p3_mx,p2_my,p2_mz,0:npy-1)), * $ (patemp3, temp3(p3_mx,p2_my,p2_mz,0:npy-1)) real :: temp23(p3_mx,p2_my,p2_mz,0:npy-1) real :: temp3(p3_mx,p2_my,p2_mz,0:npy-1) * call stkmemw ( p3_mx*p2_my*p2_mz*npy, patemp23 ) * call stkmemw ( p3_mx*p2_my*p2_mz*npy, patemp3 ) * Collective communications: all-to-all gather/scatter if ( from .eq. 2 .and. to .eq. 3 ) then do py = 0, npy-1 receiver = mypx + py*npx do k = 1, p2_nk do j = 1, p2_nj do i = 1, rp3_ni(receiver) temp23(i,j,k,py) = wp2(i+rp3_istart(receiver)-1,j,k) enddo enddo enddo enddo * Assume: p2_mz = p3_mz call MPI_alltoall ( temp23, p2_mz*p2_my*p3_mx, dc_type, > temp3, p2_mz*p2_my*p3_mx, dc_type, > commslice_y, ierr) do py = 0, npy-1 sender = mypx + py*npx do k = 1, p3_nk do j = 1, rp2_nj(sender) do i = 1, p3_ni wp3(i,j+rp2_jstart(sender)-1,k) = temp3(i,j,k,py) enddo enddo enddo enddo endif if ( from .eq. 3 .and. to .eq. 2 ) then do py = 0, npy-1 receiver = mypx + py*npx do k = 1, p3_nk do j = 1, rp2_nj(receiver) do i = 1, p3_ni temp3(i,j,k,py) = wp3(i,j+rp2_jstart(receiver)-1,k) enddo enddo enddo enddo * Assume: p2_mz = p3_mz call MPI_alltoall ( temp3, p2_mz*p2_my*p3_mx, dc_type, > temp23, p2_mz*p2_my*p3_mx, dc_type, > commslice_y, ierr) do py = 0, npy-1 sender = mypx + py*npx do k = 1, p2_nk do j = 1, p2_nj do i = 1, rp3_ni(sender) wp2(i+rp3_istart(sender)-1,j,k) = temp23(i,j,k,py) enddo enddo enddo enddo endif return end subroutine topoinit * Initialize processor topology : c implicit none #include "msg.lnk" include 'trparam.h' include 'param.nml' include 'param.misc' include 'msg.inc' integer itmp2(27), itmp3(27,0:mxp), i integer ptotal integer p1_irest, p1_jrest integer p2_irest, p2_krest integer p3_irest me=mype npx = nprocx npy = nprocy nproc=npx*npy C dc_type = MPI_DOUBLE_PRECISION c dc_type = MPI_REAL comm_type = COLLECT call MPI_Comm_size ( MPI_COMM_WORLD, ptotal, ierr ) if (ptotal .ne. nproc ) then print *, 'wrong proc number' STOP 'PROC_NUMBER_WRONG' endif c call MPI_Comm_rank ( MPI_COMM_WORLD, me, ierr ) * Determine processor coordinates of this processor * Processor grid is npx*npy. me = (mypx + mypy*npy ) * Processor coords are zero-based. mypx = npos-1 mypy = mpos-1 c mypx = mod( me, npx ) c mypy = me / npx * Communicators for rows/columns of processor grid. * commslice_x is communicator for procs with same mypx, ranked as mypy * commslice_y is communicator for procs with same mypy, ranked as mypx * mpi_comm_split(comm, color, key, ...) call MPI_Comm_split(MPI_COMM_WORLD, mypx, mypy, commslice_y, ierr) call MPI_Comm_split(MPI_COMM_WORLD, mypy, mypx, commslice_x, ierr) * south = mypy * npx + mod( mypx+1, npx ) * north = mypy * npx + mod( mypx+npx-1, npx ) * west = mypx + mod( mypy+npy-1, npy ) * npx * east = mypx + mod( mypy+1, npy ) * npx * write(6,10) me, nproc, mypx, mypy, north, south, east, west * 10 format(8I5) * Data layout used in transposition * * Phase 1: gni/npx x gnj/npy x gnk = p1_mx x p1_my x p1_mz * p1_ni = n / npx p1_mx = p1_ni + 1 * p1_mx = p1_ni p1_irest = n - p1_ni * npx p1_istart = mypx * p1_ni + 1 if ( mypx .lt. p1_irest ) then p1_ni = p1_ni + 1 p1_istart = p1_istart + mypx else p1_istart = p1_istart + p1_irest end if p1_istop = p1_istart + p1_ni - 1 p1_nj = m / npy p1_my = p1_nj + 1 * p1_my = p1_nj p1_jrest = m - p1_nj * npy p1_jstart = mypy * p1_nj + 1 if ( mypy .lt. p1_jrest ) then p1_nj = p1_nj + 1 p1_jstart = p1_jstart + mypy else p1_jstart = p1_jstart + p1_jrest end if p1_jstop = p1_jstart + p1_nj - 1 p1_nk = l p1_mz = p1_nk + 1 p1_kstart = 1 p1_kstop = l * Phase 2: (gni+2) x gnj/npy x gnk/npx = p2_mx x p2_my x p2_mz * p2_ni = n + 2 p2_ni = n p2_mx = p2_ni + 1 p2_istart = 1 * p2_istop = n + 2 p2_istop = n p2_nj = p1_nj p2_my = p1_my p2_jstart = p1_jstart p2_jstop = p2_jstart + p2_nj - 1 p2_nk = l / npx p2_mz = p2_nk + 1 * p2_mz = p2_nk p2_krest = l - p2_nk * npx p2_kstart = mypx * p2_nk + 1 if ( mypx .lt. p2_krest ) then p2_nk = p2_nk + 1 p2_kstart = p2_kstart + mypx else p2_kstart = p2_kstart + p2_krest end if p2_kstop = p2_kstart + p2_nk - 1 * Phase 3: (gni+2)/npy x gnj x gnk/npx = p3_mx x p3_my x p3_mz * p3_ni = (n+2) / npy * p3_irest = (n+2) - p3_ni * npy p3_ni = n / npy p3_mx = p3_ni + 1 p3_irest = n - p3_ni * npy p3_istart = mypy * p3_ni + 1 if ( mypy .lt. p3_irest ) then p3_ni = p3_ni + 1 p3_istart = p3_istart + mypy else p3_istart = p3_istart + p3_irest end if p3_istop = p3_istart + p3_ni - 1 p3_nj = m p3_my = p3_nj + 1 p3_jstart = 1 p3_jstop = m p3_nk = p2_nk p3_mz = p2_mz p3_kstart = p2_kstart p3_kstop = p3_kstart + p3_nk - 1 * Each processor needs to know the contents of the processors it * communicates with. We take a simple approach: each processor * obtains all the information contained in all others using * an MPI collective All-to-All gather. call MPI_barrier ( MPI_COMM_WORLD, ierr ) itmp2(1) = p1_istart itmp2(2) = p1_istop itmp2(3) = p1_ni itmp2(4) = p1_jstart itmp2(5) = p1_jstop itmp2(6) = p1_nj itmp2(7) = p1_kstart itmp2(8) = p1_kstop itmp2(9) = p1_nk itmp2(10) = p2_istart itmp2(11) = p2_istop itmp2(12) = p2_ni itmp2(13) = p2_jstart itmp2(14) = p2_jstop itmp2(15) = p2_nj itmp2(16) = p2_kstart itmp2(17) = p2_kstop itmp2(18) = p2_nk itmp2(19) = p3_istart itmp2(20) = p3_istop itmp2(21) = p3_ni itmp2(22) = p3_jstart itmp2(23) = p3_jstop itmp2(24) = p3_nj itmp2(25) = p3_kstart itmp2(26) = p3_kstop itmp2(27) = p3_nk call MPI_allgather ( itmp2, 27, MPI_INTEGER, itmp3, 27, $ MPI_INTEGER, MPI_COMM_WORLD, ierr ) do i = 0, nproc-1 rp1_istart(i) = itmp3(1,i) rp1_istop(i) = itmp3(2,i) rp1_ni(i) = itmp3(3,i) rp1_jstart(i) = itmp3(4,i) rp1_jstop(i) = itmp3(5,i) rp1_nj(i) = itmp3(6,i) rp1_kstart(i) = itmp3(7,i) rp1_kstop(i) = itmp3(8,i) rp1_nk(i) = itmp3(9,i) rp2_istart(i) = itmp3(10,i) rp2_istop(i) = itmp3(11,i) rp2_ni(i) = itmp3(12,i) rp2_jstart(i) = itmp3(13,i) rp2_jstop(i) = itmp3(14,i) rp2_nj(i) = itmp3(15,i) rp2_kstart(i) = itmp3(16,i) rp2_kstop(i) = itmp3(17,i) rp2_nk(i) = itmp3(18,i) rp3_istart(i) = itmp3(19,i) rp3_istop(i) = itmp3(20,i) rp3_ni(i) = itmp3(21,i) rp3_jstart(i) = itmp3(22,i) rp3_jstop(i) = itmp3(23,i) rp3_nj(i) = itmp3(24,i) rp3_kstart(i) = itmp3(25,i) rp3_kstop(i) = itmp3(26,i) rp3_nk(i) = itmp3(27,i) end do return end #endif C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine geomset() c c setup geometry information for each processor c include 'param.nml' include 'param.misc' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" #if (PARALLEL == 2) #if (HP == 2 || FUJI_VPP == 2 || SGI_O2K == 2 || IBM == 2 ) DC_TYPE = MPI_DOUBLE_PRECISION #else DC_TYPE = MPI_REAL #endif call MPI_Comm_size(MPI_COMM_WORLD, size, ierr) ! total numbers of PE's mysize = size call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) ! number of current PE mype = rank CCC CCC CCC CCC CCC CCC if(size.ne.nprocx*nprocy) then if(mype.eq.0) then PRINT *,'!!!!!! WRONG PROC NUMBER !!!!!!' print *,'!!!!!! NPE .ne. nprocx*nprocy !!!!!!' print *,'NPE = ',size,'nprocx*nprocy=',nprocx*nprocy print *,'!!!!!! EXIT !!!!!!' endif call MPI_Finalize(ierr) STOP 'GEOMSET' endif #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) mysize = NUM_PES() #else mysize = N$PES #endif mype = my_pe() #endif #endif #if (PARALLEL == 0) 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 #else #if (PARALLEL == 1) mype = my_pe() #endif #if (PARALLEL == 2) call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) mype = rank #endif c print *,'mype:',mype middle = 0 rightedge = 0 leftedge = 0 botedge = 0 topedge = 0 npos = mod((mype+nprocx), nprocx) + 1 mpos = mype/nprocx + 1 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) 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 print 99,mype,middle,rightedge,leftedge,botedge,topedge,npos,mpos, . peleft,peright,peabove,pebelow,perightabove, . perightbelow,peleftabove,peleftbelow 99 format(i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ', . i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3,' ',i3) #endif return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine testreal include 'param.nml' include 'param.misc' 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 compute some relevant constants constants for computational grid print *,'Start Test' do k=1,l do i=1,np do j=1,mp 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 i=1,np do j=1,mp 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 i=1,np do j=1,mp x(i,j,1)=(mype*10000+j*100+i)*1. enddo enddo #if (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else call mybarrier() #endif call update(u,np,mp,l,np,mp) call update2(u2,np,mp,l,np,mp) call updatelr(ulr,np,mp,l,np,mp) call updatebt(ubt,np,mp,l,np,mp) #if (SEMILAG == 1) call updatelagr(x,np,mp,l+2*ior,np,mp) #endif #if (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else call mybarrier() #endif iprintnow=0 77 continue #if (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else 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.misc' 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 compute some relevant constants constants for computational grid print *,'Start Test' do k=1,l0 do i=1,10 do j=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 i=1,10 do j=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 (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else call mybarrier() #endif call update(u,n0,n0,l0,n0,n0) call update2(u2,n0,n0,l0,n0,n0) call updatelr(ulr,n0,n0,l0,n0,n0) call updatebt(ubt,n0,n0,l0,n0,n0) #if (SEMILAG == 1) call updatelagr(x,n0,n0,l0,n0,n0) #endif #if (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else call mybarrier() #endif iprintnow=0 77 continue #if (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else 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 (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else 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 (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else 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 (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else 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+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine ioread0(u,v,o,w,th,p,fx,fy,fz,ft,fo,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 'param.misc' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . o(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) 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 fo(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 temp(n,m,l) c real*4 temp(n,m,l) common/blocktemp/tmparray(np,mp,l),tempval ifullarr=1 call readit0(u,temp,ifullarr,icomm) call mybarrier() call readit0(v,temp,ifullarr,icomm) call mybarrier() call readit0(o,temp,ifullarr,icomm) call mybarrier() call readit0(w,temp,ifullarr,icomm) call mybarrier() call readit0(th,temp,ifullarr,icomm) call mybarrier() call readit0(p,temp,ifullarr,icomm) call mybarrier() call readit0(fx,temp,ifullarr,icomm) call mybarrier() call readit0(fy,temp,ifullarr,icomm) call mybarrier() call readit0(fz,temp,ifullarr,icomm) call mybarrier() call readit0(ft,temp,ifullarr,icomm) call mybarrier() if (nts.eq.n) then call readit0(fo,temp,1,icomm) call mybarrier() else call readit0(fo,temp,0,icomm) call mybarrier() end if if (nms.eq.n) then call readit0(qv,temp,1,icomm) call mybarrier() call readit0(qc,temp,1,icomm) call mybarrier() call readit0(qr,temp,1,icomm) call mybarrier() call readit0(fqv,temp,1,icomm) call mybarrier() call readit0(fqc,temp,1,icomm) call mybarrier() call readit0(fqr,temp,1,icomm) call mybarrier() else call readit0(qv,temp,0,icomm) call mybarrier() call readit0(qc,temp,0,icomm) call mybarrier() call readit0(qr,temp,0,icomm) call mybarrier() call readit0(fqv,temp,0,icomm) call mybarrier() call readit0(fqc,temp,0,icomm) call mybarrier() call readit0(fqr,temp,0,icomm) call mybarrier() end if if (nicp.eq.n) then call readit0(qia,temp,1,icomm) call mybarrier() call readit0(qib,temp,1,icomm) call mybarrier() call readit0(fqia,temp,1,icomm) call mybarrier() call readit0(fqib,temp,1,icomm) call mybarrier() else call readit0(qia,temp,0,icomm) call mybarrier() call readit0(qib,temp,0,icomm) call mybarrier() call readit0(fqia,temp,0,icomm) call mybarrier() call readit0(fqib,temp,0,icomm) call mybarrier() end if if (nkv.eq.n) then call readit0(tke,temp,1,icomm) call mybarrier() else call readit0(tke,temp,0,icomm) call mybarrier() end if if (nke.eq.n) then call readit0(ftke,temp,1,icomm) call mybarrier() else call readit0(ftke,temp,0,icomm) call mybarrier() end if return end subroutine ioreadk(u,v,o,w,th,p,fx,fy,fz,ft,fo,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 'param.misc' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . o(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) 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 fo(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) common/blocktemp/tmparray(np,mp,l),tempval ifullarr=1 call readitk(u,ifullarr,icomm) call mybarrier() call readitk(v,ifullarr,icomm) call mybarrier() call readitk(o,ifullarr,icomm) call mybarrier() call readitk(w,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(fo,1,icomm) call mybarrier() else call readitk(fo,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 return end subroutine iowrite0(u,v,o,w,th,p,fx,fy,fz,ft,fo,qv,qc,qr,fqv, . fqc,fqr,qia,qib,fqia,fqib,tke,ftke,hise,epp1) c c This subroutine writes the data to the history file. c include 'param.nml' include 'param.misc' 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), . o(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) 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 fo(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) parameter (nthv=(nth-1)*ivs0+1,nthv2=2*nthv) real hise(nthv,2) c real*4 temp(n,m,l) dimension temp(n,m,l) common/blocktemp/tmparray(np,mp,l),tempval tempval=time ifullarr=1 call writeit0(u,temp,ifullarr) call mybarrier() call writeit0(v,temp,ifullarr) call mybarrier() call writeit0(o,temp,ifullarr) call mybarrier() call writeit0(w,temp,ifullarr) call mybarrier() call writeit0(th,temp,ifullarr) call mybarrier() call writeit0(p,temp,ifullarr) call mybarrier() call writeit0(fx,temp,ifullarr) call mybarrier() call writeit0(fy,temp,ifullarr) call mybarrier() call writeit0(fz,temp,ifullarr) call mybarrier() call writeit0(ft,temp,ifullarr) call mybarrier() if (nts.eq.n) then call writeit0(fo,temp,1) call mybarrier() else call writeit0(fo,temp,0) call mybarrier() end if if (nms.eq.n) then call writeit0(qv,temp,1) call mybarrier() call writeit0(qc,temp,1) call mybarrier() call writeit0(qr,temp,1) call mybarrier() call writeit0(fqv,temp,1) call mybarrier() call writeit0(fqc,temp,1) call mybarrier() call writeit0(fqr,temp,1) call mybarrier() else call writeit0(qv,temp,0) call mybarrier() call writeit0(qc,temp,0) call mybarrier() call writeit0(qr,temp,0) call mybarrier() call writeit0(fqv,temp,0) call mybarrier() call writeit0(fqc,temp,0) call mybarrier() call writeit0(fqr,temp,0) call mybarrier() end if if (nicp.eq.n) then call writeit0(qia,temp,1) call mybarrier() call writeit0(qib,temp,1) call mybarrier() call writeit0(fqia,temp,1) call mybarrier() call writeit0(fqib,temp,1) call mybarrier() else call writeit0(qia,temp,0) call mybarrier() call writeit0(qib,temp,0) call mybarrier() call writeit0(fqia,temp,0) call mybarrier() call writeit0(fqib,temp,0) call mybarrier() end if if (nkv.eq.n) then call writeit0(tke,temp,1) call mybarrier() else call writeit0(tke,temp,0) call mybarrier() end if if (nke.eq.n) then call writeit0(ftke,temp,1) call mybarrier() else call writeit0(ftke,temp,0) call mybarrier() end if return end subroutine iowritek(u,v,o,w,th,p,fx,fy,fz,ft,fo,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 'param.misc' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . o(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) 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 fo(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) common/blocktemp/tmparray(np,mp,l),tempval ifullarr=1 call writeitk(u,ifullarr) call mybarrier() call writeitk(v,ifullarr) call mybarrier() call writeitk(o,ifullarr) call mybarrier() call writeitk(w,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(fo,1) call mybarrier() else call writeitk(fo,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 return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine readit0(datarr,temp,ifullarr,icomm) c c This subroutine reads the data from the history file. c include 'param.nml' include 'param.misc' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif #if (HP > 0 || SGI_O2K > 1) integer CRAYREAD #endif common /hpcray/ ifcw,ifcr,ioptw,ioptr c real*4 temp(n,m,l) dimension temp(n,m,l) dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) common/blocktemp/tmparray(np,mp,l),tempval nml=n*m*l if (ifullarr.eq.1) then cccccccccccccccccccccccccccccccccccccc c read full array from tape file cccccccccccccccccccccccccccccccccccccc #if (HP > 0 || IBM > 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 machines read(10)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 : NCARU liblaries not available c read data from SGI Origin 2000 machine read(10)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(10)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 (CRAYPVP == 1) read(10)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,n*m*l,temp,0,temp,1) if(ierr.lt.0) . print *,'IEG2CRAY error:',ierr,' no translation performed' endif #endif #if (CRAYT3D == 1 || CRAYT3E == 1) read(10)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 n*m*l=',nml print *,'CRAY2CRI( 2, n*m*l, 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) read(10)temp #endif if (icomm.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 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 nmlp=np*mp*l #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_WORLD, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif end do #if (PARALLEL == 1) #if (PVM_IO == 0) call mybarrier() #endif #endif ccccccccccccccccccccccccccccc c endif (PARALLEL > 0) ccccccccccccccccccccccccccccc #endif end if !icomm = 1 ccccccccccccccccccccccccccccccc c end of read full array ccccccccccccccccccccccccccccccc else !ifullarr = 0 cccccccccccccccccccccccccccccccccccccccc c degenerate array; read one value cccccccccccccccccccccccccccccccccccccccc #if (HP > 0) if(ioptr.eq.0) then c read data from HP/Convex machines read(10)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(10)fval endif #endif #if (SGI_O2K == 2) if(ioptr.eq.0) then c read data from HP/Convex/SGI Origin machines read(10)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(10)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(10)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) read(10)fval #endif if (icomm.eq.1) then cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c transfer processor 0 data from tape value to local value cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc tempval=fval !tempval is available in common block for other pe's #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() #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_WORLD,ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readit0' stop end if #endif close #endif (PARALLEL > 0) #endif end if !icomm = 1 ccccccccccccccccccccccccccccc c end of read one value ccccccccccccccccccccccccccccc end if !ifullarr return end subroutine readitk(datarr,ifullarr,icomm) c c This subroutine reads the data from the history file. c #include "msg.lnk" #include "msg.lnp" include 'param.nml' include 'param.misc' include 'msg.inc' dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) common/blocktemp/tmparray(np,mp,l),tempval #if (PARALLEL > 0) if (ifullarr.eq.1) then if (icomm.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_WORLD, 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 end if !icomm = 1 else !ifullarr = 0 if (icomm.eq.1) then 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_WORLD,ierr) if (ierr.lt.0) then write(*,*)'***mpi error in readitk' stop end if #endif endif !icomm = 1 end if !ifullarr #endif return end subroutine writeit0(datarr,temp,ifullarr) c c This subroutine writes the data to the history file. c #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif include 'param.nml' include 'param.misc' include 'msg.inc' #if (HP > 0 || SGI_O2K > 1) integer CRAYWRITE #endif common /hpcray/ ifcw,ifcr,ioptw,ioptr c real*4 temp(n,m,l) dimension temp(n,m,l) dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) common/blocktemp/tmparray(np,mp,l),tempval nml=n*m*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) cccccccccccccccccccccccccccccccccccccc c get data from other processors cccccccccccccccccccccccccccccccccccccc nmlp=np*mp*l #if (PARALLEL == 1) #if (PVM_IO == 0) call mybarrier() #endif #endif cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c loop over all other processors, getting their data and transferring it cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 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_WORLD, 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 cccccccccccccccccccccccc c endif (PARALLEL > 0) cccccccccccccccccccccccc #endif ccccccccccccccccccccccccccccccccccc c write data to the tape file ccccccccccccccccccccccccccccccccccc #if (HP > 0 || IBM > 0) if(ioptw.eq.0) then write(9)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(9)temp #endif #if(SGI_O2K == 2) if(ioptw.eq.0) then write(9)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, n*m*l, temp, 0, temp, 1) if(ierr.lt.0) . print *,'CRAY2IEG error:',ierr,' no translation performed' endif write(9)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 n*m*l=',nml print *,'CRI2CRAY( 2, n*m*l, 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(9)temp #endif #if (WORKS > 0) write(9)temp #endif else !ifullarr = 0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccc c degenerate array; write out one value from PE = 0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccc c fval=1.0 fval=tempval cccccccccccccccccc c write data cccccccccccccccccc #if (HP > 0) if(ioptw.eq.0) then write(9)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(9)fval #endif #if(SGI_O2K == 2) if(ioptw.eq.0) then write(9)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(9)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 n*m*l=',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(9)fval #endif #if (WORKS > 0) write(9)fval #endif end if return end subroutine writeitk(datarr,ifullarr) c c This subroutine writes the data to the history file. c include 'param.nml' include 'param.misc' include 'msg.inc' #include "msg.lnk" #include "msg.lnp" dimension datarr(1-ih:np+ih,1-ih:mp+ih,l) common/blocktemp/tmparray(np,mp,l),tempval #if (PARALLEL > 0) 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_WORLD, ierr) if (ierr.lt.0) then write(*,*)'***mpi error in writeitk' stop end if #endif end if #endif return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine mybarrier() c c my barrier (machine specific) c ccccccccccccccccccc #if (PARALLEL == 2) #if (HP > 0) include '/opt/mpi/include/mpif.h' #endif #if (CRAYT3D == 1) c include '/opt/ctl/mpt/mpt/include/mpif.h' include '/usr/local/MPI/t3d/include/mpif.h' #endif #if (CRAYT3E == 1) include '/opt/ctl/mpt/mpt/include/mpif.h' #endif #if (SGI_O2K > 0) include 'mpif.h' #endif #if (CRAYPVP == 1) include '/opt/ctl/mpt/mpt/include/mpif.h' #endif CMPITEST integer rank,size CMPITEST call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) CMPITEST call MPI_Comm_size(MPI_COMM_WORLD, size, ierr) 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_WORLD, ierr) #endif CMPITEST print *,'After Barier',rank #endif ccccccccccccccccccc ccccccccccccccccccc #if (PARALLEL == 1) #if (SGI_O2K > 0) include '/usr/include/mpp/shmem.fh' #else include 'mpp/shmem.fh' #endif 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 ccccccccccccccccccc return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ function globsum(array,ilow,iupp,jlow,jupp,klow,kupp, . i1,i2,j1,j2,k1,k2) c c calculate sums on the MPP computers c include 'param.nml' include 'param.misc' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" common /csum/parsum,tsum,pwrk,work integer bit,neighbor,prevbits integer xor,and,or integer shiftr,shiftl,rval integer level,nodes save level,nodes data ifirst/1/ dimension array(ilow:iupp,jlow:jupp,klow:kupp) #else dimension array(-2:iupp,-2:jupp,klow:kupp) #endif real globsum C print *,'Globsum mype:',mype c compute local sums first parsum=0. do k=k1,k2 do j=j1,j2 do i=i1,i2 parsum=parsum+array(i,j,k) end do end do end do tsum=parsum #if (PARALLEL > 0) #if (PARALLEL == 2) call MPI_Comm_size(MPI_COMM_WORLD, size, ierr) nodes = size #if (HP == 2 || SGI_O2K == 2) ict=2 #else ict=1 #endif #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) nodes = NUM_PES() #else nodes = N$PES #endif #endif 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 #if (PARALLEL == 2) nodes = size #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) nodes = NUM_PES() #else nodes = N$PES #endif #endif 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 (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else call mybarrier() #endif neighbor = xor(mype,bit) #if (PARALLEL == 2) call MPI_Send(tsum,ict,DC_TYPE,neighbor,41, . MPI_COMM_WORLD, ierr) call MPI_Recv(work,ict,DC_TYPE,neighbor,41, . MPI_COMM_WORLD,status, ierr) #endif #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 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 (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else 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(tsum,ict,DC_TYPE,neighbor,41, . MPI_COMM_WORLD, ierr) #endif #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 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_TYPE,neighbor,41, . MPI_COMM_WORLD, status,ierr) #endif tsum=tsum+work end if end if prevbits = or(prevbits,bit) bit=shiftl(bit,1) end do #if (PARALLEL == 2) call MPI_Bcast(tsum,ict,DC_TYPE,0,MPI_COMM_WORLD, 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(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 end if 99 continue #endif globsum=tsum C print *,'pe :',mype,' globsum =',globsum c stop 'globsum' return end 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 'param.misc' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" 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/ dimension array(ilow:iupp,jlow:jupp,klow:kupp) #else dimension array(-2:iupp,-2:jupp,klow:kupp) #endif real globmax C print *,'Insite Globmax',mype c compute local max first c flocmax=array(1,1,1) flocmax=-1.e10 do k=k1,k2 do j=j1,j2 do i=i1,i2 flocmax=max(flocmax,array(i,j,k)) end do end do end do fglobmax=flocmax #if (PARALLEL > 0) #if (PARALLEL == 2) call MPI_Comm_size(MPI_COMM_WORLD, size, ierr) nodes = size #if (HP == 2 || SGI_O2K == 2) ict=2 #else ict=1 #endif #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) nodes = NUM_PES() #else nodes = N$PES #endif #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 #if (PARALLEL == 2) nodes = size #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) nodes = NUM_PES() #else nodes = N$PES #endif #endif 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 (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else call mybarrier() #endif neighbor = xor(mype,bit) #if (PARALLEL == 2) call MPI_Send(fglobmax,ict,DC_TYPE,neighbor,43, . MPI_COMM_WORLD, ierr) call MPI_Recv(work,ict,DC_TYPE,neighbor,43, . MPI_COMM_WORLD,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 = max(fglobmax,work) bit=shiftl(bit,1) end do else c c reduction for non-power of 2 processors c do i=1,level #if (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else 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_WORLD, 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_WORLD,status, ierr) #endif fglobmax=max(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_WORLD, 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 C print *,'pe :',mype,' globmax =',globmax 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 'param.misc' include 'msg.inc' #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" 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/ dimension array(ilow:iupp,jlow:jupp,klow:kupp) #else dimension array(-2:iupp,-2:jupp,klow:kupp) #endif real globmin C print *,'Insite Globmin',mype c compute local min first c flocmin=array(1,1,1) flocmin=1.e10 do k=k1,k2 do j=j1,j2 do i=i1,i2 flocmin=min(flocmin,array(i,j,k)) end do end do end do fglobmin=flocmin #if (PARALLEL > 0) #if (PARALLEL == 2) call MPI_Comm_size(MPI_COMM_WORLD, size, ierr) nodes = size #if (HP == 2 || SGI_O2K == 2) ict=2 #else ict=1 #endif #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) nodes = NUM_PES() #else nodes = N$PES #endif #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 #if (PARALLEL == 2) nodes = size #endif #if (PARALLEL == 1) #if (SGI_O2K > 0) nodes = NUM_PES() #else nodes = N$PES #endif #endif 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 (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else call mybarrier() #endif neighbor = xor(mype,bit) #if (PARALLEL == 2) call MPI_Send(fglobmin,ict,DC_TYPE,neighbor,45, . MPI_COMM_WORLD, ierr) call MPI_Recv(work,ict,DC_TYPE,neighbor,45, . MPI_COMM_WORLD,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 = min(fglobmin,work) bit=shiftl(bit,1) end do else c c reduction for non-power of 2 processors c do i=1,level #if (SGI_O2K > 0) #if (PARALLEL == 1) call mybarrier() #endif #else 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_WORLD, 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_WORLD,status, ierr) #endif fglobmin=min(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_WORLD,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 C print *,'pe :',mype,' fglobmin =',fglobmin return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine update(a,n1,m1,l1,ndim,mdim) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif include 'param.nml' include 'param.misc' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) 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 c if number of processors is 1 then return - nothing to update C print *,'UPDATE',mype #if (PARALLEL == 1) call shmem_set_cache_inv() #endif 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 print *,'UPDATE',mype nhl=n1*ih*l1 mhl=ih*m1*l1 ihl=ih*ih*l1 #if (HP == 2 || SGI_O2K == 2) nhl=nhl*2 mhl=mhl*2 ihl=ihl*2 #endif c c prepare bottom segments for processor below:tmpxsnd1 c prepare top segments for processor above :tmpxsnd2 c icnt=1 do i=1,n1 do j=1,ih do k=1,l1 #if (PARALLEL == 0) tmpxrcv1=a(i,j,k) tmpxrcv2=a(i,m1-ih+j,k) a(i,m1+j,k)=tmpxrcv1 a(i,-ih+j,k)=tmpxrcv2 c a(i,m1+j,k)=a(i,j,k) c a(i,-ih+j,k)=a(i,m1-ih+j,k) #else tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ih+j,k) icnt=icnt+1 #endif end do end do end do c c prepare left data segments for processor on the right:tmpysnd1 c prepare right data segments for processor on the left:tmpysnd2 c icnt=1 do i=1,ih do j=1,m1 do k=1,l1 #if (PARALLEL == 0) tmpyrcv1=a(i,j,k) tmpyrcv2=a(n1-ih+i,j,k) a(n1+i,j,k)=tmpyrcv1 a(-ih+i,j,k)=tmpyrcv2 c a(n1+i,j,k)=a(i,j,k) c a(-ih+i,j,k)=a(n1-ih+i,j,k) #else tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ih+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,(n1*ih*l1), peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,(n1*ih*l1), pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,(m1*ih*l1), peright) call shmem_get32(tmpyrcv2,tmpysnd2,(m1*ih*l1), peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,(n1*ih*l1), peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,(n1*ih*l1), pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,(m1*ih*l1), peright) call shmem_get64(tmpyrcv2,tmpysnd2,(m1*ih*l1), peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,(n1*ih*l1), peabove) call shmem_get(tmpxrcv2,tmpxsnd2,(n1*ih*l1), pebelow) call shmem_get(tmpyrcv1,tmpysnd1,(m1*ih*l1), peright) call shmem_get(tmpyrcv2,tmpysnd2,(m1*ih*l1), peleft) #endif ccc call mybarrier() #endif #if (PARALLEL == 2) #if (SGI_O2K > 0) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,1,MPI_COMM_WORLD, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_WORLD, . 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_WORLD, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_WORLD, . 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_WORLD, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_WORLD, . 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_WORLD, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_WORLD, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #else call mybarrier() call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,1, . tmpxrcv1,nhl,DC_TYPE,peabove,1,MPI_COMM_WORLD, . status,ierr) c print *,'MPI_Sendrecv 1',mype call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,2, . tmpxrcv2,nhl,DC_TYPE,pebelow,2,MPI_COMM_WORLD, . status,ierr) c print *,'MPI_Sendrecv 2',mype call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,3, . tmpyrcv1,mhl,DC_TYPE,peright,3,MPI_COMM_WORLD, . status,ierr) c print *,'MPI_Sendrecv 3',mype call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,4, . tmpyrcv2,mhl,DC_TYPE,peleft,4,MPI_COMM_WORLD, . status,ierr) #endif #endif c print *,'PARALLEL done',mype c c store data in main array now c icnt=1 do i=1,n1 do j=1,ih do k=1,l1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i,-ih+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do icnt=1 do i=1,ih do j=1,m1 do k=1,l1 a(n1+i,j,k)=tmpyrcv1(icnt) a(-ih+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,ih do j=1,ih do k=1,l1 #if (PARALLEL == 0) tmpcorrcv1=a(n1-ih+i,m1-ih+j,k) tmpcorrcv2=a(n1-ih+i,j,k) tmpcorrcv3=a(i,j,k) tmpcorrcv4=a(i,m1-ih+j,k) a(i-ih,j-ih,k)=tmpcorrcv1 a(i-ih,m1+j,k)=tmpcorrcv2 a(n1+i,m1+j,k)=tmpcorrcv3 a(n1+i,j-ih,k)=tmpcorrcv4 c a(i-ih,j-ih,k)=a(n1-ih+i,m1-ih+j,k) c a(i-ih,m1+j,k)=a(n1-ih+i,j,k) c a(n1+i,m1+j,k)=a(i,j,k) c a(n1+i,j-ih,k)=a(i,m1-ih+j,k) #else tmpcorsnd1(icnt)=a(n1-ih+i,m1-ih+j,k) tmpcorsnd2(icnt)=a(n1-ih+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) tmpcorsnd4(icnt)=a(i,m1-ih+j,k) icnt=icnt+1 #endif end do end do end do c print *,'PARALLEL 2',mype #if (PARALLEL > 0) #if (PARALLEL == 1) call mybarrier() #if (SGI_O2K > 0) #if (SGI_O2K == 1) call shmem_get32(tmpcorrcv1,tmpcorsnd1,(ih*ih*l1), peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,(ih*ih*l1), peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,(ih*ih*l1), perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,(ih*ih*l1), perightbelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpcorrcv1,tmpcorsnd1,(ih*ih*l1), peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,(ih*ih*l1), peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,(ih*ih*l1), perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,(ih*ih*l1), perightbelow) #endif #else call shmem_get(tmpcorrcv1,tmpcorsnd1,(ih*ih*l1), peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,(ih*ih*l1), peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,(ih*ih*l1), perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,(ih*ih*l1), perightbelow) #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif #if (HP == 0) call MPI_Send(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . MPI_COMM_WORLD, ierr) call MPI_Recv(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_WORLD,status, ierr) call MPI_Send(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . MPI_COMM_WORLD, ierr) call MPI_Recv(tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_WORLD,status, ierr) call MPI_Send(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . MPI_COMM_WORLD, ierr) call MPI_Recv(tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_WORLD,status, ierr) call MPI_Send(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . MPI_COMM_WORLD, ierr) call MPI_Recv(tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_WORLD,status, ierr) #else call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,5, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,5, . MPI_COMM_WORLD,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,6, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,6, . MPI_COMM_WORLD,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,7, . tmpcorrcv3,ihl,DC_TYPE,perightabove,7, . MPI_COMM_WORLD,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,8, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,8, . MPI_COMM_WORLD,ierr) #endif #endif c print *,'PARALLEL 2 done',mype icnt=1 do i=1,ih do j=1,ih do k=1,l1 a(i-ih,j-ih,k)=tmpcorrcv1(icnt) a(i-ih,m1+j,k)=tmpcorrcv2(icnt) a(n1+i,m1+j,k)=tmpcorrcv3(icnt) a(n1+i,j-ih,k)=tmpcorrcv4(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif C print *,'OUT_UPDATE',mype return end subroutine update2(a,n1,m1,l1,ndim,mdim) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif include 'param.nml' include 'param.misc' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) 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 c if number of processors is 1 then return - nothing to update C print *,'UPDATE2',mype #if (PARALLEL == 1) call shmem_set_cache_inv() #endif 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 print *,'UPDATE2',mype nhl=n1*ih*l1 mhl=m1*ih*l1 #if (HP == 2 || SGI_O2K == 2) nhl=nhl*2 mhl=mhl*2 #endif c c prepare bottom segments for processor below: tmpxsnd1 c prepare top segments for processor above : tmpxsnd2 c icnt=1 do k=1,l1 do j=1,ih do i=1,n1 #if (PARALLEL == 0) tmpxrcv1=a(i,j,k) tmpxrcv2=a(i,m1-ih+j,k) a(i,m1+j,k)=tmpxrcv1 a(i,-ih+j,k)=tmpxrcv2 c a(i,m1+j,k)=a(i,j,k) c a(i,-ih+j,k)=a(i,m1-ih+j,k) #else tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ih+j,k) icnt=icnt+1 #endif end do end do end do 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,ih do j=1,m1 do k=1,l1 #if (PARALLEL == 0) tmpyrcv1=a(i,j,k) tmpyrcv2=a(n1-ih+i,j,k) a(n1+i,j,k)=tmpyrcv1 a(-ih+i,j,k)=tmpyrcv2 c a(n1+i,j,k)=a(i,j,k) c a(-ih+i,j,k)=a(n1-ih+i,j,k) #else tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ih+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,(ndim*ih*l1), peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,(ndim*ih*l1), pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,(mdim*ih*l1), peright) call shmem_get32(tmpyrcv2,tmpysnd2,(mdim*ih*l1), peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,(ndim*ih*l1), peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,(ndim*ih*l1), pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,(mdim*ih*l1), peright) call shmem_get64(tmpyrcv2,tmpysnd2,(mdim*ih*l1), peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,(ndim*ih*l1), peabove) call shmem_get(tmpxrcv2,tmpxsnd2,(ndim*ih*l1), pebelow) call shmem_get(tmpyrcv1,tmpysnd1,(mdim*ih*l1), peright) call shmem_get(tmpyrcv2,tmpysnd2,(mdim*ih*l1), peleft) #endif #endif #if (PARALLEL == 2) #if (SGI_O2K > 0) call MPI_ISEND(tmpxsnd1,nhl,DC_TYPE,pebelow,11,MPI_COMM_WORLD, . stats,ierr) call MPI_IRECV(tmpxrcv1,nhl,DC_TYPE,peabove,11,MPI_COMM_WORLD, . 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_WORLD, . stats,ierr) call MPI_IRECV(tmpxrcv2,nhl,DC_TYPE,pebelow,12,MPI_COMM_WORLD, . 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_WORLD, . stats,ierr) call MPI_IRECV(tmpyrcv1,mhl,DC_TYPE,peright,13,MPI_COMM_WORLD, . 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_WORLD, . stats,ierr) call MPI_IRECV(tmpyrcv2,mhl,DC_TYPE,peleft,14,MPI_COMM_WORLD, . statr,ierr) call MPI_WAIT(stats,status,ierr) call MPI_WAIT(statr,status,ierr) #else call mybarrier() call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,11, . tmpxrcv1,nhl,DC_TYPE,peabove,11,MPI_COMM_WORLD, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,12, . tmpxrcv2,nhl,DC_TYPE,pebelow,12,MPI_COMM_WORLD, . status,ierr) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,13, . tmpyrcv1,mhl,DC_TYPE,peright,13,MPI_COMM_WORLD, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,14, . tmpyrcv2,mhl,DC_TYPE,peleft,14,MPI_COMM_WORLD, . status,ierr) #endif #endif c c store data in main array now c icnt=1 do k=1,l1 do j=1,ih do i=1,n1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i,-ih+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do icnt=1 do i=1,ih do j=1,m1 do k=1,l1 a(n1+i,j,k)=tmpyrcv1(icnt) a(-ih+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif C print *,'OUT UPDATE2',mype return end #if (SEMILAG == 1) subroutine updatelagr(a,n1,m1,l1,ndim,mdim) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif include 'param.nml' include 'param.misc' 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) 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 c if number of processors is 1 then return - nothing to update C print *,'UPDATELGR',mype #if (PARALLEL == 1) call shmem_set_cache_inv() #endif 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 print *,'Inside UPDATELGR',mype 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)*ihlag*l1 mhl=(julim-jllim+1)*ihlag*l1 ihl=(ihlag*ihlag*l1) #if (HP == 2 || SGI_O2K == 2) nhl=nhl*2 mhl=mhl*2 ihl=ihl*2 #endif c c prepare bottom segments for processor below c prepare upper data segments for processor above c icnt=1 do i=illim,iulim do j=1,ihlag do k=1,l1 #if (PARALLEL == 0) tmpxrcv1=a(i,j,k) tmpxrcv2=a(i,m1-ihlag+j,k) a(i,m1+ior+j,k)=tmpxrcv1 a(i,-ior-ihlag+j,k)=tmpxrcv2 c a(i,m1+ior+j,k)=a(i,j,k) c a(i,-ior-ihlag+j,k)=a(i,m1-ihlag+j,k) #else tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ihlag+j,k) icnt=icnt+1 #endif end do end do end do c c prepare left data segments for processor on the left c prepare right data segments for processor to the right c icnt=1 do i=1,ihlag do j=jllim,julim do k=1,l1 #if (PARALLEL == 0) tmpyrcv1=a(i,j,k) tmpyrcv2=a(n1-ihlag+i,j,k) a(n1+i+ior,j,k)=tmpyrcv1 a(-ior-ihlag+i,j,k)=tmpyrcv2 c a(n1+i+ior,j,k)=a(i,j,k) c a(-ior-ihlag+i,j,k)=a(n1-ihlag+i,j,k) #else tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ihlag+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,((iulim-illim+1)*ihlag*l1), . peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,((iulim-illim+1)*ihlag*l1), . pebelow) call shmem_get32(tmpyrcv1,tmpysnd1,((julim-jllim+1)*ihlag*l1), . peright) call shmem_get32(tmpyrcv2,tmpysnd2,((julim-jllim+1)*ihlag*l1), . peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,((iulim-illim+1)*ihlag*l1), . peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,((iulim-illim+1)*ihlag*l1), . pebelow) call shmem_get64(tmpyrcv1,tmpysnd1,((julim-jllim+1)*ihlag*l1), . peright) call shmem_get64(tmpyrcv2,tmpysnd2,((julim-jllim+1)*ihlag*l1), . peleft) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,((iulim-illim+1)*ihlag*l1), . peabove) call shmem_get(tmpxrcv2,tmpxsnd2,((iulim-illim+1)*ihlag*l1), . pebelow) call shmem_get(tmpyrcv1,tmpysnd1,((julim-jllim+1)*ihlag*l1), . peright) call shmem_get(tmpyrcv2,tmpysnd2,((julim-jllim+1)*ihlag*l1), . peleft) #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,21, . tmpxrcv1,nhl,DC_TYPE,peabove,21,MPI_COMM_WORLD, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,22, . tmpxrcv2,nhl,DC_TYPE,pebelow,22,MPI_COMM_WORLD, . status,ierr) call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,23, . tmpyrcv1,mhl,DC_TYPE,peright,23,MPI_COMM_WORLD, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,24, . tmpyrcv2,mhl,DC_TYPE,peleft,24,MPI_COMM_WORLD, . status,ierr) #endif c c store data in main array now c icnt=1 if (topedge.eq.0) then do i=illim,iulim do j=1,ihlag 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,ihlag 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,ihlag do k=1,l1 a(i,-ihlag+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do else do i=illim,iulim do j=1,ihlag do k=1,l1 a(i,-ior-ihlag+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,ihlag 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,ihlag 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,ihlag do j=jllim,julim do k=1,l1 a(-ihlag+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do else do i=1,ihlag do j=jllim,julim do k=1,l1 a(-ior-ihlag+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,ihlag do j=1,ihlag do k=1,l1 #if (PARALLEL == 0) tmpcorrcv1=a(n1-ihlag+i,m1-ihlag+j,k) tmpcorrcv2=a(n1-ihlag+i,j,k) tmpcorrcv3=a(i,j,k) tmpcorrcv4=a(i,m1-ihlag+j,k) a(i-ihlag-ior,j-ihlag-ior,k)=tmpcorrcv1 a(i-ihlag-ior,m1+j+ior,k)=tmpcorrcv2 a(n1+i+ior,m1+j+ior,k)=tmpcorrcv3 a(n1+i+ior,j-ihlag-ior,k)=tmpcorrcv4 c a(i-ihlag-ior,j-ihlag-ior,k)=a(n1-ihlag+i,m1-ihlag+j,k) c a(i-ihlag-ior,m1+j+ior,k)=a(n1-ihlag+i,j,k) c a(n1+i+ior,m1+j+ior,k)=a(i,j,k) c a(n1+i+ior,j-ihlag-ior,k)=a(i,m1-ihlag+j,k) #else tmpcorsnd1(icnt)=a(n1-ihlag+i,m1-ihlag+j,k) tmpcorsnd2(icnt)=a(n1-ihlag+i,j,k) tmpcorsnd3(icnt)=a(i,j,k) tmpcorsnd4(icnt)=a(i,m1-ihlag+j,k) c if (i.eq.ihlag .and. j.eq.ihlag .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,(ihlag*ihlag*l1), . peleftbelow) call shmem_get32(tmpcorrcv2,tmpcorsnd2,(ihlag*ihlag*l1), . peleftabove) call shmem_get32(tmpcorrcv3,tmpcorsnd3,(ihlag*ihlag*l1), . perightabove) call shmem_get32(tmpcorrcv4,tmpcorsnd4,(ihlag*ihlag*l1), . perightbelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpcorrcv1,tmpcorsnd1,(ihlag*ihlag*l1), . peleftbelow) call shmem_get64(tmpcorrcv2,tmpcorsnd2,(ihlag*ihlag*l1), . peleftabove) call shmem_get64(tmpcorrcv3,tmpcorsnd3,(ihlag*ihlag*l1), . perightabove) call shmem_get64(tmpcorrcv4,tmpcorsnd4,(ihlag*ihlag*l1), . perightbelow) #endif #else call shmem_get(tmpcorrcv1,tmpcorsnd1,(ihlag*ihlag*l1), . peleftbelow) call shmem_get(tmpcorrcv2,tmpcorsnd2,(ihlag*ihlag*l1), . peleftabove) call shmem_get(tmpcorrcv3,tmpcorsnd3,(ihlag*ihlag*l1), . perightabove) call shmem_get(tmpcorrcv4,tmpcorsnd4,(ihlag*ihlag*l1), . perightbelow) #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif #if (HP == 0) call MPI_Send(tmpcorsnd1,ihl,DC_TYPE,perightabove,25, . MPI_COMM_WORLD, ierr) call MPI_Recv(tmpcorrcv1,ihl,DC_TYPE,peleftbelow,25, . MPI_COMM_WORLD,status, ierr) call MPI_Send(tmpcorsnd2,ihl,DC_TYPE,perightbelow,26, . MPI_COMM_WORLD, ierr) call MPI_Recv(tmpcorrcv2,ihl,DC_TYPE,peleftabove,26, . MPI_COMM_WORLD,status, ierr) call MPI_Send(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,27, . MPI_COMM_WORLD, ierr) call MPI_Recv(tmpcorrcv3,ihl,DC_TYPE,perightabove,27, . MPI_COMM_WORLD,status, ierr) call MPI_Send(tmpcorsnd4,ihl,DC_TYPE,peleftabove,28, . MPI_COMM_WORLD, ierr) call MPI_Recv(tmpcorrcv4,ihl,DC_TYPE,perightbelow,28, . MPI_COMM_WORLD,status, ierr) #else call MPI_Sendrecv(tmpcorsnd1,ihl,DC_TYPE,perightabove,25, . tmpcorrcv1,ihl,DC_TYPE,peleftbelow,25, . MPI_COMM_WORLD,ierr) call MPI_Sendrecv(tmpcorsnd2,ihl,DC_TYPE,perightbelow,26, . tmpcorrcv2,ihl,DC_TYPE,peleftabove,26, . MPI_COMM_WORLD,ierr) call MPI_Sendrecv(tmpcorsnd3,ihl,DC_TYPE,peleftbelow,27, . tmpcorrcv3,ihl,DC_TYPE,perightabove,27, . MPI_COMM_WORLD,ierr) call MPI_Sendrecv(tmpcorsnd4,ihl,DC_TYPE,peleftabove,28, . tmpcorrcv4,ihl,DC_TYPE,perightbelow,28, . MPI_COMM_WORLD,ierr) #endif #endif icnt=1 if (leftedge.eq.0 .and. botedge.eq.0) then do i=1,ihlag do j=1,ihlag do k=1,l1 a(i-ihlag,j-ihlag,k)=tmpcorrcv1(icnt) c if (i.eq.ihlag .and. j.eq.ihlag .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,ihlag do j=1,ihlag do k=1,l1 a(i-ihlag-ior,j-ihlag,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,ihlag do j=1,ihlag do k=1,l1 a(i-ihlag,j-ihlag-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,ihlag do j=1,ihlag do k=1,l1 a(i-ihlag-ior,j-ihlag-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,ihlag do j=1,ihlag do k=1,l1 a(i-ihlag,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,ihlag do j=1,ihlag do k=1,l1 a(i-ihlag-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,ihlag do j=1,ihlag do k=1,l1 a(i-ihlag,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,ihlag do j=1,ihlag do k=1,l1 a(i-ihlag-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,ihlag do j=1,ihlag 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,ihlag do j=1,ihlag 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,ihlag do j=1,ihlag 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,ihlag do j=1,ihlag 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,ihlag do j=1,ihlag do k=1,l1 a(n1+i,j-ihlag,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,ihlag do j=1,ihlag do k=1,l1 a(n1+i+ior,j-ihlag,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,ihlag do j=1,ihlag do k=1,l1 a(n1+i,j-ihlag-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,ihlag do j=1,ihlag do k=1,l1 a(n1+i+ior,j-ihlag-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 C print *,'OUT UPDATELAGR',mype return end #endif subroutine updatebt(a,n1,m1,l1,ndim,mdim) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif include 'param.nml' include 'param.misc' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) 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 c if number of processors is 1 then return - nothing to update C print *,'UPDATEBT',mype #if (PARALLEL == 1) call shmem_set_cache_inv() #endif 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 print *,'UPDATEBT',mype nhl=n1*ih*l1 #if (HP == 2 || SGI_O2K == 2) nhl=nhl*2 #endif c c prepare bottom segments for processor below :tmpxsnd1 c prepare upper data segments for processor above:tmpxsnd2 c icnt=1 do k=1,l1 do j=1,ih do i=1,n1 #if (PARALLEL == 0) tmpxrcv1=a(i,j,k) tmpxrcv2=a(i,m1-ih+j,k) a(i,m1+j,k)=tmpxrcv1 a(i,-ih+j,k)=tmpxrcv2 c a(i,m1+j,k)=a(i,j,k) c a(i,-ih+j,k)=a(i,m1-ih+j,k) #else tmpxsnd1(icnt)=a(i,j,k) tmpxsnd2(icnt)=a(i,m1-ih+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,(n1*ih*l1), peabove) call shmem_get32(tmpxrcv2,tmpxsnd2,(n1*ih*l1), pebelow) #endif #if (SGI_O2K == 2) call shmem_get64(tmpxrcv1,tmpxsnd1,(n1*ih*l1), peabove) call shmem_get64(tmpxrcv2,tmpxsnd2,(n1*ih*l1), pebelow) #endif #else call shmem_get(tmpxrcv1,tmpxsnd1,(n1*ih*l1), peabove) call shmem_get(tmpxrcv2,tmpxsnd2,(n1*ih*l1), pebelow) #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif call MPI_Sendrecv(tmpxsnd1,nhl,DC_TYPE,pebelow,31, . tmpxrcv1,nhl,DC_TYPE,peabove,31,MPI_COMM_WORLD, . status,ierr) call MPI_Sendrecv(tmpxsnd2,nhl,DC_TYPE,peabove,32, . tmpxrcv2,nhl,DC_TYPE,pebelow,32,MPI_COMM_WORLD, . status,ierr) #endif c c store data in main array now c icnt=1 do k=1,l1 do j=1,ih do i=1,n1 a(i,m1+j,k)=tmpxrcv1(icnt) a(i,-ih+j,k)=tmpxrcv2(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif C print *,'OUT UPDATEBT',mype return end subroutine updatelr(a,n1,m1,l1,ndim,mdim) c c this subroutine updates the halo (or ghost) cells surrounding c each processors subgrid c #if (PARALLEL > 0) #include "msg.lnk" #include "msg.lnp" #endif include 'param.nml' include 'param.misc' include 'param.ior' include 'msg.inc' dimension a(1-ih:ndim+ih, 1-ih:mdim+ih,l1) #if (PARALLEL > 0) 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 c if number of processors is 1 then return - nothing to update C print *,'UPDATELR',mype #if (PARALLEL == 1) call shmem_set_cache_inv() #endif 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 print *,'UPDATELR',mype mhl=ih*m1*l1 #if (HP == 2 || SGI_O2K == 2) mhl=mhl*2 #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 icnt=1 do i=1,ih do j=1,m1 do k=1,l1 #if (PARALLEL == 0) tmpyrcv1=a(i,j,k) tmpyrcv2=a(n1-ih+i,j,k) a(n1+i,j,k)=tmpyrcv1 a(-ih+i,j,k)=tmpyrcv2 c a(n1+i,j,k)=a(i,j,k) c a(-ih+i,j,k)=a(n1-ih+i,j,k) #else tmpysnd1(icnt)=a(i,j,k) tmpysnd2(icnt)=a(n1-ih+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,(m1*ih*l1), peright) call shmem_get32(tmpyrcv2,tmpysnd2,(m1*ih*l1), peleft) #endif #if (SGI_O2K == 2) call shmem_get64(tmpyrcv1,tmpysnd1,(m1*ih*l1), peright) call shmem_get64(tmpyrcv2,tmpysnd2,(m1*ih*l1), peleft) #endif #else call shmem_get(tmpyrcv1,tmpysnd1,(m1*ih*l1), peright) call shmem_get(tmpyrcv2,tmpysnd2,(m1*ih*l1), peleft) #endif #endif #if (PARALLEL == 2) #if (SGI_O2K == 0) call mybarrier() #endif call MPI_Sendrecv(tmpysnd1,mhl,DC_TYPE,peleft,33, . tmpyrcv1,mhl,DC_TYPE,peright,33,MPI_COMM_WORLD, . status,ierr) call MPI_Sendrecv(tmpysnd2,mhl,DC_TYPE,peright,34, . tmpyrcv2,mhl,DC_TYPE,peleft,34,MPI_COMM_WORLD, . status,ierr) #endif c c store data in main array now c icnt=1 do i=1,ih do j=1,m1 do k=1,l1 a(n1+i,j,k)=tmpyrcv1(icnt) a(-ih+i,j,k)=tmpyrcv2(icnt) icnt=icnt+1 end do end do end do #if (PARALLEL == 1) call shmem_clear_cache_inv() #endif #endif C print *,'OUT UPDATELR',mype return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine timefun() include 'param.nml' include 'param.misc' include 'msg.inc' #if (HP > 0) character*24 timedat #else #if (WORKS == 1) character*24 timedat INTEGER itime #else character*8 timedat #endif #endif if (mype.eq.0) then #if (HP > 0) call fdate(timedat) #else #if (WORKS == 1) c call fdate(timedat) c itime=Time8() c timedat=CTime(itime) #else call clock(timedat) #endif #endif c write(*,*)'*** date: ',timedat end if return end C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #if (WORKS == 1) function cvmgm(a,b,c) real a,b,c,cvmgm if (c.ge.0) then cvmgm = b else cvmgm = a endif return end #endif #if (HP > 0 || IBM > 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 function cvmgm(a,b,c) real a,b,c,cvmgm if (c.ge.0) then cvmgm = b else cvmgm = a endif return end #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 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 #endif #if (GKS == 1) subroutine ncargdef include 'param.nml' common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 create vertical frames c iautoxz,iautoyz,iautoxy - set automatically frames depend on c domain size (natural aspect ratio for domain size) data iautoxz/0/,iautoyz/0/,iautoxy/1/ 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---> 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,1.,.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,1./ common/rat/rat1,rat2,rat3 common /plot2/ zmin(22),zmax(22),izval(22),ihlg(3,22),ihcg(3,22) c zmin - minimum, zmax - maximum vlaues for colorscaling (if izval=1) c thise same values for xzplot, yzplot, xyplot 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 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 ---- XZPLOT --- YZPLOT --- XYPLO ---------- data ihlg(1,1) ,ihlg(2,1) ,ihlg(3,1) /0,0,0/ !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) /0,0,0/ !p*2.*dti data ihlg(1,4) ,ihlg(2,4) ,ihlg(3,4) /0,0,0/ !u data ihlg(1,5) ,ihlg(2,5) ,ihlg(3,5) /0,0,0/ !om data ihlg(1,6) ,ihlg(2,6) ,ihlg(3,6) /0,0,0/ !w data ihlg(1,7) ,ihlg(2,7) ,ihlg(3,7) /0,0,0/ data ihlg(1,8) ,ihlg(2,8) ,ihlg(3,8) /0,0,0/ data ihlg(1,9) ,ihlg(2,9) ,ihlg(3,9) /0,0,0/ !div*dt data ihlg(1,10),ihlg(2,10),ihlg(3,10)/0,0,0/ !qv [g/kg] data ihlg(1,11),ihlg(2,11),ihlg(3,11)/0,0,0/ !qc [g/kg] data ihlg(1,12),ihlg(2,12),ihlg(3,12)/0,0,0/ !qr,qia,qib [g/kg] data ihlg(1,13),ihlg(2,13),ihlg(3,13)/0,0,0/ !Rh data ihlg(1,14),ihlg(2,14),ihlg(3,14)/0,0,0/ !thetav data ihlg(1,15),ihlg(2,15),ihlg(3,15)/0,0,0/ !Km*dt/Dx**2 data ihlg(1,16),ihlg(2,16),ihlg(3,16)/0,0,0/ !Ri data ihlg(1,17),ihlg(2,17),ihlg(3,17)/0,0,0/ !v data ihlg(1,18),ihlg(2,18),ihlg(3,18)/0,0,0/ !vortx*dt data ihlg(1,19),ihlg(2,19),ihlg(3,19)/0,0,0/ !vorty*dt data ihlg(1,20),ihlg(2,20),ihlg(3,20)/0,0,0/ !vortz*dt data ihlg(1,21),ihlg(2,21),ihlg(3,21)/0,0,0/ !pv data ihlg(1,22),ihlg(2,22),ihlg(3,22)/0,0,0/ !isentropic surface 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 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,0/ !u data ihcg(1,5) ,ihcg(2,5) ,ihcg(3,5) /0,0,0/ !om data ihcg(1,6) ,ihcg(2,6) ,ihcg(3,6) /0,0,0/ !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,0/ !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 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) 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) 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 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) /14,15,0/ !th/the-1. data xzcol(1,2) ,xzcol(2,2) ,xzcol(3,2) /4,50,0/ !th data xzcol(1,3) ,xzcol(2,3) ,xzcol(3,3) /14,10,0/ !p*2.*dti data xzcol(1,4) ,xzcol(2,4) ,xzcol(3,4) /14,10,0/ !u data xzcol(1,5) ,xzcol(2,5) ,xzcol(3,5) /14,8,0/ !om data xzcol(1,6) ,xzcol(2,6) ,xzcol(3,6) /14,10,0/ !w data xzcol(1,7) ,xzcol(2,7) ,xzcol(3,7) /4,8,0/ data xzcol(1,8) ,xzcol(2,8) ,xzcol(3,8) /4,8,0/ data xzcol(1,9) ,xzcol(2,9) ,xzcol(3,9) /14,8,0/ !div*dt data xzcol(1,10),xzcol(2,10),xzcol(3,10)/4,30,0/ !qv [g/kg] data xzcol(1,11),xzcol(2,11),xzcol(3,11)/4,8,0/ !qc [g/kg] data xzcol(1,12),xzcol(2,12),xzcol(3,12)/4,8,0/ !qr,qia,qib [g/kg] data xzcol(1,13),xzcol(2,13),xzcol(3,13)/4,10,0/ !Rh data xzcol(1,14),xzcol(2,14),xzcol(3,14)/4,50,0/ !thetav data xzcol(1,15),xzcol(2,15),xzcol(3,15)/4,8,0/ !Km*dt/Dx**2 data xzcol(1,16),xzcol(2,16),xzcol(3,16)/14,10,0/ !Ri data xzcol(1,17),xzcol(2,17),xzcol(3,17)/14,10,0/ !v data xzcol(1,18),xzcol(2,18),xzcol(3,18)/14,8,0/ !vortx*dt data xzcol(1,19),xzcol(2,19),xzcol(3,19)/14,8,0/ !vorty*dt data xzcol(1,20),xzcol(2,20),xzcol(3,20)/14,8,0/ !vortz*dt data xzcol(1,21),xzcol(2,21),xzcol(3,21)/14,8,0/ !pv c COLORPAL ISOLINES LINE_LABELS data yzcol(1,1) ,yzcol(2,1) ,yzcol(3,1) /14,15,0/ !th/the-1. data yzcol(1,2) ,yzcol(2,2) ,yzcol(3,2) /4,50,0/ !th data yzcol(1,3) ,yzcol(2,3) ,yzcol(3,3) /14,10,0/ !p*2.*dti data yzcol(1,4) ,yzcol(2,4) ,yzcol(3,4) /14,8,0/ !u data yzcol(1,5) ,yzcol(2,5) ,yzcol(3,5) /14,8,0/ !om data yzcol(1,6) ,yzcol(2,6) ,yzcol(3,6) /14,8,0/ !w data yzcol(1,7) ,yzcol(2,7) ,yzcol(3,7) /4,8,0/ data yzcol(1,8) ,yzcol(2,8) ,yzcol(3,8) /4,8,0/ data yzcol(1,9) ,yzcol(2,9) ,yzcol(3,9) /14,8,0/ !div*dt data yzcol(1,10),yzcol(2,10),yzcol(3,10)/4,30,0/ !qv [g/kg] data yzcol(1,11),yzcol(2,11),yzcol(3,11)/4,8,0/ !qc [g/kg] data yzcol(1,12),yzcol(2,12),yzcol(3,12)/4,8,0/ !qr,qia,qib [g/kg] data yzcol(1,13),yzcol(2,13),yzcol(3,13)/4,10,0/ !Rh data yzcol(1,14),yzcol(2,14),yzcol(3,14)/4,50,0/ !thetav data yzcol(1,15),yzcol(2,15),yzcol(3,15)/4,8,0/ !Km*dt/Dx**2 data yzcol(1,16),yzcol(2,16),yzcol(3,16)/14,10,0/ !Ri data yzcol(1,17),yzcol(2,17),yzcol(3,17)/14,8,0/ !v data yzcol(1,18),yzcol(2,18),yzcol(3,18)/14,8,0/ !vortx*dt data yzcol(1,19),yzcol(2,19),yzcol(3,19)/14,8,0/ !vorty*dt data yzcol(1,20),yzcol(2,20),yzcol(3,20)/14,8,0/ !vortz*dt data yzcol(1,21),yzcol(2,21),yzcol(3,21)/14,8,0/ !pv c COLORPAL ISOLINES LINE_LABELS data xycol(1,1) ,xycol(2,1) ,xycol(3,1) /14,8,0/ !th/the-1. data xycol(1,2) ,xycol(2,2) ,xycol(3,2) /4,8,0/ !th data xycol(1,3) ,xycol(2,3) ,xycol(3,3) /14,8,0/ !p*2.*dti data xycol(1,4) ,xycol(2,4) ,xycol(3,4) /14,8,0/ !u data xycol(1,5) ,xycol(2,5) ,xycol(3,5) /2,8,0/ !om data xycol(1,6) ,xycol(2,6) ,xycol(3,6) /14,8,0/ !w data xycol(1,7) ,xycol(2,7) ,xycol(3,7) /4,8,0/ data xycol(1,8) ,xycol(2,8) ,xycol(3,8) /4,8,0/ data xycol(1,9) ,xycol(2,9) ,xycol(3,9) /14,8,0/ !div*dt data xycol(1,10),xycol(2,10),xycol(3,10)/4,8,0/ !qv [g/kg] data xycol(1,11),xycol(2,11),xycol(3,11)/4,8,0/ !qc [g/kg] data xycol(1,12),xycol(2,12),xycol(3,12)/4,8,0/ !qr,qia,qib [g/kg] data xycol(1,13),xycol(2,13),xycol(3,13)/4,8,0/ !Rh data xycol(1,14),xycol(2,14),xycol(3,14)/4,8,0/ !thetav data xycol(1,15),xycol(2,15),xycol(3,15)/4,8,0/ !Km*dt/Dx**2 data xycol(1,16),xycol(2,16),xycol(3,16)/4,8,0/ !Ri data xycol(1,17),xycol(2,17),xycol(3,17)/14,8,0/ !v data xycol(1,18),xycol(2,18),xycol(3,18)/14,8,0/ !vortx*dt data xycol(1,19),xycol(2,19),xycol(3,19)/14,8,0/ !vorty*dt data xycol(1,20),xycol(2,20),xycol(3,20)/14,8,0/ !vortz*dt data xycol(1,21),xycol(2,21),xycol(3,21)/14,8,0/ !pv data xycol(1,22),xycol(2,22),xycol(3,22)/4,8,0/ !isentropic surface 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) subroutine plot(th,u,v,om,w,p,div,qv,qc,qr,qia,qib,lipps,tke, . rhf) include 'param.nml' include 'param.misc' 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), . om(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), . 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) dimension pz(1-ih:np+ih+1, 1-ih:mp+ih+1, l+1) dimension qia(1-ih:nicp+ih, 1-ih:micp+ih, lic), . qib(1-ih:nicp+ih, 1-ih:micp+ih, lic) dimension fxz(n,l),fyz(m,l),fxy(n,m), 1 uxz(n,l),wxz(n,l),vyz(m,l),wyz(m,l),uxy(n,m),vxy(n,m) dimension kil(3) common/zinver/ iinav,iqcav 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), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 4) C common// ri(n,m,l),fxyz(n,m,l),fxz(n,l),fyz(m,l),fxy(n,m), C 1 uxz(n,l),wxz(n,l),vyz(m,l),wyz(m,l),uxy(n,m),vxy(n,m) C 2,df(n,m,l),hx(n,m,l),hy(n,m,l),hz(n,m,l),pz(n+1,m+1,l+1) 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,hlatv,hlats,hlatf common/sgscnst/ ceps,cL,cm,cs,prndt common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/metrit/ zsd(n,m),tt,tend common/stresd/ ivis,irid,idiagstr(2),diagstr(8) 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), . itkes common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/gora/ xml,yml,amp,xml0,yml0 common /plzsmax/zsmx,mintop common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly data isx,isy/0,0/ c ivctpl = 1 (vectors) c ivctpl = 2 (streamlines) data ivctpl/0/ data izcr0/0/ common/plofl/ ibupl,ithpl,iprpl, . iuvpl,ivvpl,iompl,iwvpl,idvpl, . iqvpl,iqcpl,iqrpl,irhpl,ithvpl,ikmpl,iscpl data ibupl/1/,ithpl/1/,iprpl/0/, 1 iuvpl/1/,ivvpl/1/,iompl/0/,iwvpl/1/,idvpl/0/,iripl/0/, 1 iqvpl/1/,iqcpl/1/,iqrpl/0/,irhpl/1/,ithvpl/1/,ikmpl/1/, 1 iqial/0/,iqibl/0/,iscpl/1/ data ixzpl/1/,iyzpl/1/,ixypl/1/,iprfl/1/,iflxpl/0/,isppl/0/ 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/1/,isptw/1/,isptt/1/ c c---> nsppl is number of vertical levels to spectral analyze c---> ksppl(1,2,...nsppl) is vertical grid levels to analyze parameter (nsppl = 3) integer ksppl(nsppl), kug data ksppl/5,25,45/ 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 nm=n*m nml=n*m*l inorm=0 if(j3.eq.0) then c ivvpl=0 iyzpl=0 ixypl=0 isy=0 endif iqvpl=iqvpl*moist iqcpl=iqcpl*moist iqrpl=iqrpl*moist irhpl=irhpl*moist ithvpl=ithvpl*moist ikmpl=ikmpl*ivis iripl=iripl*irid 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 iqial=(iqial*moist)*iceab iqibl=(iqibl*moist)*iceab c contour level density c nclv=17 nclv=40 conversions for disipalys c limit Ri for display purposes if(iripl.eq.1) then ricut=0. do i=1,n do j=1,m do k=1,l ri(i,j,k)=amin1(ri(i,j,k),ricut) enddo enddo enddo endif c c filter selected fields for plots nullfl=1 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 c contour plots follow if(iprfl.eq.1) then if(ibupl.eq.1) then do 101 i=1,n do 101 j=1,m do 101 k=1,l 101 fxyz(i,j,k)= th(i,j,k)/the(i,j,k)-1. call profil(fxyz,n,m,l,1) endif if(ithpl.eq.1) then do 102 i=1,n do 102 j=1,m do 102 k=1,l 102 fxyz(i,j,k)= th(i,j,k) call profil(fxyz,n,m,l,2) endif if(iprpl.eq.1) then do 103 i=1,n do 103 j=1,m do 103 k=1,l 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 i=1,n do 104 j=1,m do 104 k=1,l 104 fxyz(i,j,k)= u(i,j,k) call profil(fxyz,n,m,l,4) endif if(ivvpl.eq.1) then do 1041 i=1,n do 1041 j=1,m do 1041 k=1,l 1041 fxyz(i,j,k)= v(i,j,k) call profil(fxyz,n,m,l,41) endif if(iompl.eq.1) then do 105 i=1,n do 105 j=1,m do 105 k=1,l 105 fxyz(i,j,k)= om(i,j,k) call profil(fxyz,n,m,l,5) endif if(iwvpl.eq.1) then do 106 i=1,n do 106 j=1,m do 106 k=1,l 106 fxyz(i,j,k)= w(i,j,k) call profil(fxyz,n,m,l,6) endif if(idvpl.eq.1) then do 109 i=1,n do 109 j=1,m do 109 k=1,l 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 i=1,n do 110 j=1,m do 110 k=1,l 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 i=1,n do 111 j=1,m do 111 k=1,l 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 i=1,n do 112 j=1,m do 112 k=1,l 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 i=1,n do 1121 j=1,m do 1121 k=1,l 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 i=1,n do 1122 j=1,m do 1122 k=1,l 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 i=1,n do 113 j=1,m do 113 k=1,l 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 i=1,n do 114 j=1,m do 114 k=1,l 114 fxyz(i,j,k)=th(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 i=1,n do 115 j=1,m do 115 k=1,l 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 i=1,n do 116 j=1,m do 116 k=1,l 116 fxyz(i,j,k)=ri(i,j,k) call profil(fxyz,n,m,l,16) 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 contour plots follow zsmx=0. mintop=1.e-4 do i=1,n do j=1,m zsmx=amax1(zsmx,abs(zs(i,j))) enddo enddo 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(ibupl.eq.1) then do 201 k=1,l do 201 i=1,n fxz(i,k)= th(i,j,k)/the(i,j,k)-1. c fxz(i,k)= th(i,j,k)-the(i,j,k) if(isy.eq.1) then fxz(i,k)=.5*(fxz(i,k)+th(i,j+1,k)/the(i,j+1,k)-1.) c fxz(i,k)=.5*(fxz(i,k)+th(i,j+1,k)-the(i,j+1,k)) endif 201 continue call xzplot(j,isy,fxz,uxz,wxz,n,l,ivctpl,1,nclv) endif if(ithpl.eq.1) then do 202 k=1,l do 202 i=1,n c 202 fxz(i,k)= alog(0.5*(th(i,j,k)+th(i,j+isy,k))) 202 fxz(i,k)= 0.5*(th(i,j,k)+th(i,j+isy,k)) 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))-(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(iompl.eq.1) then do 205 k=1,l do 205 i=1,n 205 fxz(i,k)=.5*(om(i,j,k)+om(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)=.5*(th(i,j,k)+epsb*qv(i,j,k)*th0(i,j,k) .+th(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 777 continue endif close xzplots if(iyzpl.eq.1) then ic=(1+n)/2 i1=ic in=ic ii=1 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(ibupl.eq.1) then do 301 k=1,l do 301 j=1,m c fyz(j,k)=th(i,j,k)/the(i,j,k)-1. fyz(j,k)=th(i,j,k)-the(i,j,k) if(isx.eq.1) then c fyz(j,k)=.5*(fyz(j,k)+th(i+1,j,k)/the(i+1,j,k)-1.) fyz(j,k)=.5*(fyz(j,k)+th(i+1,j,k)-the(i+1,j,k)) endif 301 continue call yzplot(i,isx,fyz,vyz,wyz,m,l,ivctpl,1,nclv) endif if(ithpl.eq.1) then do 302 k=1,l do 302 j=1,m 302 fyz(j,k)=.5*(th(i,j,k)+th(i+isx,j,k)) call yzplot(i,isx,fyz,vyz,wyz,m,l,0,2,nclvs) endif 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(iompl.eq.1) then do 305 k=1,l do 305 j=1,m 305 fyz(j,k)=.5*(om(i,j,k)+om(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)+epsb*qv(i,j,k)*th0(i,j,k) .+th(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 888 continue endif close yzplots if(ixypl.eq.1) then do 998 izcr=0,izcr0 if(izcr.eq.0) then k1=15 kl=45 ki=15 c k1=26 c kl=26 c ki=1 else k1=15 kl=45 ki=15 c k1=26 c kl=26 c ki=1 endif kil(1)=l/4 kil(2)=iqcav kil(3)=3*l/4 print *,'Plot XY in levels:',kil(1),kil(2),kil(3) do 999 kki=1,3 kk=kil(kki) if(ivctpl.eq.1) then do 400 j=1,m do 400 i=1,n uxy(i,j)=u(i,j,kk) vxy(i,j)=v(i,j,kk) 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 c call inzxy(kk,u,uxy,n,m,l,izcr,0,kug) c call inzxy(kk,v,vxy,n,m,l,izcr,0,kug) endif if(ibupl.eq.1) then do 401 i=1,n do 401 j=1,m do 401 k=1,l c 401 fxyz(i,j,k)=th(i,j,k)/the(i,j,k)-1. 401 fxyz(i,j,k)=th(i,j,k)-the(i,j,k) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,1,nclv) endif if(ithpl.eq.1) then call inzxy(kk,th,fxy,n,m,l,izcr,1,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,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,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,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,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,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,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,41,nclv) endif if(iompl.eq.1) then call inzxy(kk,om,fxy,n,m,l,izcr,1,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,5,nclv) endif if(iwvpl.eq.1) then call inzxy(kk,w,fxy,n,m,l,izcr,1,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,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,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,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,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,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,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,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,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,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,kug) call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,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,kug) call xyplot(k,fxy,uxy,vxy,n,m,ivctpl,32,nclv) endif if(irhpl.eq.1) then call inzxy(kk,rhf,fxy,n,m,l,izcr,1,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,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)+epsb*qv(i,j,k)*th0(i,j,k) call inzxy(kk,fxyz,fxy,n,m,l,izcr,1,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,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,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,15,nclv) endif if(iripl.eq.1) then call inzxy(kk,ri,fxy,n,m,l,izcr,1,kug) call xyplot(kk,fxy,uxy,vxy,n,m,ivctpl,16,nclv) endif 999 continue 998 continue close xyplot endif 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 do 1098 izcr=0,izcr0 do 510 kk=1,nsppl ks = ksppl(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 call inzxy(ks,fxyz,fxy,n,m,l,izcr,1,kug) do i=1,2 call spxypl(fxy,n,m,1,ks,kug,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,kug) do i=1,2 call spxypl(fxy,n,m,2,ks,kug,i) enddo endif if(isptw.eq.1) then call inzxy(ks,w,fxy,n,m,l,izcr,1,kug) do i=1,2 call spxypl(fxy,n,m,3,ks,kug,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,kug) do i=1,2 call spxypl(fxy,n,m,4,ks,kug,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,nn=nm/2,nnp=nn+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),nn) c enddo call setusv('LW',2000) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(xx(2),spav(2),nn) 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),nn) 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, kug,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 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 nn(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,kug,ireset,LL,subavg,kscale,escale=', 1 n1,n2,iflg,k,dsd,kug,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(kug.ne.0) then do 10 j=1,n2 do 10 i=1,n1 if(nint(fxy(i,j)).eq.kug) 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 =',kug,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:54) ux = cpux(512) uy = cpuy(1012) call plchhq(ux,uy,title(1:54),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('(f6.2)','(1PE7.1)',6,7,15,15,0,0,0) elseif((exfmt.eq.0).and.(eyfmt.eq.0)) then call labmod('(f6.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 nn(1) = ndim nn(2) = jymax ntot = nn(1)*nn(2) nwork = nmax*nmax n1d2 = nn(1)/2 n1d2p1 = n1d2+1 n2d2 = nn(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,nn(2) do 91 i=1,nn(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 nn(1),nn(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:54),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, (nn(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 (TURBPL == 1) subroutine turban(u,v,w,th,p,qv,qc,qr,lipps,e,ivis) include 'param.nml' include 'param.misc' 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) 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, 7) 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,hlatv,hlats,hlatf common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/gora/ xml,yml,amp,xml0,yml0 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 'param.misc' 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 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, 7) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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), . itkes common/srprint/ itblpri real linet, xs(2), ys(2) 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.e3 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 [km] -->',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) c --- specify lines call set(.1,.9,.1,.9,0.,1.,0.,1.,1) ns = 2 xs(1) = .6 xs(2) = .75 c --- ---------- call dashdc('$''$''$''$''$''$''$''',10,12) ys(1) = .85 ys(2) = .85 call curved(xs,ys,ns) ux = 1.05*xs(2) uy = ys(1) call plchhq(ux,uy,'buoyancy',0.015,0.,-1.) c --- ---------- call dashdc('$$''$$''$$''$$''$$''',10,12) ys(1) = .8 ys(2) = .8 call curved(xs,ys,ns) ux = 1.05*xs(2) uy = ys(1) call plchhq(ux,uy,'u,v,w,p',0.015,0.,-1.) c --- ---------- call dashdc('$$$''$$$''$$$''$$$''',10,12) ys(1) = .75 ys(2) = .75 call curved(xs,ys,ns) ux = 1.05*xs(2) uy = ys(1) call plchhq(ux,uy,'dissip',0.015,0.,-1.) c --- ---------- call dashdc('$$$$''$$$$''$$$$''',10,12) ys(1) = .7 ys(2) = .7 call curved(xs,ys,ns) ux = 1.05*xs(2) uy = ys(1) call plchhq(ux,uy,'U shear',0.015,0.,-1.) c --- ---------- call dashdc('$$$$$''$$$$$''$$$$$''',10,12) ys(1) = .65 ys(2) = .65 call curved(xs,ys,ns) ux = 1.05*xs(2) uy = ys(1) call plchhq(ux,uy,'V shear',0.015,0.,-1.) c --- ---------- call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) ys(1) = .6 ys(2) = .6 call curved(xs,ys,ns) ux = 1.05*xs(2) uy = ys(1) call plchhq(ux,uy,'total TKE',0.015,0.,-1.) c --- ---------- 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 'param.misc' 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/ drgnorm, itd common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm 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, 5) 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 'param.misc' 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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 'param.misc' 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 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/srprint/ itblpri c zlam=1.e3 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 [km] -->',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 'param.misc' 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 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/srprint/ itblpri c zlam=1.e3 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)+1.e-10) fss(k)=fss(k)/(awn(k)+1.e-10) 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 [km] -->',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 'param.misc' 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 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly c c zlam=1.e3 ntp=n3 top=(ntp-1)*dz/zlam il=1 ir=n1-ibcx jl=1 jr=n2-ibcy 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 (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.1)',3,6,2,2,20,20,0) call periml(1,10,5,2) 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.1)',3,6,2,2,20,20,0) call periml(1,10,5,2) 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 'param.misc' 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) 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, 3) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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 realatively 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/1/,ithpl/1/ data ixzpl/1/,iyzpl/1/,ixypl/1/,iprfl/1/,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 in=ic ii=1 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=20 kl=20 kk=1 else k1=6 kl=11 kk=1 endif do 999 k=k1,kl,kk if (ivctpl.eq.1) then do 400 j=1,m do 400 i=1,n uxy(i,j)=u(i,j,k) vxy(i,j)=v(i,j,k) 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 c call inzxy(k,u,uxy,n,m,l,izcr,0,kug) c call inzxy(k,v,vxy,n,m,l,izcr,0,kug) 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,kug) 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,kug) 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,kug) 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,kug) 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 'param.misc' 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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 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), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 3) C common// pv(n,m,l),zth(n,m,l),thx(n,m,l), C * thy(n,m,l),thz(n,m,l),thn(n,m,l) call update(th,np,mp,l,np,mp) 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 illim = 1 + 1*leftedge iulim = np - 1*rightedge 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 (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 if (j3 .eq. 1) then jllim = 1 + j3*botedge julim = mp - j3*topedge 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 (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 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) include 'param.nml' include 'param.misc' 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) common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) 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), . ugg(1-ih:np+ih, 1-ih:mp+ih, l), . vgg(1-ih:np+ih, 1-ih:mp+ih, l), . wgg(1-ih:np+ih, 1-ih:mp+ih, l), . temp(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 3) C common ug(n,m,l), vg(n,m,l), wg(n,m,l), C . ugg(n,m,l),vgg(n,m,l),wgg(n,m,l) nm=n*m ml=m*l nml=n*m*l dxil=.5*dxi dyil=.5*dyi dzil=.5*dzi do i=1,np do j=1,mp do k=1,l ug(i,j,k)=(u(i,j,k)-iflg*ue(i,j,k))/gi(i,j) vg(i,j,k)=(v(i,j,k)-iflg*ve(i,j,k))/gi(i,j) wg(i,j,k)=w(i,j,k)/gi(i,j) ugg(i,j,k)=(u(i,j,k)-iflg*ue(i,j,k)) - . c13(i,j)*gmul(k)*w(i,j,k)/gi(i,j) vgg(i,j,k)=(v(i,j,k)-iflg*ve(i,j,k)) - . c23(i,j)*gmul(k)*w(i,j,k)/gi(i,j) wgg(i,j,k)=(c13(i,j)*gmul(k)*(v(i,j,k)-iflg*ve(i,j,k)) - . c23(i,j)*gmul(k)*(u(i,j,k)-iflg*ue(i,j,k)))/ . gi(i,j) enddo enddo enddo call update(ug,np,mp,l,np,mp) call update(vg,np,mp,l,np,mp) call update(wg,np,mp,l,np,mp) call update(ugg,np,mp,l,np,mp) call update(vgg,np,mp,l,np,mp) call update(wgg,np,mp,l,np,mp) illim = 1 + 1*leftedge iulim = np - 1*rightedge do k=1,l do j=1,mp do i=illim,iulim vry(i,j,k)= - dxil*(wg(i+1,j,k)-wg(i-1,j,k)) vrz(i,j,k)= dxil*(vg(i+1,j,k)-vg(i-1,j,k))*j3 enddo enddo enddo if (leftedge.eq.1) then do k=1,l do j=1,mp vry(1,j,k)= -((1-ibcx)*dxi*(wg(2,j,k)-wg(1 ,j,k)) . +ibcx*dxil*(wg(2,j,k)-wg(-1,j,k))) vrz(1,j,k)= ((1-ibcx)*dxi*(vg(2,j,k)-vg(1 ,j,k)) . +ibcx*dxil*(vg(2,j,k)-vg(-1,j,k)))*j3 enddo enddo endif if (rightedge.eq.1) then do k=1,l do j=1,mp vry(np,j,k)= -((1-ibcx)*dxi*(wg(np,j,k)-wg(np-1,j,k)) . +ibcx*dxil*(wg(np+2,j,k)-wg(np-1,j,k))) vrz(np,j,k)= ((1-ibcx)*dxi*(vg(np,j,k)-vg(np-1,j,k)) . +ibcx*dxil*(vg(np+2,j,k)-vg(np-1,j,k)))*j3 enddo enddo endif if (j3.eq.1) then jllim = 1 + j3*botedge julim = mp - j3*topedge do k=1,l do j=jllim,julim do i=1,np vrx(i,j,k)= dyil*(wg(i,j+j3,k)-wg(i,j-j3,k)) vrz(i,j,k)= vrz(i,j,k) - . dyil*(ug(i,j+j3,k)-ug(i,j-j3,k)) enddo enddo enddo if (botedge.eq.1) then do k=1,l do i=1,np vrx(i,1,k)=(1-ibcy)*dyi*(wg(i,1+j3,k)-wg(i,1,k)) . + ibcy*dyil*(wg(i,1+j3,k)-wg(i,-j3,k)) vrz(i,1,k)= vrz(i,1,k) - . ((1-ibcy)*dyi*(ug(i,1+j3,k)-ug(i,1,k)) . + ibcy*dyil*(ug(i,1+j3,k)-ug(i,-j3,k))) enddo enddo end if if (topedge.eq.1) then do k=1,l do i=1,np vrx(i,mp,k)=(1-ibcy)*dyi*(wg(i,mp,k)-wg(i,mp-j3,k)) . + ibcy*dyil*(wg(i,mp+2,k)-wg(i,mp-j3,k)) vrz(i,mp,k)= vrz(i,mp,k) - . ((1-ibcy)*dyi*(ug(i,mp,k)-ug(i,mp-j3,k)) . + ibcy*dyil*(ug(i,mp+2,k)-ug(i,mp-j3,k))) enddo enddo end if else do i=1,np do j=1,mp do k=1,l vrx(i,j,k)=0. vrz(i,j,k)=0. enddo enddo enddo endif do k=2,l-1 do j=1,mp do i=1,np vrx(i,j,k)=vrx(i,j,k) - . dzil*(vgg(i,j,k+1)-vgg(i,j,k-1))*j3 vry(i,j,k)=vry(i,j,k) + . dzil*(ugg(i,j,k+1)-ugg(i,j,k-1)) vrz(i,j,k)=vrz(i,j,k) + . dzil*(wgg(i,j,k+1)-wgg(i,j,k-1))*j3 enddo enddo enddo do j=1,mp do i=1,np vrx(i,j,1)=vrx(i,j,1)- dzi*(vgg(i,j,2)-vgg(i,j,1))*j3 vrx(i,j,l)=vrx(i,j,l)- dzi*(vgg(i,j,l)-vgg(i,j,l-1))*j3 vry(i,j,1)=vry(i,j,1)+ dzi*(ugg(i,j,2)-ugg(i,j,1)) vry(i,j,l)=vry(i,j,l)+ dzi*(ugg(i,j,l)-ugg(i,j,l-1)) vrz(i,j,1)=vrz(i,j,1)+ dzi*(wgg(i,j,2)-wgg(i,j,1))*j3 vrz(i,j,l)=vrz(i,j,l)+ dzi*(wgg(i,j,l)-wgg(i,j,l-1))*j3 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 do k=1,l do j=1,mp do i=1,np vrx(i,j,k)=vrx(i,j,k)*gi(i,j)*dt vry(i,j,k)=vry(i,j,k)*gi(i,j)*dt vrz(i,j,k)=vrz(i,j,k)*gi(i,j)*dt enddo enddo enddo compute vorticity diagnostics vrxmx=-1.e15 vrxmn= 1.e15 vrxav= 0. vrymx=-1.e15 vrymn= 1.e15 vryav= 0. vrzmx=-1.e15 vrzmn= 1.e15 vrzav= 0. c do k=1,l c do j=1,mp c do i=1,np c vrxmx=amax1(vrxmx,vrx(i,j,k)) c vrxmn=amin1(vrxmn,vrx(i,j,k)) c vrxav= vrxav+vrx(i,j,k) c vrymx=amax1(vrymx,vry(i,j,k)) c vrymn=amin1(vrymn,vry(i,j,k)) c vryav= vryav+vry(i,j,k) c vrzmx=amax1(vrzmx,vrz(i,j,k)) c vrzmn=amin1(vrzmn,vrz(i,j,k)) c vrzav= vrzav+vrz(i,j,k) c enddo c enddo c enddo 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 c vrxsd=vrxsd+(vrx(i,j,k)-vrxav)**2 c vrysd=vrysd+(vry(i,j,k)-vryav)**2 c vrzsd=vrzsd+(vrz(i,j,k)-vrzav)**2 temp(i,j,k)=(vrx(i,j,k)-vrzav)**2 enddo enddo enddo vrxsd=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=(vry(i,j,k)-vryav)**2 enddo enddo enddo vrysd=globsum(temp,1-ih,np+ih,1-ih,mp+ih,1,l,1,np,1,mp,1,l) do k=1,l do j=1,mp do i=1,np temp(i,j,k)=(vrz(i,j,k)-vrzav)**2 enddo enddo enddo vrzsd=globsum(temp,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(1x,'vrxmx,vrxmn,vrxav,vrxsd:',4e11.4) print 202, vrymx,vrymn,vryav,vrysd 202 format(1x,'vrymx,vrymn,vryav,vrysd:',4e11.4) print 203, vrzmx,vrzmn,vrzav,vrzsd 203 format(1x,'vrzmx,vrzmn,vrzav,vrzsd:',4e11.4) return end #endif subroutine reystress(f,w,n1,n2,n3,iflg,lipps) include 'param.nml' include 'param.misc' 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) character*80 lhead dimension fav(l),wav(l),fwav(l),reys(l),reysd(l), 1 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/ drgnorm, itd common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/normzi/ zi,wstr,tstr,qstr,hf00,qf00,cdrg,inorm common/skew/ w2(l) 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, 5) 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 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 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 reys(kc) = reys(kc) + * (fz(i,j,kc)-fav(kc))**nsq*(wz(i,j,kc)-wav(kc))*rho(kc) enddo enddo endif ccc if (wgt(kc).eq.float(ir*jr)) then ccc 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) + ccc * ((fwz(i,j,kc)-fav(kc)*wav(kc))*rho(kc)*dx*dy/cnorm * ((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)) ccc * *rho(kc)*dx*dy/cnorm - reys(kc) )**2 * *rho(kc) - reys(kc) )**2 enddo enddo endif if (wgt(kc).gt.0.) then ccc 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 do 22 k=1,n3 zcr(k)=zcr(k)/zlam t1=amax1(t1,reys(k)) t2=amin1(t2,reys(k)) 22 t3=amax1(t3,reysd(k)) 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 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 [km] -->',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.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(reys(is),zcr(is),ip) 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(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,kug) include 'param.nml' include 'param.misc' 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common /smospv/ spval,jswt,ioffp c kug = 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 kug = 123456*ispvl spval=kug fiz(i,j)=spval endif enddo enddo endif return end subroutine inzxy3(f,fiz,n1,n2,n3) include 'param.nml' include 'param.misc' 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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 'param.misc' 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly 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 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 'param.misc' 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 timepl(f1,n1,n3,nclv,iflg) include 'param.nml' include 'param.misc' include 'msg.inc' parameter (nl2=n*nth*2) dimension f1(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/ inita , initb , arowl , iterp , iterc , igflg 1 , imsg , uvmsg , icyc , displ , dispc , cstop common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),zct,itc common /plzsmax/zsmx,mintop c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) 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/ jswt=1 ioffp=0 spval=0. ilab=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 c iz0=1 c iz1=0 incx=2 ! 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 xml=1.e3 ntp=n3 nbt=1 xm0=(ntp-1)*dt/60 xm1=(nbt-1)*dt/60 ntp=n3-ke nbt=1+ks top=(ntp-1)*dz/zlam bot=(nbt-1)*dz/zlam botzb=(nbt-1)*dz/zb cccccccccccccccccccccccccccccccccc c contour plots of CAPE follow cccccccccccccccccccccccccccccccccc iflagc=iflg #if (COLORPL == 1) color plot create values for color map ipal =4 !colorpalete nclev=12 !number of isolines ilabl=0 !number of line labels zmin1=0. !minimum values zmax1=1000. !maximum values izval1=0 !flag for min, max values ihlg1=0 !high/low labels ihcg1=0 !hachuring flags call sflush vps=-(t2x-t1x)/(t2z-t1z) !vps=-1.5 - sample value c plot color isolines, labels call colorpl(f1(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 call set(t1x,t2x,t1z,t2z,xm0,xm1,bot,top,1) create minimum(cmn), maximum(cmx) and contour density(cnt) izval1=izval(iflagc) if (izval1.eq.1) then cmn=0. cmx=1000. nclv=15 cnt=(cmx-cmn)/float(nclv) else call contin(f,cmn,cmx,cnt,nclv,n,l) 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 (COLORPL == 0) c plot bw isolines if (cmx.ge.cnt) then ct=cnt if(cmn.gt.ct) ct=cmn call conrec(f1(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 f1(i,k)=-f1(i,k) end do end do ct=cnt if (cmx.lt.-ct) ct=-cmx cmnn=-cmn call conrec(f1(1+is,1+ks),n1,n1-(is+ie),n3-(ks+ke),ct,cmnn,cnt, . -1,-1,682) end if #endif call gaseti('LTY',1) call labmod('(f6.2)','(f6.2)',6,6,1,1,20,20,0) call gridal (5,10,5,2,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-.125 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') call plchhq(xc,cfuy(yxl),'x (km)',.015, 0.,0.) call plchhq(cfux(xyl),yc,'time (min)',.015,90.,0.) call wrtitl(lhead,iflg,time,jc,6) 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 #if (CAPEPL == 1) subroutine wyporpl(f1,f2,n1,n3,nclv) include 'param.nml' include 'param.misc' include 'msg.inc' parameter (nl2=n*nth*2) dimension f1(n1,n3),f2(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/ inita , initb , arowl , iterp , iterc , igflg 1 , imsg , uvmsg , icyc , displ , dispc , cstop common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),zct,itc common /plzsmax/zsmx,mintop c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) 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/ jswt=1 ioffp=0 spval=0. ilab=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 c iz0=1 c iz1=0 incx=2 ! 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 xml=1.e3 xm0=-((n1-1-2*is)*0.5*dx/xml) xm1=+((n1-1-2*ie)*0.5*dx/xml) ntp=n3-ke nbt=1+ks top=(ntp-1)*dt/60 bot=(nbt-1)*dt/60 botzb=(nbt-1)*dt/60 cccccccccccccccccccccccccccccccccc c contour plots of CAPE follow cccccccccccccccccccccccccccccccccc iflg=33 iflagc=iflg #if (COLORPL == 1) color plot create values for color map ipal =4 !colorpalete nclev=12 !number of isolines ilabl=0 !number of line labels zmin1=0. !minimum values zmax1=1000. !maximum values izval1=0 !flag for min, max values ihlg1=0 !high/low labels ihcg1=0 !hachuring flags call sflush vps=-(t2x-t1x)/(t2z-t1z) !vps=-1.5 - sample value c plot color isolines, labels call colorpl(f1(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 call set(t1x,t2x,t1z,t2z,xm0,xm1,bot,top,1) create minimum(cmn), maximum(cmx) and contour density(cnt) izval1=izval(iflagc) if (izval1.eq.1) then cmn=0. cmx=1000. nclv=15 cnt=(cmx-cmn)/float(nclv) else call contin(f,cmn,cmx,cnt,nclv,n,l) 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 (COLORPL == 0) c plot bw isolines if (cmx.ge.cnt) then ct=cnt if(cmn.gt.ct) ct=cmn call conrec(f1(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 f1(i,k)=-f1(i,k) end do end do ct=cnt if (cmx.lt.-ct) ct=-cmx cmnn=-cmn call conrec(f1(1+is,1+ks),n1,n1-(is+ie),n3-(ks+ke),ct,cmnn,cnt, . -1,-1,682) end if #endif call gaseti('LTY',1) call labmod('(f6.2)','(f6.2)',6,6,1,1,20,20,0) call gridal (5,10,5,2,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-.125 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') call plchhq(xc,cfuy(yxl),'x (km)',.015, 0.,0.) call plchhq(cfux(xyl),yc,'time (min)',.015,90.,0.) call wrtitl(lhead,iflg,time,jc,6) 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 ccccccccccccccccccccccccccccccccc c contour plots of CIN follow ccccccccccccccccccccccccccccccccc iflg=34 iflagc=iflg #if (COLORPL == 1) color plot create values for color map ipal =4 !colorpalete nclev=12 !number of isolines ilabl=0 !number of line labels zmin1=0. !minimum values zmax1=1000. !maximum values izval1=0 !flag for min, max values ihlg1=0 !high/low labels ihcg1=0 !hachuring flags call sflush vps=-(t2x-t1x)/(t2z-t1z) !vps=-1.5 - sample value c plot color isolines, labels call colorpl(f2(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 call set(t1x,t2x,t1z,t2z,xm0,xm1,bot,top,1) create minimum(cmn), maximum(cmx) and contour density(cnt) izval1=izval(iflagc) if (izval1.eq.1) then cmn=0. cmx=1000. nclv=15 cnt=(cmx-cmn)/float(nclv) else call contin(f,cmn,cmx,cnt,nclv,n,l) 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 (COLORPL == 0) c plot bw isolines if (cmx.ge.cnt) then ct=cnt if(cmn.gt.ct) ct=cmn call conrec(f2(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 f2(i,k)=-f2(i,k) end do end do ct=cnt if (cmx.lt.-ct) ct=-cmx cmnn=-cmn call conrec(f2(1+is,1+ks),n1,n1-(is+ie),n3-(ks+ke),ct,cmnn,cnt, . -1,-1,682) end if #endif call gaseti('LTY',1) call labmod('(f6.2)','(f6.2)',6,6,1,1,20,20,0) call gridal (5,10,5,2,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-.125 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') call plchhq(xc,cfuy(yxl),'x (km)',.015, 0.,0.) call plchhq(cfux(xyl),yc,'time (min)',.015,90.,0.) call wrtitl(lhead,iflg,time,jc,6) 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 #endif subroutine lwcpl(th,u,v,w,qv,qc,qr,qia,qib,lippsi,it) include 'param.nml' include 'param.misc' include 'msg.inc' dimension qia(1-ih:nicp+ih,1-ih:micp+ih,lic), . qib(1-ih:nicp+ih,1-ih:micp+ih,lic), . 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), . 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) dimension alwc(1-ih:nmsp+ih,1-ih:mmsp+ih,lms), . alwp(1-ih:nmsp+ih,1-ih:mmsp+ih), . zcr(l),rho(l),press(l) character*10 filename dimension zlwc(l),zlwch(120,l),zlwph(400) 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/blank/ plot_reserve(1-ih:np+ih, 1-ih:mp+ih, l, 5), . tem(1-ih:np+ih, 1-ih:mp+ih, l), . scr4(1-ih:np+ih, 1-ih:mp+ih, l, 4) do 1 kc=1,l 1 zcr(kc)=(kc-1)*dz call density profile call rhprof(rho,zcr,l,lipps) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C FIND LOCAL TEMPERATURE CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC compute approximate pressure of height levels: press(1)=pr00/100. do j=1,mp do i=1,np tem(i,j,1)=th(i,j,1)*(1000./press(1))**(-rg/cp) enddo enddo do k=2,l do j=1,mp do i=1,np km=k-1 tempk =th(i,j,k ) tempkm=th(i,j,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*(zcr(k)-zcr(km))/cp )**rci tem(i,j,k)=th(i,j,k)*(1000./press(k))**(-rg/cp) enddo enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C FIND LOCAL TEMPERATURE DONE CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC #if (ANALIZE == 0) if(it.lt.10) then write(filename( 7: 7),'(I1)') 0 write(filename( 8: 8),'(I1)') 0 write(filename( 9: 9),'(I1)') 0 write(filename(10:10),'(I1)') it elseif (it.lt.100) then write(filename( 7: 7),'(I1)') 0 write(filename( 8: 8),'(I1)') 0 write(filename( 9:10),'(I2)') it elseif (it.lt.1000) then write(filename( 7: 7),'(I1)') 0 write(filename( 8:10),'(I3)') it elseif (it.lt.10000) then write(filename( 7:10),'(I4)') it endif #else filename(7:9)='ana' write(filename(10:10),'(I1)') it #endif filename(1:6)='f_lwc.' open (unit=1, file=filename) filename(1:6)='f_tem.' open (unit=2, file=filename) filename(1:6)='f___u.' open (unit=3, file=filename) filename(1:6)='f___v.' open (unit=4, file=filename) filename(1:6)='f___w.' open (unit=5, file=filename) 2 format(3i4,1x,f7.2,1x,f4.1) 3 format(f7.2,1x,f4.1) 4 format(f7.2) 5 format(f4.1) do i=1,nmsp do j=1,mmsp do k=1,lms alwc(i,j,k)=qc(i,j,k)*rho(k) c alwc(i,j,k)=(qc(i,j,k)+qr(i,j,k))*rho(k) c write(15,2) i,j,k,alwc(i,j,k)*1000.,(tem(i,j,k)-273.15) c write(16,3) alwc(i,j,k)*1000.,(tem(i,j,k)-273.15) write(1,4) alwc(i,j,k)*1000. write(2,5) tem(i,j,k)-273.15 write(3,5) u(i,j,k) write(4,5) v(i,j,k) write(5,5) w(i,j,k) enddo enddo enddo close(1) close(2) close(3) close(4) close(5) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C WRITE LOCAL TEMPERATURE AND LWC DONE CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC iqcav=0 qcnvx=0. qcmint=0. qcmaxt=0. k0x=0 kmx=0 tbase=0. iinav=0 k00=l kmm=1 tlwp=100000. tlwh=1000. do k=1,lms zlwc(k)=0. do i=1,120 zlwch(i,k)=0. enddo enddo do i=1,400 zlwph(i)=0. enddo cccccccccccccccccccccccc do j=1,mmsp do i=1,nmsp zinv=0. do k=2,lms-1 zinv1=qv(i,j,k+1)-qv(i,j,k-1) ! find local z gradient of qv if(zinv1.lt.zinv) then ! find minimum in local gradient iinv=k ! level of minimum (inversion) zinv=zinv1 ! new value of minimum endif ! end enddo iinav=iinav+iinv ! mean level of inversion enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCC COMPUTE CLOUD STATISTICS CCCCCCCCCCCCCCCCCCCCCCCCCCCCC idiv=0 ! number of levels with cloud water do j=1,mmsp do i=1,nmsp CCCCCCCCCCCCCCCCCCCCCCCCCCCCC COLUMN LOOP ON THE PLANE CCCCCCCCCCCCCCCCCCCCCCCCCCCCC iqcv=0 qcnv=0. qcmin=0. qcmax=0. k0=0 km=0 tbase0=0. do k=1,lms qcnv1=qc(i,j,k) ! find local qc mixing ratio if(qcnv1.ge.1e-6) then if(qcnv1.gt.qcnv) then ! find maximum in local qc iqcv=k ! level of maxium cloud water qcnv=qcnv1 ! new value of maximum cloud water endif ! end if(qcmin.eq.0.) then qcmin=zcr(k) ! cloud base height k0=k ! cloud base level index tbase0=tem(i,j,k) ! cloud base temperature endif qcmax=zcr(k) ! cloud - maximum height km=k ! cloud - maximum height level index zlwc1=alwc(i,j,k) ! find local LWC zlwc2=zlwc1*tlwp ! convert LWC to [g/kg*100.] kl=k-k0+1 zlwc(kl)=zlwc(kl)+zlwc2 ! mean LWC above cloud base zlwch(nint(zlwc2),kl)= . zlwch(nint(zlwc2),kl)+1. ! histogram LWC above cloud base endif enddo iqcav=iqcav+iqcv ! mean level of maximum cloud water qcnvx=qcnvx+qcnv ! mean value of maximum cloud water qcmint=qcmint+qcmin ! mean height of cloud base qcmaxt=qcmaxt+qcmax ! mean height of cloud top k0x=k0x+k0 ! mean level of cloud base kmx=kmx+km ! mean level of cloud top tbase=tbase+tbase0 ! mean cloud base temperature CCCCCCCCCCCCCCCCCCCCCCCCCCCCC COLUMN LOOP ON THE PLANE DONE CCCCCCCCCCCCCCCCCCCCCCCCCCCCC alwp(i,j)=0. if(qcnv.gt.0.) then ! if column with cloud water idiv=idiv+1 ! another column with cloud water do k=2,km-k0+1 ! alwp(i,j)=0. for cloud base alwp(i,j)=alwp(i,j) . +0.5*(alwc(i,j,k0-1+k)+alwc(i,j,k0-2+k))*dz if(j.eq.10 .and. i.eq.10) . print *,i,j,k,alwp(i,j),alwc(i,j,k0-1+k) enddo zlwp1=alwp(i,j) ! find local LWP zlwp2=zlwp1*tlwh ! convert LWP to [g/m**2*1.] zlwph(int(zlwp2))= . zlwph(int(zlwp2))+1. ! histogram LWP above cloud base c if(j.eq.10) print *,i,j,zlwp1,zlwp2,nint(zlwp2),int(zlwp2) k00=min(k00,k0) ! total minimum in cloud base level kmm=max(kmm,km) ! total maximum in cloud height level endif ! endif enddo enddo CCCCCCCCCCCCCCCCCCCCCCCCCCCCC CLOUD STATISTICS COMPUTED CCCCCCCCCCCCCCCCCCCCCCCCCCCCC print *,'IDIV:',idiv,np*mp divide=1./float(idiv) ! nr of column with cloud water dividet=1./float(np*mp) ! nr of column (total) coverage=100.*float(idiv)*dividet ! coverage [%] iinav= iinav*dividet ! mean level of inversion iqcav= iqcav*divide ! mean level of max(qc) k0x= k0x*divide ! mean level of cloud base kmx= kmx*divide ! mean level of cloud top tbase= tbase*divide-273.16 ! mean cloud base temperature [C] qcnvx= qcnvx*divide*1000. ! mean value of maximum cloud water qcmint=qcmint*divide ! mean height of cloud base qcmaxt=qcmaxt*divide ! mean height of cloud top idepth =max(0,kmm-k00+1) ! maximun cloud level depth idepthx=max(0,kmx-k0x+1) ! mean cloud level depth c print *,' Mean LWC:' do k=1,l zlwc(k)=zlwc(k)*divide/100. c print *,k,zlwc(k) enddo do i=1,400 zlwph(i)=zlwph(i)*divide c write(*,*) 'ZLWPH:',i,zlwph(i) enddo cccccccccccccccccccccccc print *,'CLOUD MEAN STATISTICS' print *,'CLOUD coverage [%] :',coverage print *,'CLOUD base [m] :',int(qcmint) print *,'CLOUD top [m] :',int(qcmaxt) print *,'CLOUD base temperature [C]:',tbase print *,'CLOUD max depth [lev]:',idepth print *,'CLOUD mean depth [lev]:',idepthx print *,'CLOUD mean invers [lev]:',iinav print *,'CLOUD mean max(qc) [lev]:',iqcav print *,'CLOUD mean max(qc) [g/kg]:',qcnvx call lwcplot(zlwch,zlwph,tbase, . zlwc,idepth,idepthx,coverage,qcmint,qcmaxt) return end subroutine lwcplot(f1,fp,tbase, . f2,idepth,idepthx,coverage,qcmint,qcmaxt) include 'param.nml' include 'param.misc' include 'msg.inc' parameter (lt2=l*120*2) dimension f1(120,l),f2(l),f3(121),f4(121),work(lt2) dimension fp(400),fp1(400) 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/ inita , initb , arowl , iterp , iterc , igflg 1 , imsg , uvmsg , icyc , displ , dispc , cstop common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),zct,itc common /plzsmax/zsmx,mintop c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) 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/ jswt=1 ioffp=0 spval=0. ilab=0 ilab=1 ioffm=1 iswt=1 iflv=1 ivrt=0 itc=1 zct=1. + float(l-1) litarfl=1 c ix0=4 c ix1=4 c iz0=1 c iz1=0 incx=2 ! density of vector in x direction incz=2 ! density of vector in z direction inita=4 initb=4 ccccccccccccccccccccccccccccccccccccccccccccccc c contour plots of LWC distribution follow ccccccccccccccccccccccccccccccccccccccccccccccc c scales for plot xm0=0. xm1=120./100. !convert to [g/kg] bot=0. top=float(idepth-1)*dz topx=float(idepthx-1)*dz iflg=36 #if (COLORPL == 1) ccccccccccccccccccccccccccccc create values for color map ipal =4 !colorpalete nclev=50 !number of isolines ilabl=0 !number of line labels zmin1=0. !minimum values zmax1=float(np*mp) !maximum values izval1=0 !flag for min, max values ihlg1=0 !high/low labels ihcg1=0 !hachuring flags call sflush vps=-1. !width/height ratio * (-1.) c vps=-(t2x-t1x)/(t2z-t1z) !vps=-1.5 - sample value ccccccccccccccccccccccccccccc c plot color isolines, labels call colorpl(f1,120,120,l,idepth,ism,3, . iflg,vps,nclev,ipal,ilabl,zmin1,zmax1,izval1,ihlg1,ihcg1) ccccccccccccccccccccccccccccc #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) ccccccccccccccccccccccccccccc do i=1,121 f3(i)=float(i-1)/100. ! [g/kg] f4(i)=float(idepthx-1)*dz ! mean cloud height [m] enddo call curved(f3,f4,121) do i=1,idepth f4(i)=float(i-1)*dz enddo call gsln(2) c call curved(f2(1:idepth),f4(1:idepth),idepth) call curved(f2,f4,idepth) Cwc=2.4e-3 print * Cw=4.07e-5*tbase+1.45e-3 print *,'Cw: 4.07e-5*tbase+1.45e-3 :',Cw Cw=-4.25e-7*tbase**2+5.36e-5*tbase+1.4e-3 print *,'Cw: -4.25e-7*tbase**2+5.36e-5*tbase+1.4e-3 :',Cw do i=1,idepth f3(i)=1.e-3+Cwc*float(i-1)*dz f4(i)=float(i-1)*dz enddo call gsln(2) c call curved(f3(1:idepth),f4(1:idepth),idepth) call curved(f3,f4,idepth) do i=1,idepth f3(i)=1.e-3+Cw*float(i-1)*dz enddo call gsln(1) c call curved(f3(1:idepth),f4(1:idepth),idepth) call curved(f3,f4,idepth) ccccccccccccccccccccccccccccc call gaseti('LTY',1) call labmod('(f6.2)','(f6.2)',6,6,1,1,20,20,0) call gridal (5,10,5,2,1,1,5,0.,0.) x2=float(120) y2=float(l) 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-.125 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') call plchhq(xc,cfuy(yxl),'LWC (g/m^3)',.015, 0.,0.) call plchhq(cfux(xyl),yc,'H above cloud base (m)',.015,90.,0.) write (lhead,535) time 535 format('Histogram of LWC with height at time= ',f7.2) call plchhq(xc,cfuy(ypl),lhead(1:45),0.0125,0.,0.) ccccccccccccccccccccccccccccc xpl=0.70 ypl=0.85 call plchhq(cfux(xpl),cfuy(ypl),'CLOUD MEAN STAT',0.0125,0.,0.) ypl=0.82 write (lhead,536) coverage call plchhq(cfux(xpl),cfuy(ypl),lhead(1:21),0.0125,0.,0.) ypl=0.79 write (lhead,537) int(qcmint) call plchhq(cfux(xpl),cfuy(ypl),lhead(1:21),0.0125,0.,0.) ypl=0.76 write (lhead,538) int(qcmaxt) call plchhq(cfux(xpl),cfuy(ypl),lhead(1:21),0.0125,0.,0.) ypl=0.73 write (lhead,539) tbase call plchhq(cfux(xpl),cfuy(ypl),lhead(1:21),0.0125,0.,0.) ypl=0.70 write (lhead,540) cw call plchhq(cfux(xpl),cfuy(ypl),lhead(1:21),0.0125,0.,0.) 536 format('- coverage [%] ',f5.1) 537 format('- base [m] ',i4) 538 format('- top [m] ',i4) 539 format('- base temp.[C] ',f4.1) 540 format('- Cw ',f7.5) ccccccccccccccccccccccccccccc c call bndary call frame ccccccccccccccccccccccccccccccccccccccccccccccc c contour plots of LWC 5 - levels distrib. ccccccccccccccccccccccccccccccccccccccccccccccc c scales for plot xm0=0. xm1=120./100. bot=0. top=float(idepth-1)*dz topx=float(idepthx-1)*dz iflg=36 ccccccccccccccccccccccccccccc create values for color map call sflush vps=-1. !width/height ratio * (-1.) c vps=-(t2x-t1x)/(t2z-t1z) !vps=-1.5 - sample value 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) ccccccccccccccccccccccccccccc do i=1,121 f3(i)=float(i-1)/100. f4(i)=float(idepth-1)*dz*1.0 enddo call curved(f3,f4,121) do i=1,121 f4(i)=float(idepth-1)*dz*0.8 enddo call curved(f3,f4,121) do i=1,121 f4(i)=float(idepth-1)*dz*0.6 enddo call curved(f3,f4,121) do i=1,121 f4(i)=float(idepth-1)*dz*0.4 enddo call curved(f3,f4,121) do i=1,121 f4(i)=float(idepth-1)*dz*0.2 enddo call curved(f3,f4,121) do i=1,idepth f4(i)=float(i-1)*dz enddo call gsln(2) c call curved(f2(1:idepth),f4(1:idepth),idepth) call curved(f2,f4,idepth) f1_m1=0. f1_m2=0. f1_m3=0. f1_m4=0. f1_m5=0. f2_m1=0. f2_m2=0. f2_m3=0. f2_m4=0. f2_m5=0. id5=idepth/5 do j=1,120 flwc=float(j)/100. do i=0*id5+1,1*id5 f1_m1=f1_m1+f1(j,i) f2_m1=f2_m1+f1(j,i)*flwc enddo do i=1*id5+1,2*id5 f1_m2=f1_m2+f1(j,i) f2_m2=f2_m2+f1(j,i)*flwc enddo do i=2*id5+1,3*id5 f1_m3=f1_m3+f1(j,i) f2_m3=f2_m3+f1(j,i)*flwc enddo do i=3*id5+1,4*id5 f1_m4=f1_m4+f1(j,i) f2_m4=f2_m4+f1(j,i)*flwc enddo do i=4*id5+1,5*id5 f1_m5=f1_m5+f1(j,i) f2_m5=f2_m5+f1(j,i)*flwc enddo enddo fm1=f2_m1/f1_m1 fm2=f2_m2/f1_m2 fm3=f2_m3/f1_m3 fm4=f2_m4/f1_m4 fm5=f2_m5/f1_m5 print *,'LWC - LEV:',id5,fm1,fm2,fm3,fm4,fm5 print *,'Z - LEV:',f4(idepth/10),f4(3*idepth/10),f4(5*idepth/10), . f4(7*idepth/10),f4(9*idepth/10) print *,'Z - IND:',idepth/10,3*idepth/10,5*idepth/10,7*idepth/10, . 9*idepth/10 do i=1,idepth print *,'F4:',i,f4(i) enddo CALL GSMK(4) ! polymarker type (dot, plus, asterisk, circle or cross) ! < 0 - implementation idependent (not used in NCAR GKS) ! 1 - . (dot) ! 2 - + (plus) ! 3 - * (asterisk) ! 4 - o (circle) ! 5 - X (cross) !>= 6 - reserved - registration or future standardization c CALL GSPMCI(1) ! Index of color table that is used to color polymarkers ! Index 0 - background color. Index 1 - foreground color. CALL GSMKSC(1.) ! Size of the marker (dot polymarker cannot be resized) ! Scale factor >=0. Default: 1. c call point(fm1,f4(1*idepth/10)) c call point(fm2,f4(3*idepth/10)) c call point(fm3,f4(5*idepth/10)) c call point(fm4,f4(7*idepth/10)) c call point(fm5,f4(9*idepth/10)) CALL GPM(1,fm1,f4(1*idepth/10)) CALL GPM(1,fm2,f4(3*idepth/10)) CALL GPM(1,fm3,f4(5*idepth/10)) CALL GPM(1,fm4,f4(7*idepth/10)) CALL GPM(1,fm5,f4(9*idepth/10)) ccccccccccccccccccccccccccccc Cwc=2.4e-3 print * Cw=4.07e-5*tbase+1.45e-3 print *,'Cw: 4.07e-5*tbase+1.45e-3 :',Cw Cw=-4.25e-7*tbase**2+5.36e-5*tbase+1.4e-3 print *,'Cw: -4.25e-7*tbase**2+5.36e-5*tbase+1.4e-3 :',Cw do i=1,idepth f3(i)=1.e-3+Cwc*float(i-1)*dz f4(i)=float(i-1)*dz enddo call gsln(2) c call curved(f3(1:idepth),f4(1:idepth),idepth) call curved(f3,f4,idepth) do i=1,idepth f3(i)=1.e-3+Cw*float(i-1)*dz enddo call gsln(1) c call curved(f3(1:idepth),f4(1:idepth),idepth) call curved(f3,f4,idepth) ccccccccccccccccccccccccccccc call gaseti('LTY',1) call labmod('(f6.2)','(f6.2)',6,6,1,1,20,20,0) call gridal (5,10,5,2,1,1,5,0.,0.) x2=float(120) y2=float(l) 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-.125 yxl=yvpb-.08 ypl=0.98 call pcsetc('FC - FUNCTION CODE CHARACTER','?') call plchhq(xc,cfuy(yxl),'LWC (g/m^3)',.015, 0.,0.) call plchhq(cfux(xyl),yc,'H above cloud base (m)',.015,90.,0.) write (lhead,535) time call plchhq(xc,cfuy(ypl),lhead(1:45),0.0125,0.,0.) ccccccccccccccccccccccccccccc xpl=0.70 ypl=0.45 call plchhq(cfux(xpl),cfuy(ypl),'CLOUD MEAN STAT',0.0125,0.,0.) ypl=0.42 write (lhead,536) coverage call plchhq(cfux(xpl),cfuy(ypl),lhead(1:21),0.0125,0.,0.) ypl=0.39 write (lhead,537) int(qcmint) call plchhq(cfux(xpl),cfuy(ypl),lhead(1:21),0.0125,0.,0.) ypl=0.36 write (lhead,538) int(qcmaxt) call plchhq(cfux(xpl),cfuy(ypl),lhead(1:21),0.0125,0.,0.) ypl=0.33 write (lhead,539) tbase call plchhq(cfux(xpl),cfuy(ypl),lhead(1:21),0.0125,0.,0.) ypl=0.30 write (lhead,540) cw call plchhq(cfux(xpl),cfuy(ypl),lhead(1:21),0.0125,0.,0.) ccccccccccccccccccccccccccccc c call bndary call frame ccccccccccccccccccccccccccccccccccccccccccccccc c contour plots of LWP distribution follow ccccccccccccccccccccccccccccccccccccccccccccccc c scales for plot xm0=0. xm1=400. bot=0. top=0. dfp=1./1. ! [g/m**2] c dfp=1./0.001 ! [kg/m**2] do i=1,400 fp(i)=fp(i)*dfp !histogram if(xm0.eq.0. .and. fp(i ).gt.0. ) xm0=float(i ) !min LWP if(xm1.eq.400. .and. fp(400-i+1).gt.0. ) xm1=float(400-i+1) !max LWP top=amax1(top,fp(i)) !max hist c print *,'LWP1:',i,fp(i) enddo c print *,'LWP: top, min, max',top,xm0,xm1 if( (xm1-xm0).eq.0. ) then xm0=xm0*0.8 xm1=xm1*1.2 endif top=1.2*top call set (xvpl,xvpr,yvpb,yvpt,xm0,xm1,bot,top,lnlg) call gstxci(1) call gsplci(1) call gaseti('LTY',1) call labmod('(f6.2)','(f6.2)',6,6,1,1,20,20,0) call gridal (5,10,5,2,1,1,5,0.,0.) ihist=int(xm1)-int(xm0)+1 do i=int(xm0),int(xm1) ip=i-int(xm0)+1 f3(ip)=float(i) fp1(ip)=fp(i) enddo c call curved(f3(int(xm0):int(xm1)),fp(int(xm0):int(xm1)),ihist) call curved(f3,fp1,ihist) call pcsetc('FC - FUNCTION CODE CHARACTER','?') xpl=0.5 ypl=0.1 call plchhq(cfux(xpl),cfuy(ypl),'LWP (g/m^2)',.015, 0.,0.) xpl=0.07 ypl=0.5 call plchhq(cfux(xpl),cfuy(ypl),'#/LWP_tot/dLWP',.015,90.,0.) write (lhead,545) time 545 format('Histogram of LWP at time= ',f7.2) xpl=0.5 ypl=0.97 call plchhq(cfux(xpl),cfuy(ypl),lhead(1:35),0.0125,0.,0.) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c call bndary call frame return end subroutine xzplot(jc,isy,f,u,w,n1,n3,ivctpl,iflg,nclv) include 'param.nml' include 'param.misc' 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/ inita , initb , arowl , iterp , iterc , igflg 1 , imsg , uvmsg , icyc , displ , dispc , cstop common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),zct,itc c data tp/2000*0./ common /plzsmax/zsmx,mintop c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) 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/ c print *,'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 c iz0=1 c iz1=0 incx=2 ! 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 xml=1.e3 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) ntp=n3-ke nbt=1+ks top=(ntp-1)*dz/zlam bot=(nbt-1)*dz/zlam botzb=(nbt-1)*dz/zb c i1=int(102.4+409.6) c ipt1=int(192.8+819.2) c ipt2=int(192.8+819.2)-50 cccccccccccccccccccccccccccccc c contour plots follow cccccccccccccccccccccccccccccc create topography for mapping purposes 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 end do 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 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 call set(t1x,t2x,t1z,t2z,xm0,xm1,bot,top,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=xzcol(2,iflagc) cnt=(cmx-cmn)/float(nclv) else c nclv=xzcol(2,iflagc) call contin(f,cmn,cmx,cnt,nclv,n,l) 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 do i=1+is,n1-ie tp(i-is)=(zs(i,jc)+zs(i,jc+isy))*zlam2 tp(i-is)=max(bot,tp(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 setusv('LW',1000) endif call gaseti('LTY',1) call labmod('(f6.2)','(f6.2)',6,6,1,1,20,20,0) call gridal (5,10,5,2,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','?') call plchhq(xc,cfuy(yxl),'x (km)',.015, 0.,0.) call plchhq(cfux(xyl),yc,'z (km)',.015,90.,0.) c call plchhq(xc,cfuy(yxl),'x/a',.015, 0.,0.) c call plchhq(cfux(xyl),yc,'z/z\B1\c\N',.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 'param.misc' 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/ inita , initb , arowl , iterp , iterc , igflg 1 , imsg , uvmsg , icyc , displ , dispc , cstop common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),zct,itc c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0 common /plzsmax/zsmx,mintop common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) 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. 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=3 c iz0=1 c iz1=0 incz=2 inita=4 initb=4 c zlam=1.e3 xml=1.e3 xm0=-((n2-1-2*js)*0.5*dy/xml) xm1=+((n2-1-2*je)*0.5*dy/xml) c xm0=-((jcc-1-js)*dy/xml) c xm1=+((n2-jcc-je)*dy/xml) ntp=n3-ke nbt=1+ks top=(ntp-1)*dz/zlam bot=(nbt-1)*dz/zlam botzb=(nbt-1)*dz/zb c i1=int(102.4+409.6) c ipt1=int(192.8+819.2) c ipt2=int(192.8+819.2)-50 ccccccccccccccccccccccccccccccccc c contour plots follow ccccccccccccccccccccccccccccccccc create topography for mapping purposes 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 end do 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 iflagc=iflg endif #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) 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 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+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) #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 if((zsmx.gt.mintop).and.(zsmx.gt.bot)) then zlam2=.5/zlam dyxml=dy/xml 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)) xp(j-js)=(j-(j3+js))*dyxml+xm0 end do call setusv('LW',2000) call dashdc('$$$$$$$$$$$$$$$$$$$$',10,12) call curved(xp,tp,n2-(js+je)) call setusv('LW',1000) endif call gaseti('LTY',1) call labmod('(f6.2)','(f6.2)',6,6,1,1,20,20,0) call gridal (5,10,4,5,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','?') call plchhq(xc,cfuy(yxl),'y (km)' ,0.015, 0.,0.) call plchhq(cfux(xyl),yc,'z (km)' ,0.015,90.,0.) c call plchhq(xc,cfuy(yxl),'y/R -->',0.015, 0.,0.) c call plchhq(cfux(xyl),yc,'z/R -->',0.015,90.,0.) c call plchhq(xc,cfuy(yxl),'y/a' ,0.015, 0.,0.) c call plchhq(cfux(xyl),yc,'z/z\B1\c\N',.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 'param.misc' include 'msg.inc' parameter (nm2=n*m*2) dimension f(n1,n2),u(n1,n2),v(n1,n2),work(nm2),zs(n,m) 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/ inita , initb , arowl , iterp , iterc , igflg 1 , imsg , uvmsg , icyc , displ , dispc , cstop common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/topog/ tp(2000),zct,itc c common/gora/ xml1,yml1,amp,icc,jcc common/gora/ xml1,yml1,amp,xml0,yml0 common /plzsmax/zsmx,mintop common/metric/ zs0(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) 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/ jswt=1 spval=0. ioffp=0 iflv=1 ivrt=0 do i=1,2000 tp(i)=0. enddo do i=1,n1 do j=1,n2 zs(i,j)=zs0(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 c ix0=4 c ix1=4 c iy0=4 c iy1=4 incx=2 incy=2 inita=4 initb=4 c xml=1.e3 yml=1.e3 xm0=-((n1-1-2*is)*0.5*dx/xml) xm1=+((n1-1-2*ie)*0.5*dx/xml) ym0=-((n2-1-2*js)*0.5*dy/yml) ym1=+((n2-1-2*je)*0.5*dy/yml) c xm0=-((icc-1-is)*dx/xml) c xm1=+((n1-icc-ie)*dx/xml) c ym0=-((jcc-1-js)*dy/yml) c ym1=+((n2-jcc-je)*dy/yml) c i1=int(102.4+409.6) c ipt1=int(192.8+819.2) c ipt2=int(192.8+819.2)-50 cccccccccccccccccccccccccccccccc c contour plots follow cccccccccccccccccccccccccccccccc 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 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,0, . 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(zs(1+is,1+js),n1,n1-(is+ie),n2-(js+je), . cgr0,cgrt,cgri,-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 call gaseti('LTY',1) call labmod('(f6.2)','(f6.2)',6,6,1,1,20,20,0) call gridal (5,10,4,10,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','?') call plchhq(xc,cfuy(yxl),'x (km) ',0.015, 0.,0.) call plchhq(cfux(xyl),yc,'y (km) ',0.015,90.,0.) c call plchhq(xc,cfuy(yxl),'x/R -->',0.015, 0.,0.) c call plchhq(cfux(xyl),yc,'y/R -->',0.015,90.,0.) 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 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 xyzplot(f,zs3,n1,n2,n3,iflg) include 'param.nml' include 'param.misc' 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.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 if(iflg.eq.56) write (lhead,56) time if(iflg.eq.57) write (lhead,57) time 1 format(' at time= ',f9.2) 2 format(' at time= ',f9.2) 3 format(' at time= ',f9.2) 4 format(' at time= ',f9.2) 41 format(' at time= ',f9.2) 5 format(' at time= ',f9.2) 6 format(' 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) 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) 56 format('red scalar at time= ',f9.2) 57 format('blue scalar 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.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 if(iflg.eq.56) write (lhead,256) time,jc if(iflg.eq.57) write (lhead,257) time,jc 201 format('theta perturbation at time= ',f9.2,' j=',i4) c 202 format('isentropes at time= ',f9.2,' j=',i4) 202 format('log isentropes at time= ',f9.2,' j=',i4) 203 format('press perturbation at time= ',f9.2,' j=',i4) 204 format('u perturbation at time= ',f9.2,' j=',i4) 2041 format('v perturbation at time= ',f9.2,' j=',i4) 205 format('omega at time= ',f9.2,' j=',i4) 206 format('w 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) 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) 256 format('red scalar at time= ',f9.2,' j=',i4) 257 format('blue scalar 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.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 if(iflg.eq.56) write (lhead,356) time,ic if(iflg.eq.57) write (lhead,357) time,ic 301 format('theta perturbation at time= ',f9.2,' i=',i4) 302 format('isentropes at time= ',f9.2,' i=',i4) 303 format('press perturbation at time= ',f9.2,' i=',i4) 304 format('u perturbation at time= ',f9.2,' i=',i4) 3041 format('v perturbation at time= ',f9.2,' i=',i4) 305 format('omega at time= ',f9.2,' i=',i4) 306 format('w 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) 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) 356 format('red scalar at time= ',f9.2,' i=',i4) 357 format('blue scalar 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.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 if(iflg.eq.56) write (lhead,456) time,kc if(iflg.eq.57) write (lhead,457) time,kc 401 format('theta perturbation at time= ',f9.2,' k=',i4) 402 format('isentropes at time= ',f9.2,' k=',i4) 403 format('press perturbation at time= ',f9.2,' k=',i4) 404 format('u perturbation at time= ',f9.2,' k=',i4) 4041 format('v perturbation at time= ',f9.2,' k=',i4) 405 format('omega at time= ',f9.2,' k=',i4) 406 format('w 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) 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) 456 format('red scalar at time= ',f9.2,' k=',i4) 457 format('blue scalar 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 if(iplf.eq.6) then if(iflg.eq.33) write (lhead,533) time if(iflg.eq.34) write (lhead,534) time if(iflg.eq.35) write (lhead,535) time if(iflg.eq.36) write (lhead,536) time if(iflg.eq.37) write (lhead,537) time if(iflg.eq.38) write (lhead,538) time 533 format('CAPE at time= ',f9.2) 534 format('CIN at time= ',f9.2) 535 format('Time evolution of U at time= ',f9.2) 536 format('Time evolution of V at time= ',f9.2) 537 format('Time evolution of W at time= ',f9.2) 538 format('Time evolution of Th at time= ',f9.2) endif C 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) c 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) c print *,'fxmin,fxmax:',fxmin,fxmax c 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 zbiory_v5d(th,u,v,om,w,p,div,qv,qc,qr,qia,qib, 1 tke,rhf,n1,n2,n3,inr) include 'param.nml' include 'param.misc' include 'msg.inc' dimension u(1-ih:np+ih,1-ih:mp+ih,l), . v(1-ih:np+ih,1-ih:mp+ih,l), . om(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), . p(1-ih:np+ih,1-ih:mp+ih,l), . div(1-ih:np+ih,1-ih:mp+ih,l), . rhf(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), . 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) 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, 7) 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), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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,hlatv,hlats,hlatf common/sgscnst/ ceps,cL,cm,cs,prndt common/stresd/ ivis,irid,idiagstr(2),diagstr(8) 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 MISSING integer IMISSING parameter (MISSING=1.0E35) parameter (IMISSING=-987654) C------------------- C Rest declarations C------------------- parameter (NVARS=30) parameter (NTIMES=1) parameter (NROWS=200) parameter (NCOLUMNS=200) parameter (NLEVELS=100) integer nr, nc, nl(NVARS) integer numtimes integer numvars character*10 varname(NVARS) integer dates(1) integer times(1) integer compressmode integer projection real proj_args(100) integer vertical real vert_args(NLEVELS) c-------------- c Local varlues c-------------- character*13 outname character*2 outn data ibupl/1/,ithpl/1/,iprpl/1/, 1 iuvpl/1/,ivvpl/1/,iompl/0/,iwvpl/1/,idvpl/0/,iripl/1/, 1 iqvpl/1/,iqcpl/1/,iqrpl/0/,irhpl/1/,ithvpl/1/,ikmpl/1/, 1 iqial/1/,iqibl/1/ 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*ivis iripl=iripl*irid c------------------------------- c ivar is an total output fields INVARS=ibupl+ithpl+iprpl+iuvpl+ivvpl+iompl+iwvpl+idvpl+ 1 iripl+iqvpl+iqcpl+iqrpl+irhpl+ithvpl+ikmpl+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)') inr else if (inr.lt.100) then write (outn(1:2), '(I2)') inr else outn(1:2)='9Q' endif outname(2:3)=outn(1:2) outname(4:13)='output.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) conwert axis left iconv=1 iconv=1 if(itwo.eq.0) then nr=n1 nc=n2 if(j3.eq.0) then nr=2 nc=n1 else if(iconv.eq.1) then nr=n2 nc=n1 endif endif do i=1,INVARS nl(i)=n3 enddo else nr=nnv nc=mv if(j3.eq.0) then nr=2 nc=nnv else if(iconv.eq.1) then nr=mv nc=nnv endif endif do i=1,INVARS nl(i)=lv enddo endif cprojection mode projection=0 if(itwo.eq.0) then ast=1. nn2=n2 nn1=n1 ddy=dy ddx=dx else ast=2. nn2=mv nn1=nnv ddy=ast*dy ddx=ast*dx endif if(j3.eq.1) then if(iconv.eq.1) then proj_args(1)=(nn2-1)*ddy proj_args(2)=(nn1-1)*ddx proj_args(3)=ddy proj_args(4)=ddx else proj_args(1)=(nn1-1)*ddx proj_args(2)=(nn2-1)*ddy proj_args(3)=ddx proj_args(4)=ddy endif endif if(j3.eq.0) then proj_args(1)=1. proj_args(2)=(nn1-1)*ddx proj_args(3)=1. proj_args(4)=ddx endif cvertical coordinate system vertical=0 vert_args(1)=0. vert_args(2)=ast*dz 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)='theta pert' i=i+1 endif if(iprpl.eq.1) then varname(i)='p/rho pert' i=i+1 endif if(iuvpl.eq.1) then varname(i)='U' i=i+1 endif if(ivvpl.eq.1) then varname(i)='V' i=i+1 endif if(iompl.eq.1) then varname(i)='omega' i=i+1 endif if(iwvpl.eq.1) then varname(i)='W' 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 *,'LICZBA PLIKOW DO ZAPISU:',i,' INVAR:',INVARS c-------------------------------------------------------------- c Create the v5d file. c------------------------- 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' 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 c-------------------------------- check if compute topografy needed sumtopo=0. do j=1,m do i=1,n sumtopo=sumtopo+zs(i,j) enddo enddo itrans=0 if(sumtopo.gt.1.) itrans=1 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 i=1,n do j=1,m do k=1,l fxyz(i,j,k)= th(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,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE buo FAILED' endif iv=iv+1 endif c------------------------ c Potential temperature c------------------------ if(ithpl.eq.1) then do i=1,n do j=1,m do k=1,l c fxyz(i,j,k)= alog(th(i,j,k)) fxyz(i,j,k)= th(i,j,k) enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE th FAILED' endif iv=iv+1 endif c------------------------ c Presure perturbation c------------------------ if(iprpl.eq.1) then do i=1,n do j=1,m do k=1,l fxyz(i,j,k)= p(i,j,k)*2.*dti enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE p/rho FAILED' 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 v5dwrite0(fxyz0,iconv,iv,it,no) else call v5dwrite0(u ,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE u_per FAILED' 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 v5dwrite0(fxyz0,iconv,iv,it,no) else call v5dwrite0(v ,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE v_per FAILED' endif iv=iv+1 endif c------------------------ c Omega - v e l o c i t y c------------------------ if(iompl.eq.1) then if(itrans.eq.1) then call transform(om,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,no) else call v5dwrite0(om ,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE om FAILED' 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 v5dwrite0(fxyz0,iconv,iv,it,no) else call v5dwrite0(w ,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE w_per FAILED' endif iv=iv+1 endif c------------------------ c D i v e r g e n c e c------------------------ if(idvpl.eq.1) then do i=1,n do j=1,m do k=1,l 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,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE div_e FAILED' endif iv=iv+1 endif c-------------------------- c Water vapour mixong ratio c-------------------------- if(iqvpl.eq.1) then do i=1,nms do j=1,mms do k=1,lms 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,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE qv FAILED' endif iv=iv+1 endif c------------------------ c Cloud water mixing ratio c------------------------ if(iqcpl.eq.1) then do i=1,nms do j=1,mms do k=1,lms 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,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE qc FAILED' endif iv=iv+1 endif c------------------------- c Rain water mixing ratio c------------------------- if(iqrpl.eq.1) then do i=1,nms do j=1,mms do k=1,lms 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,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE qr FAILED' endif iv=iv+1 endif c------------------------- c Ice A mixing ratio c------------------------- if(iqial.eq.1) then do i=1,nic do j=1,mic do k=1,lic 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,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE qia FAILED' endif iv=iv+1 endif c------------------------- c Ice B mixing ratio c------------------------- if(iqibl.eq.1) then do i=1,nic do j=1,mic do k=1,lic 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,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE qib FAILED' endif iv=iv+1 endif c------------------------ c Relative - humidity c------------------------ if(irhpl.eq.1) then do i=1,nms do j=1,mms do k=1,lms 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,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE rhf FAILED' 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 i=1,n do j=1,m do k=1,l fxyz(i,j,k)=th(i,j,k)+epsb*qv(i,j,k)*th0(i,j,k) enddo enddo enddo else do i=1,n do j=1,m do k=1,l 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,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE thv FAILED' 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 i=1,nkv do j=1,mkv do k=1,lkv 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 enddo enddo enddo if(itrans.eq.1) then call transform(fxyz,fxyz0,100) call v5dwrite0(fxyz0,iconv,iv,it,no) else call v5dwrite0(fxyz,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE tke_e FAILED' 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,no) else call v5dwrite0(ri ,iconv,iv,it,no) endif if (no .eq. 0) then print *,'WRITE ri FAILED' endif iv=iv+1 endif enddo c------------------------------------------------------------- c close the v5d file and exit c-------------------------------- no = v5dclose() if (no .eq. 0) then print *,'V5D_FILE NOT SAVED __ SAVING FAILED' endif return end subroutine v5dwrite0(f,iconv,IV,IT,ierr) include 'param.nml' include 'param.misc' include 'msg.inc' 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) dimension fxyz(n,m,l),fyxz(m,n,l),fn(2,n,l) dimension fxyz1(nnv,mv,lv),fyxz1(mv,nnv,lv),fn1(2,nnv,lv) integer v5dwrite if(itwo.eq.0) then if(j3.eq.0) then do i=1,n do k=1,l fn(1,i,k)=f(i,1,k) fn(2,i,k)=f(i,1,k) enddo enddo ierr = v5dwrite( IT, IV, fn ) else if(iconv.eq.1) then do i=1,n do j=1,m do k=1,l fyxz(m+1-j,i,k)=f(i,j,k) enddo enddo enddo ierr = v5dwrite( IT, IV, fyxz ) else do i=1,n do j=1,m do k=1,l fxyz(i,j,k)=f(i,j,k) enddo enddo enddo ierr = v5dwrite( IT, IV, fxyz ) endif endif else do i=1,nnv do j=1,mv do k=1,lv ii=(2*i)-1 jj=(2*j)-1 kk=(2*k)-1 fxyz1(i,j,k)=f(ii,jj,kk) enddo enddo enddo if(j3.eq.0) then do i=1,nnv do k=1,lv fn1(1,i,k)=fxyz1(i,1,k) fn1(2,i,k)=fxyz1(i,1,k) enddo enddo ierr = v5dwrite( IT, IV, fn1 ) else if(iconv.eq.1) then do i=1,nnv do j=1,mv do k=1,lv fyxz1(j,i,k)=fxyz1(i,j,k) enddo enddo enddo ierr = v5dwrite( IT, IV, fyxz1 ) else ierr = v5dwrite( IT, IV, fxyz1) endif endif endif return end subroutine transform(f,ff,iflg) include 'param.nml' include 'param.misc' include 'msg.inc' parameter(n1=n,n2=m,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 common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(1-ih:np+ih,1-ih:mp+ih) data igros/1/ if(iflg.eq.100) then tlo=1.0E35 else if((iflg.eq.4).or.(iflg.eq.41))then tlo=0. else if((iflg.eq.5).or.(iflg.eq.6))then tlo=0. 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,n c do 1 j=1,m 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,m c do 13 i=1,n 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,m do i=1,n 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 return end subroutine continl(f,cmn,cmx,n1,n2,n3) include 'param.nml' include 'param.misc' include 'msg.inc' dimension f(1-ih:np+ih, 1-ih:mp+ih, l) cmx=-1.e10 cmn= 1.e10 do i=1,n1 do j=1,n2 do k=1,n3 cmx=amax1(cmx,f(i,j,k)) cmn=amin1(cmn,f(i,j,k)) enddo enddo enddo return end #endif #if (GKS == 1) cinclude(/users/andii/model/graphics/conrec.gks) cinclude(/users/andii/model/graphics/velvct.gks) include 'conrec.gks' c include 'velvct.gks' #if (SPCTPL == 1) cinclude(/users/andii/model/graphics/cfftpack.f) c include 'cfftpack.f' #endif #if (COLORPL == 1) cinclude(/users/andii/model/graphics/colorpl.gks) include 'colorpl.gks' #endif #endif '\eof' cat > conrec.gks<< '\eof' SUBROUTINE CONREC (Z,L,M,N,FLO,HI,FINC,NSET,NHI,NDOT) C C C EXTERNAL CONBD C SAVE CHARACTER*1 IGAP ,ISOL ,RCHAR CHARACTER ENCSCR*22 ,IWORK*252 DIMENSION LNGTHS(5) ,HOLD(5) ,WNDW(4) ,VWPRT(4) DIMENSION Z(L,N) ,CL(80) ,RWORK(80) ,LASF(13) C COMMON /INTPR/ PAD1, FPART, PAD(8) COMMON/INTPR/IPAU,FPART,TENSN,NP1,SMALL,L1,ADDLR,ADDTB,MLLINE, 1 ICLOSE COMMON /SMOLAB/ ISWIT,ILABS, IOFFMS COMMON /SMOSPV/ SPVAS,JSWIT, IOFFPS COMMON /CONRE1/ IOFFP ,SPVAL COMMON /CONRE3/ IXBITS ,IYBITS COMMON /CONRE4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP , 1 NCRT ,ILAB ,NULBLL ,IOFFD , 2 EXT ,IOFFM ,ISOLID ,NLA , 3 NLM ,XLT ,YBT ,SIDE COMMON /CONRE5/ SCLY COMMON /RECINT/ IRECMJ ,IRECMN ,IRECTX DATA LNGTHS(1),LNGTHS(2),LNGTHS(3),LNGTHS(4),LNGTHS(5) 1 / 12, 3, 20, 9, 17 / DATA ISOL, IGAP /'$', ''''/ C C ISOL AND IGAP (DOLLAR-SIGN AND APOSTROPHE) ARE USED TO CONSTRUCT PAT- C TERNS PASSED TO ROUTINE DASHDC IN THE SOFTWARE DASHED-LINE PACKAGE. C C C C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR C CALL Q8QST4 ('GRAPHX','CONREC','CONREC','VERSION 01') C C NONSMOOTHING VERSION C IF(ISWIT.EQ.1) THEN IOFFM=IOFFMS ILAB=ILABS ENDIF IF(JSWIT.EQ.1) THEN IOFFP=IOFFPS SPVAL=SPVAS ENDIF C C C CALL RESET FOR COMPATIBILITY WITH ALL DASH ROUTINES(EXCEPT DASHLINE) C CALL RESET C C GET NUMBER OF BITS IN INTEGER ARITHMETIC C IARTH = I1MACH(8) IXBITS = 0 DO 101 I=1,IARTH IF (M .LE. (2**I-1)) GO TO 102 IXBITS = I+1 101 CONTINUE 102 IYBITS = 0 DO 103 I=1,IARTH IF (N .LE. (2**I-1)) GO TO 104 IYBITS = I+1 103 CONTINUE 104 IF ((IXBITS*IYBITS).GT.0 .AND. (IXBITS+IYBITS).LE.24) GO TO 105 C C REPORT ERROR NUMBER ONE C IWORK = 'CONREC - DIMENSION ERROR - M*N .GT. (2**IARTH) M = + N = ' WRITE (IWORK(56:62),'(I6)') M WRITE (IWORK(73:79),'(I6)') N CERR CALL SETER( IWORK, 1, 1 ) RETURN 105 CONTINUE C C INQUIRE CURRENT TEXT AND LINE COLOR INDEX C CALL GQTXCI ( IERR, ITXCI ) CALL GQPLCI ( IERR, IPLCI ) C C Set requested text color. C CALL GSTXCI(IRECTX) C C SET LINE AND TEXT ASF TO INDIVIDUAL C CALL GQASF ( IERR, LASF ) LSV3 = LASF(3) LSV10 = LASF(10) LASF(3) = 1 LASF(10) = 1 CALL GSASF ( LASF ) C GL = FLO HA = HI GP = FINC MX = L NX = M NY = N IDASH = NDOT NEGPOS = ISIGN(1,IDASH) IDASH = IABS(IDASH) IF (IDASH.EQ.0 .OR. IDASH.EQ.1) IDASH = ISOLID C C SET CONTOUR LEVELS. C CALL CLGEN (Z,MX,NX,NY,GL,HA,GP,NLA,NLM,CL,NCL,ICNST) C C FIND MAJOR AND MINOR LINES C IF (ILAB .NE. 0) CALL REORD (CL,NCL,RWORK,NML,NULBLL+1) IF (ILAB .EQ. 0) NML = 0 C C SAVE CURRENT NORMALIZATION TRANS NUMBER NTORIG AND LOG SCALING FLAG C CALL GQCNTN ( IERR, NTORIG ) CALL GETUSV ('LS',IOLLS) C C SET UP SCALING C CALL GETUSV ( 'YF' , IYVAL ) SCLY = 1.0 / ISHIFT ( 1, 15 - IYVAL ) C IF (NSET) 106,107,111 106 CALL GQNT ( NTORIG,IERR,WNDW,VWPRT ) X1 = VWPRT(1) X2 = VWPRT(2) Y1 = VWPRT(3) Y2 = VWPRT(4) C C SAVE NORMALIZATION TRANS 1 C CALL GQNT (1,IERR,WNDW,VWPRT) C C DEFINE NORMALIZATION TRANS AND LOG SCALING C CALL SET(X1, X2, Y1, Y2, 1.0, FLOAT(NX), 1.0, FLOAT(NY), 1) GO TO 111 107 CONTINUE X1 = XLT X2 = XLT+SIDE Y1 = YBT Y2 = YBT+SIDE X3 = NX Y3 = NY IF (AMIN1(X3,Y3)/AMAX1(X3,Y3) .LT. EXT) GO TO 110 IF (NX-NY) 108,110,109 108 X2 = SIDE*X3/Y3+XLT GO TO 110 109 Y2 = SIDE*Y3/X3+YBT C C SAVE NORMALIZATION TRANS 1 C 110 CALL GQNT ( 1, IERR, WNDW, VWPRT ) C C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING C CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) C C DRAW PERIMETER C CALL PERIM (NX-1,1,NY-1,1) 111 IF (ICNST .NE. 0) GO TO 124 C C SET UP LABEL SCALING C IOFFDT = IOFFD IF (GL.NE.0.0 .AND. (ABS(GL).LT.0.1 .OR. ABS(GL).GE.1.E5)) 1 IOFFDT = 1 IF (HA.NE.0.0 .AND. (ABS(HA).LT.0.1 .OR. ABS(HA).GE.1.E5)) 1 IOFFDT = 1 ASH = 10.**(3-IFIX(ALOG10(AMAX1(ABS(GL),ABS(HA),ABS(GP))) 1 -4999.999)-5000) IF (IOFFDT .EQ. 0) ASH = 1. IF (IOFFM .NE. 0) GO TO 115 IWORK ='CONTOUR FROM TO CONTOUR INTERVAL 1 OF PT(3,3)= LABELS SCALED BY' HOLD(1) = GL HOLD(2) = HA HOLD(3) = GP HOLD(4) = Z(3,3) HOLD(5) = ASH NCHAR = 0 DO 114 I=1,5 WRITE ( ENCSCR, '(G13.5)' ) HOLD(I) NCHAR = NCHAR+LNGTHS(I) DO 113 J=1,13 NCHAR = NCHAR+1 IWORK(NCHAR:NCHAR) = ENCSCR(J:J) 113 CONTINUE 114 CONTINUE IF (ASH .EQ. 1.) NCHAR = NCHAR-13-LNGTHS(5) C C WRITE TITLE USING NORMALIZATION TRANS NUMBER 0 C CALL GETUSV('LS',LSO) CALL SETUSV('LS',1) CALL GSELNT (0) CALL WTSTR ( 0.5, 0.015625, IWORK(1:NCHAR), 0, 0, 0 ) CALL SETUSV('LS',LSO) CALL GSELNT (1) C C C C * * * * * * * * * * C * * * * * * * * * * C C C PROCESS EACH LEVEL C 115 FPART = .5 C DO 123 I=1,NCL CALL PLOTIT(0,0,0) CALL GSPLCI ( IRECMJ ) CONTR = CL(I) NDASH = IDASH IF (NEGPOS.LT.0 .AND. CONTR.GE.0.) NDASH = ISOLID C C CHANGE 10 BIT PATTERN TO 10 CHARACTER PATTERN. C DO 116 J=1,10 IBIT = IAND(ISHIFT(NDASH,(J-10)),1) RCHAR = IGAP IF (IBIT .NE. 0) RCHAR = ISOL IWORK(J:J) = RCHAR 116 CONTINUE IF (I .GT. NML) GO TO 121 C C SET UP MAJOR LINE (LABELED) C C C NREP REPITITIONS OF PATTERN PER LABEL. C NCHAR = 10 IF (NREP .LT. 2) GO TO 119 DO 118 J=1,10 NCHAR = J RCHAR = IWORK(J:J) DO 117 K=2,NREP NCHAR = NCHAR+10 IWORK(NCHAR:NCHAR) = RCHAR 117 CONTINUE 118 CONTINUE 119 CONTINUE C C PUT IN LABEL. C CALL ENCD (CONTR,ASH,ENCSCR,NCUSED,IOFFDT) DO 120 J=1,NCUSED NCHAR = NCHAR+1 IWORK(NCHAR:NCHAR) = ENCSCR(J:J) 120 CONTINUE GO TO 122 C C SET UP MINOR LINE (UNLABELED). C 121 CONTINUE C C SET LINE INTENSITY TO LOW C CALL GSPLCI ( IRECMN ) NCHAR = 10 122 CALL DASHDC ( IWORK(1:NCHAR),NCRT, ISIZEL ) C C DRAW ALL LINES AT THIS LEVEL. C CALL STLINE (Z,MX,NX,NY,CONTR) C 123 CONTINUE CALL GSPLCI(IRECMJ) C C FIND RELATIVE MINIMUMS AND MAXIMUMS IF WANTED, AND MARK VALUES IF C WANTED. C IF (NHI .EQ. 0) CALL MINMAX (Z,MX,NX,NY,ISIZEM,ASH,IOFFDT) IF (NHI .GT. 0) CALL MINMAX (Z,MX,NX,NY,ISIZEP,-ASH,IOFFDT) FPART = 1. GO TO 127 124 CONTINUE IWORK = 'CONSTANT FIELD' WRITE( ENCSCR, '(G22.14)' ) GL DO 126 I=1,22 IWORK(I+14:I+14) = ENCSCR(I:I) 126 CONTINUE C C WRITE TITLE USING NORMALIZATION TRNS 0 C CALL GETUSV('LS',LSO) CALL SETUSV('LS',1) CALL GSELNT (0) CALL WTSTR ( 0.09765, 0.48825, IWORK(1:36), 3, 0, -1 ) C C RESTORE NORMALIZATION TRANS 1, LINE AND TEXT INTENSITY TO ORIGINAL C 127 IF (NSET.LE.0) THEN CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) END IF CALL GSPLCI ( IPLCI ) CALL GSTXCI ( ITXCI ) C C SELECT ORIGINAL NORMALIZATION TRANS NUMBER NTORIG, AND RESTORE ASF C CALL GSELNT ( NTORIG ) LASF(3) = LSV3 LASF(10) = LSV10 CALL GSASF ( LASF ) C RETURN C C END SUBROUTINE CLGEN (Z,MX,NX,NNY,CCLO,CHI,CINC,NLA,NLM,CL,NCL,ICNST) SAVE DIMENSION CL(NLM) ,Z(MX,NNY) COMMON /CONRE1/ IOFFP ,SPVAL C C CLGEN PUTS THE VALUES OF THE CONTOUR LEVELS IN CL. C VARIABLE NAMES MATCH THOSE IN CONREC, WITH THE FOLLOWING ADDITIONS. C NCL -NUMBER OF CONTOUR LEVELS PUT IN CL. C ICNST -FLAG TO TELL CONREC IF A CONSTANT FIELD WAS DETECTED. C .ICNST=0 MEANS NON-CONSTANT FIELD. C .ICNST NON-ZERO MEANS CONSTANT FIELD. C C TO PRODUCE NON-UNIFORM CONTOUR LEVEL SPACING, REPLACE THE CODE IN THIS C SUBROUTINE WITH CODE TO PRODUCE WHATEVER SPACING IS DESIRED. C ICNST = 0 NY = NNY CLO = CCLO GLO = CLO HA = CHI FANC = CINC CRAT = NLA IF (HA-GLO) 101,102,111 101 GLO = HA HA = CLO GO TO 111 102 IF (GLO .NE. 0.) GO TO 120 GLO = Z(1,1) HA = Z(1,1) IF (IOFFP .EQ. 0) GO TO 107 DO 106 J=1,NY DO 105 I=1,NX IF (Z(I,J) .EQ. SPVAL) GO TO 105 GLO = Z(I,J) HA = Z(I,J) DO 104 JJ=J,NY DO 103 II=1,NX IF (Z(II,JJ) .EQ. SPVAL) GO TO 103 GLO = AMIN1(Z(II,JJ),GLO) HA = AMAX1(Z(II,JJ),HA) 103 CONTINUE 104 CONTINUE GO TO 110 105 CONTINUE 106 CONTINUE GO TO 110 107 DO 109 J=1,NY DO 108 I=1,NX GLO = AMIN1(Z(I,J),GLO) HA = AMAX1(Z(I,J),HA) 108 CONTINUE 109 CONTINUE 110 IF (GLO .GE. HA) GO TO 119 111 IF (FANC) 112,113,114 112 CRAT = AMAX1(1.,-FANC) 113 FANC = (HA-GLO)/CRAT P = 10.**(IFIX(ALOG10(FANC)+5000.)-5000) FANC = AINT(FANC/P)*P 114 IF (CHI-CLO) 116,115,116 115 GLO = AINT(GLO/FANC)*FANC HA = AINT(HA/FANC)*FANC*(1.+SIGN(1.E-6,HA)) 116 DO 117 K=1,NLM CC = GLO+FLOAT(K-1)*FANC IF (CC .GT. HA) GO TO 118 KK = K CL(K) = CC 117 CONTINUE 118 NCL = KK CCLO = CL(1) CHI = CL(NCL) CINC = FANC RETURN 119 ICNST = 1 NCL = 1 CCLO = GLO RETURN 120 CL(1) = GLO NCL = 1 RETURN END SUBROUTINE DRLINE (Z,L,MM,NN) SAVE DIMENSION Z(L,NN) C C THIS ROUTINE TRACES A CONTOUR LINE WHEN GIVEN THE BEGINNING BY STLINE. C TRANSFORMATIONS CAN BE ADDED BY DELETING THE STATEMENT FUNCTIONS FOR C FX AND FY IN DRLINE AND MINMAX AND ADDING EXTERNAL FUNCTIONS. C X=1. AT Z(1,J), X=FLOAT(M) AT Z(M,J). X TAKES ON NON-INTEGER VALUES. C Y=1. AT Z(I,1), Y=FLOAT(N) AT Z(I,N). Y TAKES ON NON-INTEGER VALUES. C COMMON /CONRE2/ IX ,IY ,IDX ,IDY , 1 IS ,ISS ,NP ,CV , 2 INX(8) ,INY(8) ,IR(2000) ,NR COMMON /CONRE1/ IOFFP ,SPVAL COMMON /CONRE3/ IXBITS ,IYBITS LOGICAL IPEN ,IPENO C COMMON/TOPOG/ CTP(2000),Z0,ITOP C FX(X,Y)=(DXMN+DXD*(X-1.)/(FLOAT(MM)-1.)) C * *COS(THMN+THD*(Y-1.)/(FLOAT(NN)-1.)) C FY(X,Y)=(DXMN+DXD*(X-1.)/(FLOAT(MM)-1.)) C * *SIN(THMN+THD*(Y-1.)/(FLOAT(NN)-1.)) FX(X,Y)=X C FY(X,Y)=Y FY(X,Y)=Y+ITOP*((CTP(IFIX(X))+(IFIX(X)-X)*(CTP(IFIX(X))- 1CTP(IFIX(X+1.))))*(Z0-Y)) C C IXYPAK(IXX,IYY) = ISHIFT(IXX,IYBITS)+IYY C(P1,P2) = (P1-CV)/(P1-P2) C DATA IPEN,IPENO/.TRUE.,.TRUE./ C M = MM N = NN IF (IOFFP .EQ. 0) GO TO 101 ASSIGN 110 TO JUMP1 ASSIGN 115 TO JUMP2 GO TO 102 101 ASSIGN 112 TO JUMP1 ASSIGN 117 TO JUMP2 102 IX0 = IX IY0 = IY IS0 = IS IF (IOFFP .EQ. 0) GO TO 103 IX2 = IX+INX(IS) IY2 = IY+INY(IS) IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL IPENO = IPEN 103 IF (IDX .EQ. 0) GO TO 104 Y = IY ISUB = IX+IDX X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) GO TO 105 104 X = IX ISUB = IY+IDY Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) 105 CALL FRSTD (FX(X,Y),FY(X,Y)) 106 IS = IS+1 IF (IS .GT. 8) IS = IS-8 IDX = INX(IS) IDY = INY(IS) IX2 = IX+IDX IY2 = IY+IDY IF (ISS .NE. 0) GO TO 107 IF (IX2.GT.M .OR. IY2.GT.N .OR. IX2.LT.1 .OR. IY2.LT.1) GO TO 120 107 IF (CV-Z(IX2,IY2)) 108,108,109 108 IS = IS+4 IX = IX2 IY = IY2 GO TO 106 109 IF (IS/2*2 .EQ. IS) GO TO 106 GO TO JUMP1,(110,112) 110 ISBIG = IS+(8-IS)/6*8 IX3 = IX+INX(ISBIG-1) IY3 = IY+INY(ISBIG-1) IX4 = IX+INX(ISBIG-2) IY4 = IY+INY(ISBIG-2) IPENO = IPEN IF (ISS .NE. 0) GO TO 111 IF (IX3.GT.M .OR. IY3.GT.N .OR. IX3.LT.1 .OR. IY3.LT.1) GO TO 120 IF (IX4.GT.M .OR. IY4.GT.N .OR. IX4.LT.1 .OR. IY4.LT.1) GO TO 120 111 IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL .AND. 1 Z(IX3,IY3).NE.SPVAL .AND. Z(IX4,IY4).NE.SPVAL 112 IF (IDX .EQ. 0) GO TO 113 Y = IY ISUB = IX+IDX X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) GO TO 114 113 X = IX ISUB = IY+IDY Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) 114 GO TO JUMP2,(115,117) 115 IF (.NOT.IPEN) GO TO 118 IF (IPENO) GO TO 116 C C END OF LINE SEGMENT C CALL LASTD CALL FRSTD (FX(XOLD,YOLD),FY(XOLD,YOLD)) C C CONTINUE LINE SEGMENT C 116 CONTINUE 117 CALL VECTD (FX(X,Y),FY(X,Y)) 118 XOLD = X YOLD = Y IF (IS .NE. 1) GO TO 119 NP = NP+1 IF (NP .GT. NR) GO TO 120 IR(NP) = IXYPAK(IX,IY) 119 IF (ISS .EQ. 0) GO TO 106 IF (IX.NE.IX0 .OR. IY.NE.IY0 .OR. IS.NE.IS0) GO TO 106 C C END OF LINE C 120 CALL LASTD RETURN END SUBROUTINE MINMAX (Z,L,MM,NN,ISSIZM,AASH,JOFFDT) C C THIS ROUTINE FINDS RELATIVE MINIMUMS AND MAXIMUMS. A RELATIVE MINIMUM C (OR MAXIMUM) IS DEFINED TO BE THE LOWEST (OR HIGHEST) POINT WITHIN C A CERTAIN NEIGHBORHOOD OF THE POINT. THE NEIGHBORHOOD USED HERE C IS + OR - MN IN THE X DIRECTION AND + OR - NM IN THE Y DIRECTION. C C ORIGINATOR DAVID KENNISON C SAVE CHARACTER*7 IA DIMENSION Z(L,NN) C C C COMMON /CONRE1/ IOFFP ,SPVAL COMMON /CONRE5/ SCLY C FX(X,Y) = X FY(X,Y) = Y C M = MM N = NN C C SET UP SCALING FOR LABELS C SIZEM = (ISSIZM + 1)*256*SCLY ISIZEM = ISSIZM C ASH = ABS(AASH) IOFFDT = JOFFDT C IF (AASH .LT. 0.0) GO TO 128 C MN = MIN0(15,MAX0(2,IFIX(FLOAT(M)/8.))) NM = MIN0(15,MAX0(2,IFIX(FLOAT(N)/8.))) NM1 = N-1 MM1 = M-1 C C LINE LOOP FOLLOWS - THE COMPLETE TWO-DIMENSIONAL TEST FOR A MINIMUM OR C MAXIMUM OF THE FIELD IS ONLY PERFORMED FOR POINTS WHICH ARE MINIMA OR C MAXIMA ALONG SOME LINE - FINDING THESE CANDIDATES IS MADE EFFICIENT BY C USING A COUNT OF CONSECUTIVE INCREASES OR DECREASES OF THE FUNCTION C ALONG THE LINE C DO 127 JP=2,NM1 C IM = MN-1 IP = -1 GO TO 126 C C CONTROL RETURNS TO STATEMENT 10 AS LONG AS THE FUNCTION IS INCREASING C ALONG THE LINE - WE SEEK A POSSIBLE MAXIMUM C 101 IP = IP+1 AA = AN IF (IP .EQ. MM1) GO TO 104 AN = Z(IP+1,JP) IF (IOFFP.NE.0 .AND. AN.EQ.SPVAL) GO TO 125 IF (AA-AN) 102,103,104 102 IM = IM+1 GO TO 101 103 IM = 0 GO TO 101 C C FUNCTION DECREASED - TEST FOR MAXIMUM ON LINE C 104 IF (IM .GE. MN) GO TO 106 IS = MAX0(1,IP-MN) IT = IP-IM-1 IF (IS .GT. IT) GO TO 106 DO 105 II=IS,IT IF (AA .LE. Z(II,JP)) GO TO 112 105 CONTINUE 106 IS = IP+2 IT = MIN0(M,IP+MN) IF (IS .GT. IT) GO TO 109 DO 108 II=IS,IT IF (IOFFP.EQ.0 .OR. Z(II,JP).NE.SPVAL) GO TO 107 IP = II-1 GO TO 125 107 IF (AA .LE. Z(II,JP)) GO TO 112 108 CONTINUE C C WE HAVE MAXIMUM ON LINE - DO TWO-DIMENSIONAL TEST FOR MAXIMUM OF FIELD C 109 JS = MAX0(1,JP-NM) JT = MIN0(N,JP+NM) IS = MAX0(1,IP-MN) IT = MIN0(M,IP+MN) DO 111 JK=JS,JT IF (JK .EQ. JP) GO TO 111 DO 110 IK=IS,IT IF (Z(IK,JK).GE.AA .OR. 1 (IOFFP.NE.0 .AND. Z(IK,JK).EQ.SPVAL)) GO TO 112 110 CONTINUE 111 CONTINUE C X = FLOAT(IP) Y = FLOAT(JP) CALL WTSTR ( FX(X,Y),FY(X,Y),'H',ISIZEM,0,0 ) CALL FL2INT ( FX(X,Y),FY(X,Y),IFX,IFY ) C C SCALE TO USER SET RESOLUTION C IFY = IFY*SCLY CALL ENCD (AA,ASH,IA,NC,IOFFDT) MY = IFY - SIZEM TMY = CPUY ( MY ) CALL WTSTR ( FX(X,Y),TMY,IA(1:NC),ISIZEM,0,0 ) 112 IM = 1 IF (IP-MM1) 113,127,127 C C CONTROL RETURNS TO STATEMENT 20 AS LONG AS THE FUNCTION IS DECREASING C ALONG THE LINE - WE SEEK A POSSIBLE MINIMUM C 113 IP = IP+1 AA = AN IF (IP .EQ. MM1) GO TO 116 AN = Z(IP+1,JP) IF (IOFFP.NE.0 .AND. AN.EQ.SPVAL) GO TO 125 IF (AA-AN) 116,115,114 114 IM = IM+1 GO TO 113 115 IM = 0 GO TO 113 C C FUNCTION INCREASED - TEST FOR MINIMUM ON LINE C 116 IF (IM .GE. MN) GO TO 118 IS = MAX0(1,IP-MN) IT = IP-IM-1 IF (IS .GT. IT) GO TO 118 DO 117 II=IS,IT IF (AA .GE. Z(II,JP)) GO TO 124 117 CONTINUE 118 IS = IP+2 IT = MIN0(M,IP+MN) IF (IS .GT. IT) GO TO 121 DO 120 II=IS,IT IF (IOFFP.EQ.0 .OR. Z(II,JP).NE.SPVAL) GO TO 119 IP = II-1 GO TO 125 119 IF (AA .GE. Z(II,JP)) GO TO 124 120 CONTINUE C C WE HAVE MINIMUM ON LINE - DO TWO-DIMENSIONAL TEST FOR MINIMUM OF FIELD C 121 JS = MAX0(1,JP-NM) JT = MIN0(N,JP+NM) IS = MAX0(1,IP-MN) IT = MIN0(M,IP+MN) DO 123 JK=JS,JT IF (JK .EQ. JP) GO TO 123 DO 122 IK=IS,IT IF (Z(IK,JK).LE.AA .OR. 1 (IOFFP.NE.0 .AND. Z(IK,JK).EQ.SPVAL)) GO TO 124 122 CONTINUE 123 CONTINUE C X = FLOAT(IP) Y = FLOAT(JP) CALL WTSTR ( FX(X,Y),FY(X,Y),'L',ISIZEM,0,0 ) CALL FL2INT( FX(X,Y),FY(X,Y),IFX,IFY ) IFY = SCLY*IFY CALL ENCD (AA,ASH,IA,NC,IOFFDT) MY = IFY - SIZEM TMY = CPUY ( MY ) CALL WTSTR ( FX(X,Y),TMY,IA(1:NC),ISIZEM,0,0 ) 124 IM = 1 IF (IP-MM1) 101,127,127 C C SKIP SPECIAL VALUES ON LINE C 125 IM = 0 126 IP = IP+1 IF (IP .GE. MM1) GO TO 127 IF (IOFFP.NE.0 .AND. Z(IP+1,JP).EQ.SPVAL) GO TO 125 IM = IM+1 IF (IM .LE. MN) GO TO 126 IM = 1 AN = Z(IP+1,JP) IF (Z(IP,JP)-AN) 101,103,113 C 127 CONTINUE C RETURN C C ****************************** ENTRY PNTVAL ************************** C ENTRY PNTVAL (Z,L,MM,NN,ISSIZM,AASH,JOFFDT) C 128 CONTINUE II = (M-1+24)/24 JJ = (N-1+48)/48 NIQ = 1 NJQ = 1 DO 130 J=NJQ,N,JJ Y = J DO 129 I=NIQ,M,II X = I ZZ = Z(I,J) IF (IOFFP.NE.0 .AND. ZZ.EQ.SPVAL) GO TO 129 CALL ENCD (ZZ,ASH,IA,NC,IOFFDT) CALL WTSTR (FX(X,Y),FY(X,Y),IA(1:NC),ISIZEM,0,0 ) 129 CONTINUE 130 CONTINUE RETURN END SUBROUTINE REORD (CL,NCL,C1,MARK,NMG) SAVE DIMENSION CL(NCL) ,C1(NCL) C C THIS ROUTINE PUTS THE MAJOR (LABELED) LEVELS IN THE BEGINNING OF CL C AND THE MINOR (UNLABELED) LEVELS IN END OF CL. THE NUMBER OF MAJOR C LEVELS IS RETURNED IN MARK. C1 IS USED AS A WORK SPACE. NMG IS THE C NUMBER OF MINOR GAPS (ONE MORE THAN THE NUMBER OF MINOR LEVELS BETWEEN C MAJOR LEVELS). C NL = NCL IF (NL.LE.4 .OR. NMG.LE.1) GO TO 113 NML = NMG-1 IF (NL .LE. 10) NML = 1 C C CHECK FOR ZERO OR OTHER NICE NUMBER FOR A MAJOR LINE C NMLP1 = NML+1 DO 101 I=1,NL ISAVE = I IF (CL(I) .EQ. 0.) GO TO 104 101 CONTINUE L = NL/2 L = ALOG10(ABS(CL(L)))+1. Q = 10.**L DO 103 J=1,3 Q = Q/10. DO 102 I=1,NL ISAVE = I IF (AMOD(ABS(CL(I)+1.E-9*CL(I))/Q,FLOAT(NMLP1)) .LE. .0001) 1 GO TO 104 102 CONTINUE 103 CONTINUE ISAVE = NL/2 C C PUT MAJOR LEVELS IN C1 C 104 ISTART = MOD(ISAVE,NMLP1) IF (ISTART .EQ. 0) ISTART = NMLP1 NMAJL = 0 DO 105 I=ISTART,NL,NMLP1 NMAJL = NMAJL+1 C1(NMAJL) = CL(I) 105 CONTINUE MARK = NMAJL L = NMAJL C C PUT MINOR LEVELS IN C1 C IF (ISTART .EQ. 1) GO TO 107 DO 106 I=2,ISTART ISUB = L+I-1 C1(ISUB) = CL(I-1) 106 CONTINUE 107 L = NMAJL+ISTART-1 DO 109 I=2,NMAJL DO 108 J=1,NML L = L+1 ISUB = ISTART+(I-2)*NMLP1+J C1(L) = CL(ISUB) 108 CONTINUE 109 CONTINUE NLML = NL-L IF (L .EQ. NL) GO TO 111 DO 110 I=1,NLML L = L+1 C1(L) = CL(L) 110 CONTINUE C C PUT REORDERED ARRAY BACK IN ORIGINAL PLACE C 111 DO 112 I=1,NL CL(I) = C1(I) 112 CONTINUE RETURN 113 MARK = NL RETURN END SUBROUTINE STLINE (Z,LL,MM,NN,CONV) SAVE DIMENSION Z(LL,NN) C C THIS ROUTINE FINDS THE BEGINNINGS OF ALL CONTOUR LINES AT LEVEL CONV. C FIRST THE EDGES ARE SEARCHED FOR LINES INTERSECTING THE EDGE (OPEN C LINES) THEN THE INTERIOR IS SEARCHED FOR LINES WHICH DO NOT INTERSECT C THE EDGE (CLOSED LINES). BEGINNINGS ARE STORED IN IR TO PREVENT RE- C TRACING OF LINES. IF IR IS FILLED, THE SEARCH IS STOPPED FOR THIS C CONV. C COMMON /CONRE2/ IX ,IY ,IDX ,IDY , 1 IS ,ISS ,NP ,CV , 2 INX(8) ,INY(8) ,IR(2000) ,NR COMMON /CONRE3/ IXBITS ,IYBITS C C C C C C IXYPAK(IXX,IYY) = ISHIFT(IXX,IYBITS)+IYY C L = LL M = MM N = NN CV = CONV NP = 0 ISS = 0 DO 102 IP1=2,M I = IP1-1 IF (Z(I,1).GE.CV .OR. Z(IP1,1).LT.CV) GO TO 101 IX = IP1 IY = 1 IDX = -1 IDY = 0 IS = 1 CALL DRLINE (Z,L,M,N) 101 IF (Z(IP1,N).GE.CV .OR. Z(I,N).LT.CV) GO TO 102 IX = I IY = N IDX = 1 IDY = 0 IS = 5 CALL DRLINE (Z,L,M,N) 102 CONTINUE DO 104 JP1=2,N J = JP1-1 IF (Z(M,J).GE.CV .OR. Z(M,JP1).LT.CV) GO TO 103 IX = M IY = JP1 IDX = 0 IDY = -1 IS = 7 CALL DRLINE (Z,L,M,N) 103 IF (Z(1,JP1).GE.CV .OR. Z(1,J).LT.CV) GO TO 104 IX = 1 IY = J IDX = 0 IDY = 1 IS = 3 CALL DRLINE (Z,L,M,N) 104 CONTINUE ISS = 1 DO 108 JP1=3,N J = JP1-1 DO 107 IP1=2,M I = IP1-1 IF (Z(I,J).GE.CV .OR. Z(IP1,J).LT.CV) GO TO 107 IXY = IXYPAK(IP1,J) IF (NP .EQ. 0) GO TO 106 DO 105 K=1,NP IF (IR(K) .EQ. IXY) GO TO 107 105 CONTINUE 106 NP = NP+1 IF (NP .GT. NR) THEN C C THIS PRINTS AN ERROR MESSAGE IF THE LOCAL ARRAY IR IN SUBROUTINE C STLINE HAS AN OVERFLOW C THIS MESSAGE IS WRITTEN BOTH ON THE FRAME AND ON THE STANDARD ERROR C UNIT C IUNIT = I1MACH(4) WRITE(IUNIT,1000) 1000 FORMAT( 1' WARNING FROM ROUTINE STLINE IN CONREC--WORK ARRAY OVERFLOW') CALL GETSET(VXA,VXB,VYA,VYB,XA,XB,YA,YB,LTYPE) Y = (YB - YA) / 2. X = (XB - XA) / 2. CALL PWRIT(X,Y, 1'**WARNING--PICTURE INCOMPLETE**', 2 31,3,0,0) Y = Y * .7 CALL PWRIT(X,Y, 1'WORK ARRAY OVERFLOW IN STLINE', 2 29,3,0,0) RETURN ENDIF IR(NP) = IXY IX = IP1 IY = J IDX = -1 IDY = 0 IS = 1 CALL DRLINE (Z,L,M,N) 107 CONTINUE 108 CONTINUE RETURN END SUBROUTINE CALCNT (Z,M,N,A1,A2,A3,I1,I2,I3) C C THIS ENTRY POINT IS FOR USERS WHO ARE TOO LAZY TO SWITCH OLD DECKS C TO THE NEW CALLING SEQUENCE. C DIMENSION Z(M,N) SAVE C C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR C CALL Q8QST4 ('GRAPHX','CONREC','CALCNT','VERSION 01') C CALL CONREC (Z,M,M,N,A1,A2,A3,I1,I2,-IABS(I3)) RETURN END SUBROUTINE EZCNTR (Z,M,N) C C CONTOURING VIA SHORTEST POSSIBLE ARGUMENT LIST C ASSUMPTIONS -- C ALL OF THE ARRAY IS TO BE CONTOURED, C CONTOUR LEVELS ARE PICKED INTERNALLY, C CONTOURING ROUTINE PICKS SCALE FACTORS, C HIGHS AND LOWS ARE MARKED, C NEGATIVE LINES ARE DRAWN WITH A DASHED LINE PATTERN, C EZCNTR CALLS FRAME AFTER DRAWING THE CONTOUR MAP. C IF THESE ASSUMPTIONS ARE NOT MET, USE CONREC. C C ARGUMENTS C Z ARRAY TO BE CONTOURED C M FIRST DIMENSION OF Z C N SECOND DIMENSION OF Z C SAVE DIMENSION Z(M,N) DATA NSET,NHI,NDASH/0,0,682/ C C 682=1252B C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR C CALL Q8QST4 ('GRAPHX','CONREC','EZCNTR','VERSION 01') C CALL CONREC (Z,M,M,N,0.,0.,0.,NSET,NHI,-NDASH) CALL FRAME RETURN END BLOCKDATA CONBD COMMON /CONRE1/ IOFFP ,SPVAL COMMON /CONRE2/ IX ,IY ,IDX ,IDY , 1 IS ,ISS ,NP ,CV , 2 INX(8) ,INY(8) ,IR(2000) ,NR COMMON /CONRE4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP , 1 NCRT ,ILAB ,NULBLL ,IOFFD , 2 EXT ,IOFFM ,ISOLID ,NLA , 3 NLM ,XLT ,YBT ,SIDE COMMON /RECINT/ IRECMJ ,IRECMN ,IRECTX DATA IOFFP,SPVAL/0,0.0/ DATA ISIZEL,ISIZEM,ISIZEP,NLA,NLM,XLT,YBT,SIDE,ISOLID,NREP,NCRT/ 1 1, 2, 0, 16, 80,.05,.05, .9, 1023, 6, 4 / DATA EXT,IOFFD,NULBLL,IOFFM,ILAB/.25,0,3,0,0/ DATA INX(1),INX(2),INX(3),INX(4),INX(5),INX(6),INX(7),INX(8)/ 1 -1 , -1 , 0 , 1 , 1 , 1 , 0 , -1 / DATA INY(1),INY(2),INY(3),INY(4),INY(5),INY(6),INY(7),INY(8)/ 1 0 , 1 , 1 , 1 , 0 , -1 , -1 , -1 / DATA NR/2000/ DATA IRECMJ,IRECMN,IRECTX/ 1 , 1 , 1/ C C REVISION HISTORY--- C C JANUARY 1980 ADDED REVISION HISTORY AND CHANGED LIBRARY NAME C FROM CRAYLIB TO PORTLIB FOR MOVE TO PORTLIB C C MAY 1980 ARRAYS IWORK AND ENCSCR, PREVIOUSLY TOO SHORT FOR C SHORT-WORD-LENGTH MACHINES, LENGTHENED. SOME C DOCUMENTATION CLARIFIED AND CORRECTED. C C JUNE 1984 CONVERTED TO FORTRAN 77 AND TO GKS C C JUNE 1985 ERROR HANDLING LINES ADDED; IF OVERFLOW HAPPENS TO C WORK ARRAY IN STLINE, A WARNING MESSAGE IS WRITTEN C BOTH ON PLOT FRAME AND ON STANDARD ERROR MESSAGE. C------------------------------------------------------------------- C END '\eof' echo CREATE_VELVCT.GKS cat > velvct.gks<< '\eof' SUBROUTINE VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,LENGTH) C COMMON/VPLT/ IFLV,IVU1,IVU2,IVRT C DECLARATIONS - C COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , + IOFFD ,IOFFM ,ISX ,ISY , + RMN ,RMX ,SIDE ,SIZE , + XLT ,YBT ,ZMN ,ZMX C COMMON /VEC2/ BIG,IX0,IX1,INCX,IY0,IY1,INCY COMMON/LITARR/ LITARFL DATA LITARFL/1/ C C FORCE THE BLOCK DATA ROUTINE, WHICH SETS DEFAULT VARIABLES, TO LOAD. C EXTERNAL VELDAT C C ARGUMENT DIMENSIONS. C DIMENSION U(LU,N) ,V(LV,N) ,SPV(2) CHARACTER*14 LABEL REAL WIND(4), VIEW(4), IAR(4) COMMON/TOPOG/ CTP(2000),Z0,ITOP C C --------------------------------------------------------------------- C C INTERNAL PARAMETERS OF VELVCT ARE AS FOLLOWS. THE DEFAULT VALUES OF C THESE PARAMETERS ARE DECLARED IN THE BLOCK DATA ROUTINE VELDAT. C C NAME DEFAULT FUNCTION C ---- ------- -------- C C BIG R1MACH(2) CONSTANT USED TO INITIALIZE C POSSIBLE SEARCH FOR HI. C C EXT 0.25 THE LENGTHS OF THE SIDES OF THE C PLOT ARE PROPORTIONAL TO M AND C N WHEN NSET IS LESS THAN OR C EQUAL TO ZERO, EXCEPT WHEN C MIN(M,N)/MAX(M,N) IS LESS THAN C EXT, IN WHICH CASE A SQUARE C GRAPH IS PLOTTED. C C ICTRFG 1 FLAG TO CONTROL THE POSITION OF C THE ARROW RELATIVE TO A BASE C POINT AT (MX,MY). C C ZERO - CENTER AT (MX,MY) C C POSITIVE - TAIL AT (MX,MY) C C NEGATIVE - HEAD AT (MX,MY) C C ILAB 0 FLAG TO CONTROL THE DRAWING OF C LINE LABELS. C C ZERO - DO NOT DRAW THE LABELS C C NON-ZERO - DRAW THE LABELS C C INCX 1 X-COORDINATE STEP SIZE FOR LESS C DENSE ARRAYS. C C INCY 1 Y-COORDINATE STEP SIZE. C C IOFFD 0 FLAG TO CONTROL NORMALIZATION C OF LABEL NUMBERS. C C ZERO - INCLUDE A DECIMAL POINT C WHEN POSSIBLE C C NON-ZERO - NORMALIZE ALL LABEL C NUMBERS BY ASH C C IOFFM 0 FLAG TO CONTROL PLOTTING OF C THE MESSAGE BELOW THE PLOT. C C ZERO - PLOT THE MESSAGE C C NON-ZERO - DO NOT PLOT IT C C RMN 160. ARROW SIZE BELOW WHICH THE C HEAD NO LONGER SHRINKS, ON A C 2**15 X 2**15 GRID. C C RMX 6400. ARROW SIZE ABOVE WHICH THE C HEAD NO LONGER GROWS LARGER, C ON A 2**15 X 2**15 GRID. C C SIDE 0.90 LENGTH OF LONGER EDGE OF PLOT. C (SEE ALSO EXT.) C C SIZE 256. WIDTH OF THE CHARACTERS IN C VECTOR LABELS, ON A 2**15 X C 2**15 GRID. C C XLT 0.05 LEFT HAND EDGE OF THE PLOT. C (0 IS THE LEFT EDGE OF THE C FRAME, 1 THE RIGHT EDGE.) C C YBT 0.05 BOTTOM EDGE OF THE PLOT (0 IS C THE BOTTOM OF THE FRAME, 1 THE C TOP OF THE FRAME.) C C --------------------------------------------------------------------- C C INTERNAL FUNCTIONS WHICH MAY BE MODIFIED FOR DATA TRANSFORMATION - C C SCALE COMPUTES A SCALE FACTOR USED IN THE C DETERMINATION OF THE LENGTH OF THE C VECTOR TO BE DRAWN. C C DIST COMPUTES THE LENGTH OF A VECTOR. C C FX RETURNS THE X INDEX AS THE C X-COORDINATE OF THE VECTOR BASE. C C MXF RETURNS THE X-COORDINATE OF THE VECTOR C HEAD. C C FY RETURNS THE Y INDEX AS THE C Y-COORDINATE OF THE VECTOR BASE. C C MYF RETURNS THE Y-COORDINATE OF THE VECTOR C HEAD. C C VLAB THE VALUE FOR THE VECTOR LABEL WHEN C ILAB IS NON-ZERO. C SAVE FX(XX,YY) = XX C FY(XX,YY) = YY FY(XX,YY)=YY+ITOP*((CTP(IFIX(XX))+(IFIX(XX)-XX)*(CTP(IFIX(XX))- 1CTP(IFIX(XX+1.))))*(Z0-YY)) DIST(XX,YY) = SQRT(XX*XX+YY*YY) MXF(XX,YY,UU,VV,SFXX,SFYY,MXX,MYY) = MXX+IFIX(SFXX*UU) MYF(XX,YY,UU,VV,SFXX,SFYY,MXX,MYY) = MYY+IFIX(SFYY*VV) SCALEX(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,XX4,YY3,YY4, 1 LENN) = LENN/HAA SCALEY(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3,XX4,YY3,YY4, 1 LENN) = SCALEX(MM,NN,INCXX,INCYY,HAA,XX1,XX2,YY1,YY2,XX3, 2 XX4,YY3,YY4,LENN) VLAB(UU,VV,II,JJ) = DIST(UU,VV) C C --------------------------------------------------------------------- C C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. C C CALL Q8QST4 ('NSSL','VELVCT','VELVCT','VERSION 6') C C INITIALIZE AND TRANSFER SOME ARGUMENTS TO LOCAL VARIABLES. C BIG = -1.E-15 MX = LU MY = LV NX = M NY = N GL = FLO HA = HI ISP = 0 NC = 0 C C COMPUTE CONSTANTS BASED ON THE ADDRESSABILITY OF THE PLOTTER. C CALL GETUSV('XF',ISX) CALL GETUSV('YF',ISY) ISX = 2**(15-ISX) ISY = 2**(15-ISY) LEN = LENGTH*ISX C C SET UP THE SCALING OF THE PLOT. C CALL GQCNTN(IERR,IOLDNT) CALL GQNT(IOLDNT,IERR,WIND,VIEW) X1 = VIEW(1) X2 = VIEW(2) Y1 = VIEW(3) Y2 = VIEW(4) X3 = WIND(1) X4 = WIND(2) Y3 = WIND(3) Y4 = WIND(4) CALL GETUSV('LS',IOLLS) C C SAVE NORMALIZATION TRANSFORMATION 1 C CALL GQNT(1,IERR,WIND,VIEW) C IF (NSET) 101,102,106 C 101 X3 = 1. X4 = FLOAT(NX) Y3 = 1. Y4 = FLOAT(NY) GO TO 105 C 102 X1 = XLT X2 = XLT+SIDE Y1 = YBT Y2 = YBT+SIDE X3 = 1. Y3 = 1. X4 = FLOAT(NX) Y4 = FLOAT(NY) IF (AMIN1(X4,Y4)/AMAX1(X4,Y4) .LT. EXT) GO TO 105 C IF (NX-NY) 103,105,104 103 X2 = XLT+SIDE*X4/Y4 GO TO 105 104 Y2 = YBT+SIDE*Y4/X4 C 105 CALL SET(X1,X2,Y1,Y2,X3,X4,Y3,Y4,1) IF (NSET .EQ. 0) CALL PERIM (1,0,1,0) C C CALCULATE A LENGTH IF NONE PROVIDED. C 106 IF (LEN .NE. 0) GO TO 107 CALL FL2INT(FX(1.,1.),FY(1.,1.),MX,MY) CALL FL2INT(FX(FLOAT(1+INCX),FLOAT(1+INCY)), + FY(FLOAT(1+INCX),FLOAT(1+INCY)),LX,LY) LEN = SQRT((FLOAT(MX-LX)**2+FLOAT(MY-LY)**2)/2.) C C SET UP SPECIAL VALUES. C 107 IF (ISP .EQ. 0) GO TO 108 SPV1 = SPV(1) SPV2 = SPV(2) IF (ISP .EQ. 4) SPV2 = SPV(1) C C FIND THE MAXIMUM VECTOR LENGTH. C 108 IF (HA .GT. 0.) GO TO 118 C HA = BIG IF (ISP .EQ. 0) GO TO 115 C DO 114 J=IY0,NY-IY1,INCY DO 113 I=IX0,NX-IX1,INCX IF (ISP-2) 109,111,110 109 IF (U(I,J) .EQ. SPV1) GO TO 113 GO TO 112 110 IF (U(I,J) .EQ. SPV1) GO TO 113 111 IF (V(I,J) .EQ. SPV2) GO TO 113 112 HA = AMAX1(HA,DIST(U(I,J),V(I,J))) 113 CONTINUE 114 CONTINUE GO TO 126 C 115 DO 117 J=IY0,NY-IY1,INCY DO 116 I=IX0,NX-IX1,INCX HA = AMAX1(HA,DIST(U(I,J),V(I,J))) 116 CONTINUE 117 CONTINUE C C BRANCH IF NULL VECTOR SIZE. C C 126 IF (HA .LE. 0.) GO TO 125 126 IF (HA .LE. 1.E-15) GO TO 125 C C COMPUTE SCALE FACTORS. C 118 SFX = SCALEX(M,N,INCX,INCY,HA,X1,X2,Y1,Y2,X3,X4,Y3,Y4,LEN) SFY = SCALEY(M,N,INCX,INCY,HA,X1,X2,Y1,Y2,X3,X4,Y3,Y4,LEN) IOFFDT = IOFFD IF (GL.NE.0.0 .AND. (ABS(GL).LT.0.1 .OR. ABS(GL).GE.1.E5)) 1 IOFFDT = 1 IF (HA.NE.0.0 .AND. (ABS(HA).LT.0.1 .OR. ABS(HA).GE.1.E5)) 1 IOFFDT = 1 ASH = 1.0 IF (IOFFDT .NE. 0) 1 ASH = 10.**(3-IFIX(ALOG10(AMAX1(ABS(GL),ABS(HA)))-500.)-500) IZFLG = 0 C C COMPUTE ZMN AND ZMX, WHICH ARE USED IN DRWVEC. C ZMN = LEN*(GL/HA) ZMX = FLOAT(LEN)+.01 C C DRAW THE VECTORS. C DO 123 J=IY0,NY-IY1,INCY DO 122 I=IX0,NX-IX1,INCX UI = U(I,J) VI = V(I,J) IF (ISP-1) 121,119,120 119 IF (UI-SPV1) 121,122,121 120 IF (VI .EQ. SPV2) GO TO 122 IF (ISP .GE. 3) GO TO 119 121 X = I Y = J CALL FL2INT(FX(X,Y),FY(X,Y),MX,MY) LX = MAX0(1,MXF(X,Y,UI,VI,SFX,SFY,MX,MY)) LY = MAX0(1,MYF(X,Y,UI,VI,SFX,SFY,MX,MY)) IZFLG = 1 IF (ILAB .NE. 0) CALL ENCD(VLAB(UI,VI,I,J),ASH,LABEL,NC, + IOFFDT) CALL DRWVEC (MX,MY,LX,LY,LABEL,NC) 122 CONTINUE 123 CONTINUE C IF (IZFLG .EQ. 0) GO TO 125 C IF (IOFFM .NE. 0) GO TO 200 C WRITE(LABEL,'(E10.3)')HA IF(IVRT.EQ.0) THEN #if (PVP > 0) c ENCODE(14,904,LABEL) HA 904 FORMAT(F6.1,8H M/S ) C 904 FORMAT(F6.2,8H M/S ) #endif ENDIF IF(IVRT.EQ.1) THEN #if (PVP > 0) c ENCODE(14,9041,LABEL) HA 9041 FORMAT(E7.2,7H10**4/S) #endif ENDIF C C TURN OFF CLIPPING SO ARROW CAN BE DRAWN C CALL GQCLIP(IER,ICLP,IAR) CALL GSCLIP(0) C CALL DRWVEC (28768,608,28768+LEN,608,LABEL,14) IF(LITARFL.EQ.1) 1 CALL DRWVEC (28768,384,28768+LEN,384,LABEL,14) C C RESTORE CLIPPING C CALL GSCLIP(ICLP) IX = 1+(28768+LEN/2)/ISX IY = 1+(608-(5*ISX*MAX0(256/ISX,8))/4)/ISY CALL GQCNTN(IER,ICN) CALL GSELNT(0) C XC = CPUX(IX) C YC = CPUY(IY) C CALL WTSTR (XC,YC, C + 'MAXIMUM VECTOR',MAX0(256/ISX,8),0,0) CALL GSELNT(ICN) C C DONE. C GOTO 200 C C ZERO-FIELD ACTION. C 125 IX = 1+16384/ISX IY = 1+16384/ISY CALL GQCNTN(IER,ICN) CALL GSELNT(0) XC = CPUX(IX) YC = CPUY(IY) CALL WTSTR (XC,YC, + 'ZERO FIELD',MAX0(960/ISX,8),0,0) CALL GSELNT(ICN) C C RESTORE TRANS 1 AND LOG SCALING AND ORIGINAL TRANS NUMBER C 200 CONTINUE IF (NSET .LE. 0) THEN CALL SET(VIEW(1),VIEW(2),VIEW(3),VIEW(4), - WIND(1),WIND(2),WIND(3),WIND(4),IOLLS) ENDIF CALL GSELNT(IOLDNT) RETURN END SUBROUTINE DRWVEC (M1,M2,M3,M4,LABEL,NC) C C THIS ROUTINE IS CALLED TO DRAW A SINGLE ARROW. IT HAS ARGUMENTS AS C FOLLOWS - C C (M1,M2) - COORDINATE OF ARROW BASE, ON A 2**15 X 2**15 GRID. C (M3,M4) - COORDINATE OF ARROW HEAD, ON A 2**15 X 2**15 GRID. C LABEL - CHARACTER LABEL TO BE PUT ABOVE ARROW. C NC - NUMBER OF CHARACTERS IN LABEL. C SAVE C C COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , + IOFFD ,IOFFM ,ISX ,ISY , + RMN ,RMX ,SIDE ,SIZE , + XLT ,YBT ,ZMN ,ZMX CHARACTER*10 LABEL C C SOME LOCAL PARAMETERS ARE THE FOLLOWING - C C CL - ARROW HEAD LENGTH SCALE FACTOR - EACH SIDE OF THE ARROW C HEAD IS THIS LONG RELATIVE TO THE LENGTH OF THE ARROW C ST,CT - SIN AND COS OF THE ARROW HEAD ANGLE C PI - THE CONSTANT PI C TWOPI - TWO TIMES PI C OHOPI - ONE HALF OF PI C FHOPI - FIVE HALVES OF PI C DATA CL / .25 / DATA ST / .382683432365090 / DATA CT / .923879532511287 / DATA PI / 3.14159265358979 / DATA TWOPI / 6.28318530717959 / DATA OHOPI / 1.57079632679489 / DATA FHOPI / 7.85398163397448 / C DIST(X,Y) = SQRT(X*X+Y*Y) C C TRANSFER ARGUMENTS TO LOCAL VARIABLES AND COMPUTE THE VECTOR LENGTH. C N1 = M1 N2 = M2 N3 = M3 N4 = M4 DX = N3-N1 DY = N4-N2 R = DIST(DX,DY) C C SORT OUT POSSIBLE CASES, DEPENDING ON VECTOR LENGTH. C IF (R .LE. ZMN) RETURN C c IF (R .LE. ZMX) GO TO 101 GO TO 101 C C PLOT A POINT FOR VECTORS WHICH ARE TOO LONG. C c CALL PLOTIT (N1,N2,0) c CALL PLOTIT (N1,N2,1) c CALL PLOTIT (N1,N2,0) c RETURN C C ADJUST THE COORDINATES OF THE VECTOR ENDPOINTS AS IMPLIED BY THE C CENTERING OPTION. C 101 IF (ICTRFG) 102,103,104 C 102 N3 = N1 N4 = N2 N1 = FLOAT(N1)-DX N2 = FLOAT(N2)-DY GO TO 104 C 103 N1 = FLOAT(N1)-.5*DX N2 = FLOAT(N2)-.5*DY N3 = FLOAT(N3)-.5*DX N4 = FLOAT(N4)-.5*DY C C DETERMINE THE COORDINATES OF THE POINTS USED TO DRAW THE ARROWHEAD. C 104 C1 = CL C C SHORT ARROWS HAVE HEADS OF A FIXED MINIMUM SIZE. C IF (R .LT. RMN) C1 = RMN*CL/R C C LONG ARROWS HAVE HEADS OF A FIXED MAXIMUM SIZE. C IF (R .GT. RMX) C1 = RMX*CL/R C C COMPUTE THE COORDINATES OF THE HEAD. C N5 = FLOAT(N3)-C1*(CT*DX-ST*DY) N6 = FLOAT(N4)-C1*(CT*DY+ST*DX) N7 = FLOAT(N3)-C1*(CT*DX+ST*DY) N8 = FLOAT(N4)-C1*(CT*DY-ST*DX) C C PLOT THE ARROW. C CALL PLOTIT (N1,N2,0) CALL PLOTIT (N3,N4,1) CALL PLOTIT (N5,N6,0) CALL PLOTIT (N3,N4,1) CALL PLOTIT (N7,N8,1) CALL PLOTIT (0,0,0) C C IF REQUESTED, PUT THE VECTOR MAGNITUDE ABOVE THE ARROW. C IF (NC .EQ. 0) RETURN PHI = ATAN2(DY,DX) IF (AMOD(PHI+FHOPI,TWOPI) .GT. PI) PHI = PHI+PI IX = 1+IFIX(.5*FLOAT(N1+N3)+1.25* + FLOAT(ISX*MAX0(IFIX(SIZE)/ISX,8))*COS(PHI+OHOPI))/ISX IY = 1+IFIX(.5*FLOAT(N2+N4)+1.25* + FLOAT(ISX*MAX0(IFIX(SIZE)/ISX,8))*SIN(PHI+OHOPI))/ISY CALL GQCNTN(IER,ICN) CALL GSELNT(0) XC = CPUX(IX) YC = CPUY(IY) CALL WTSTR(XC,YC, + LABEL,MAX0(IFIX(SIZE)/ISX,8), + IFIX(57.2957795130823*PHI),0) CALL GSELNT(ICN) RETURN END SUBROUTINE VELVEC (U,LU,V,LV,M,N,FLO,HI,NSET) C C THIS ROUTINE SUPPORTS USERS OF THE OLD VERSION OF THIS PACKAGE. C DIMENSION U(LU,N) ,V(LV,N) ,SPV(2) C SAVE C C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR. C C CALL Q8QST4 ('CRAYLIB','VELVCT','VELVEC','VERSION 4') CALL VELVCT (U,LU,V,LV,M,N,FLO,HI,NSET,0) RETURN END BLOCK DATA VELDAT C C THIS 'ROUTINE' DEFINES THE DEFAULT VALUES OF THE VELVCT PARAMETERS. C SAVE C COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , + IOFFD ,IOFFM ,ISX ,ISY , + RMN ,RMX ,SIDE ,SIZE , + XLT ,YBT ,ZMN ,ZMX C COMMON /VEC2/ BIG,IX0,IX1,INCX,IY0,IY1,INCY C DATA EXT / 0.25 / DATA ICTRFG / 1 / DATA ILAB / 0 / DATA IOFFD / 0 / DATA IOFFM / 0 / DATA RMN / 160.00 / DATA RMX / 6400.00 / DATA SIDE / 0.90 / DATA SIZE / 256.00 / DATA XLT / 0.05 / DATA YBT / 0.05 / DATA ZMX / 0.00 / DATA IX0,IX1,INCX /1,0, 1 / DATA IY0,IY1,INCY /1,0, 1 / C C REVISION HISTORY ---------------------------------------------------- C C FEBRUARY, 1979 ADDED REVISION HISTORY C MODIFIED CODE TO CONFORM TO FORTRAN 66 STANDARD C C JULY, 1979 FIXED HI VECTOR TRAP AND MESSAGE INDICATING C MAXIMUM VECTOR PLOTTED. C C DECEMBER, 1979 CHANGED THE STATISTICS CALL FROM CRAYLIB TO NSSL C C MARCH, 1981 FIXED SOME FRINGE-CASE ERRORS, CHANGED THE CODE TO C USE FL2INTT AND PLOTIT INSTEAD OF MXMY, FRSTPT, AND C VECTOR, AND MADE THE ARROWHEADS NARROWER (45 DEGREES C APART, RATHER THAN 60 DEGREES APART) C C FEBRUARY, 1984 PROVIDED A DIMENSION STATEMENT FOR A VARIABLE INTO C WHICH A TEN-CHARACTER STRING WAS BEING ENCODED. ON C THE CRAY, WHEN THE ENCODE WAS DONE, A WORD FOLLOWING C THE VARIABLE WAS CLOBBERED, BUT THIS APPARENTLY MADE C NO DIFFERENCE. ON AT LEAST ONE OTHER MACHINE, THE C CODE BLEW UP. (ERROR REPORTED BY GREG WOODS) C C JULY, 1984 CONVERTED TO FORTRAN77 AND GKS. C C --------------------------------------------------------------------- END SUBROUTINE STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,NSET,IER) C C +-----------------------------------------------------------------+ C | | C | Copyright (C) 1989 by UCAR | C | University Corporation for Atmospheric Research | C | All Rights Reserved | C | | C | NCARGRAPHICS Version 3.00 | C | | C +-----------------------------------------------------------------+ C C SUBROUTINE STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,NSET,IER) C C DIMENSION OF U(IMAX,JPTSY) , V(IMAX,JPTSY) , C ARGUMENTS WORK(2*IMAX*JPTSY) C C PURPOSE STRMLN draws a streamline representation of C the flow field. The representation is C independent of the flow speed. C C USAGE If the following assumptions are met, use C C CALL EZSTRM (U,V,WORK,IMAX,JMAX) C C Assumptions: C --The whole array is to be processed. C --The arrays are dimensioned C U(IMAX,JMAX) , V(IMAX,JMAX) and C WORK(2*IMAX*JMAX). C --Window and viewport are to be chosen C by STRMLN. C --PERIM is to be called. C C If these assumptions are not met, use C C CALL STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY, C NSET,IER) C C The user must call FRAME in the calling C routine. C C The user may change various internal C parameters via common blocks. See below. C C ARGUMENTS C C ON INPUT U, V C Two dimensional arrays containing the C velocity fields to be plotted. C C Note: If the U AND V components C are, for example, defined in Cartesian C coordinates and the user wishes to plot them C on a different projection (i.e., stereo- C graphic), then the appropriate C transformation must be made to the U and V C components via the functions FU and FV C (located in DRWSTR). C C WORK C User provided work array. The dimension C of this array must be .GE. 2*IMAX*JPTSY. C C Caution: This routine does not check the C size of the work array. C C IMAX C The first dimension of U and V in the C calling program. (X-direction) C C IPTSX C The number of points to be plotted in the C first subscript direction. (X-direction) C C JPTSY C The number of points to be plotted in the C second subscript direction. (Y-direction) C C NSET C Flag to control scaling C > 0 STRMLN assumes that the window C and viewport have been set by the C user in such a way as to properly C scale the plotting instructions C generated by STRMLN. PERIM is not C called. C = 0 STRMLN will establish the window and C viewport to properly scale the C plotting instructions to the standard C configuration. PERIM is called to draw C the border. C < 0 STRMLN establishes the window C and viewport so as to place the C streamlines within the limits C of the user's window. PERIM is C not called. C C ON OUTPUT Only the IER argument may be changed. All C other arguments are unchanged. C C C IER C = 0 when no errors are detected C = -1 when the routine is called with ICYC C .NE. 0 and the data are not cyclic C (ICYC is an internal parameter C described below); in this case the C routine will draw the C streamlines with the non-cyclic C interpolation formulas. C C ENTRY POINTS STRMLN, DRWSTR, EZSTRM, GNEWPT, CHKCYC C C COMMON BLOCKS STR01, STR02, STR03, STR04 C C REQUIRED LIBRARY GRIDAL, GBYTES, and the SPPS C ROUTINES C C REQUIRED GKS LEVEL 0A C C I/O None C C PRECISION Single C C LANGUAGE FORTRAN 77 C C HISTORY Written and standardized in November 1973. C C Converted to FORTRAN 77 and GKS in June, 1984. C C C PORTABILITY FORTRAN 77 C C ALGORITHM Wind components are normalized to the value C of DISPL. The least significant two C bits of the work array are C utilized as flags for each grid box. Flag 1 C indicates whether any streamline has C previously passed through this box. Flag 2 C indicates whether a directional arrow has C already appeared in a box. Judicious use C of these flags prevents overcrowding of C streamlines and directional arrows. C Experience indicates that a final pleasing C picture is produced when streamlines are C initiated in the center of a grid box. The C streamlines are drawn in one direction then C in the opposite direction. C C REFERENCE The techniques utilized here are described C in an article by Thomas Whittaker (U. of C Wisconsin) which appeared in the notes and C correspondence section of Monthly Weather C Review, June 1977. C C TIMING Highly variable C It depends on the complexity of the C flow field and the parameters: DISPL, C DISPC , CSTOP , INITA , INITB , ITERC , C and IGFLG. (See below for a discussion C of these parameters.) If all values C are default, then a simple linear C flow field for a 40 x 40 grid will C take about 0.4 seconds on the CRAY1-A; C a fairly complex flow field will take about C 1.5 seconds on the CRAY1-A. C C C INTERNAL PARAMETERS C C NAME DEFAULT FUNCTION C ---- ------- -------- C C EXT 0.25 Lengths of the sides of the C plot are proportional to C IPTSX and JPTSY except in C the case when MIN(IPTSX,JPT C / MAX(IPTSX,JPTSY) .LT. EXT C in that case a square C graph is plotted. C C SIDE 0.90 Length of longer edge of C plot. (See also EXT.) C C XLT 0.05 Left hand edge of the plot. C (0.0 = left edge of frame) C (1.0 = right edge of frame) C C YBT 0.05 Bottom edge of the plot. C (0.0 = bottom ; 1.0 = top) C C (YBT+SIDE and XLT+SIDE must C be .LE. 1. ) C C INITA 2 Used to precondition grid C boxes to be eligible to C start a streamline. C For example, a value of 4 C means that every fourth C grid box is eligible ; a C value of 2 means that every C other grid box is eligible. C (see INITB) C C INITB 2 Used to precondition grid C boxes to be eligible for C direction arrows. C If the user changes the C default values of INITA C and/or INITB, it should C be done such that C MOD(INITA,INITB) = 0 . C For a dense grid try C INITA=4 and INITB=2 to C reduce the CPU time. C C AROWL 0.33 Length of direction arrow. C For example, 0.33 means C each directional arrow will C take up a third of a grid C box. C C ITERP 35 Every 'ITERP' iterations C the streamline progress C is checked. C C ITERC -99 The default value of this C parameter is such that C it has no effect on the C code. When set to some C positive value, the program C will check for streamline C crossover every 'ITERC' C iterations. (The routine C currently does this every C time it enters a new grid C box.) C Caution: When this C parameter is activated, C CPU time will increase. C C IGFLG 0 A value of zero means that C the sixteen point Bessel C Interpolation Formula will C be utilized where possible; C when near the grid edges, C quadratic and bi-linear C interpolation will be C used. This mixing of C interpolation schemes can C sometimes cause slight C raggedness near the edges C of the plot. If IGFLG.NE.0 C then only the bilinear C interpolation formula C is used; this will generall C result in slightly faster C plot times but a less C pleasing plot. C C IMSG 0 If zero, then no missing C U and V components are C present. C If .NE. 0, STRMLN will C utilize the C bi-linear interpolation C scheme and terminate if C any data points are missing C C UVMSG 1.E+36 Value assigned to a missing C point. C C ICYC 0 Zero means the data are C non-cyclic in the X C direction. C If .NE 0, the C cyclic interpolation C formulas will be used. C (Note: Even if the data C are cyclic in X, leaving C ICYC = 0 will do no harm.) C C DISPL 0.33 The wind speed is C normalized to this value. C (See the discussion below.) C C DISPC 0.67 The critical displacement. C If after 'ITERP' iterations C the streamline has not C moved this distance, the C streamline will be C terminated. C C CSTOP 0.50 This parameter controls C the spacing between C streamlines. The checking C is done when a new grid C box is entered. C C DISCUSSION OF Assume a value of 0.33 for DISPL. This C DISPL,DISPC means that it will take three steps to move C AND CSTOP across one grid box if the flow was all in the C X direction. If the flow is zonal, then a C larger value of DISPL is in order. C If the flow is highly turbulent, then C a smaller value is in order. The smaller C DISPL, the more the CPU time. A value C of 2 to 4 times DISPL is a reasonable value C for DISPC. DISPC should always be greater C than DISPL. A value of 0.33 for CSTOP would C mean that a maximum of three stream- C lines will be drawn per grid box. This max C will normally only occur in areas of singular C points. C C *************************** C Any or all of the above C parameters may be changed C by utilizing common blocks C STR02 and/or STR03 C *************************** C C UXSML A number which is small C compared to the average C normalized u component. C Set automatically. C C NCHK 750 This parameter is located C in DRWSTR. It specifies the C length of the circular C lists used for checking C for STRMLN crossovers. C For most plots this number C may be reduced to 500 C or less and the plots will C not be altered. C C ISKIP Number of bits to be C skipped to get to the C least two significant bits C in a floating point number. C The default value is set to C I1MACH(5) - 2 . This value C may have to be changed C depending on the target C computer; see subroutine C DRWSTR. C C C DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) , 1 WORK(1) DIMENSION WNDW(4) ,VWPRT(4) C COMMON /STR01/ IS ,IEND ,JS ,JEND 1 , IEND1 ,JEND1 ,I ,J 2 , X ,Y ,DELX ,DELY 3 , ICYC1 ,IMSG1 ,IGFL1 COMMON /STR02/ EXT , SIDE , XLT , YBT COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP C SAVE C EXT = 0.25 SIDE = 0.90 XLT = 0.05 YBT = 0.05 C C INITA = 2 C INITB = 2 AROWL = 0.40 C AROWL = 0.33 ITERP = 35 ITERC = -99 IGFLG = 0 ICYC = 0 IMSG = 0 UVMSG = 1.E+36 DISPL = 0.33 DISPC = 0.67 c CSTOP = 0.50 C C THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR C C CALL Q8QST4 ( 'GRAPHX', 'STRMLN', 'STRMLN', 'VERSION 01') C IER = 0 C C LOAD THE COMMUNICATION COMMON BLOCK WITH PARAMETERS C IS = 1 IEND = IPTSX JS = 1 JEND = JPTSY IEND1 = IEND-1 JEND1 = JEND-1 IEND2 = IEND-2 JEND2 = JEND-2 XNX = FLOAT(IEND-IS+1) XNY = FLOAT(JEND-JS+1) ICYC1 = ICYC IGFL1 = IGFLG IMSG1 = 0 C C IF ICYC .NE. 0 THEN CHECK TO MAKE SURE THE CYCLIC CONDITION EXISTS. C IF (ICYC1.NE.0) CALL CHKCYC (U,V,IMAX,JPTSY,IER) C C SAVE ORIGINAL NORMALIZATION TRANSFORMATION NUMBER C CALL GQCNTN ( IERR,NTORIG ) C C SET UP SCALING C IF (NSET) 10 , 20 , 60 10 CALL GETUSV ( 'LS' , ITYPE ) CALL GQNT ( NTORIG,IERR,WNDW,VWPRT ) CALL GETUSV('LS',IOLLS) X1 = VWPRT(1) X2 = VWPRT(2) Y1 = VWPRT(3) Y2 = VWPRT(4) X3 = IS X4 = IEND Y3 = JS Y4 = JEND GO TO 55 C 20 ITYPE = 1 X1 = XLT X2 = (XLT+SIDE) Y1 = YBT Y2 = (YBT+SIDE) X3 = IS X4 = IEND Y3 = JS Y4 = JEND IF (AMIN1(XNX,XNY)/AMAX1(XNX,XNY).LT.EXT) GO TO 50 IF (XNX-XNY) 30, 50, 40 30 X2 = (SIDE*(XNX/XNY) + XLT) GO TO 50 40 Y2 = (SIDE*(XNY/XNX) + YBT) 50 CONTINUE C C CENTER THE PLOT C DX = 0.25*( 1. - (X2-X1) ) DY = 0.25*( 1. - (Y2-Y1) ) X1 = (XLT+DX) X2 = (X2+DX ) Y1 = (YBT+DY) Y2 = (Y2+DY ) C 55 CONTINUE C C SAVE NORMALIZATION TRANSFORMATION 1 C CALL GQNT ( 1,IERR,WNDW,VWPRT ) C C DEFINE AND SELECT NORMALIZATION TRANS, SET LOG SCALING C CALL SET(X1,X2,Y1,Y2,X3,X4,Y3,Y4,ITYPE) C IF (NSET.EQ.0) CALL PERIM (1,0,1,0) C 60 CONTINUE C C DRAW THE STREAMLINES C . BREAK THE WORK ARRAY INTO TWO PARTS. SEE DRWSTR FOR FURTHER C . COMMENTS ON THIS. C CALL DRWSTR (U,V,WORK(1),WORK(IMAX*JPTSY+1),IMAX,JPTSY) C C RESET NORMALIATION TRANSFORMATION 1 TO ORIGINAL VALUES C IF (NSET .LE. 0) THEN CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) ENDIF CALL GSELNT (NTORIG) C RETURN END SUBROUTINE DRWSTR (U,V,UX,VY,IMAX,JPTSY) C PARAMETER (NCHK=750) C C THIS ROUTINE DRAWS THE STREAMLINES. C . THE XCHK AND YCHK ARRAYS SERVE AS A CIRCULAR LIST. THEY C . ARE USED TO PREVENT LINES FROM CROSSING ONE ANOTHER. C C THE WORK ARRAY HAS BEEN BROKEN UP INTO TWO ARRAYS FOR CLARITY. THE C . TOP HALF OF WORK (CALLED UX) WILL HAVE THE NORMALIZED (AND C . POSSIBLY TRANSFORMED) U COMPONENTS AND WILL BE USED FOR BOOK C . KEEPING. THE LOWER HALF OF THE WORK ARRAY (CALLED VY) WILL C . CONTAIN THE NORMALIZED (AND POSSIBLY TRANSFORMED) V COMPONENTS. C DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) 1 , UX(IMAX,JPTSY) ,VY(IMAX,JPTSY) COMMON /STR01/ IS ,IEND ,JS ,JEND 1 , IEND1 ,JEND1 ,I ,J 2 , X ,Y ,DELX ,DELY 3 , ICYC1 ,IMSG1 ,IGFL1 COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP COMMON /STR04/ XCHK(NCHK) ,YCHK(NCHK) , NUMCHK , UXSML COMMON/TOPOG/ CTP(2000),Z0,ITOP C C SAVE C C STATEMENT FUNCTIONS FOR SPATIAL AND VELOCITY TRANSFORMATIONS. C . (IF THE USER WISHES OTHER TRANSFORMATIONS REPLACE THESE STATEMENT C . FUNCTIONS WITH THE APPROPRIATE NEW ONES, OR , IF THE TRANSFORMA- C . TIONS ARE COMPLICATED DELETE THESE STATEMENT FUNCTIONS C . AND ADD EXTERNAL ROUTINES WITH THE SAME NAMES TO DO THE TRANS- C . FORMING.) C FX(X,Y) = X c FY(X,Y) = Y FY(XX,YY)=YY+ITOP*((CTP(IFIX(XX))+(IFIX(XX)-XX)*(CTP(IFIX(XX))- 1CTP(IFIX(XX+1.))))*(Z0-YY)) FU(X,Y) = X FV(X,Y) = Y C C INITIALIZE C ISKIP = I1MACH(5) - 2 ISKIP1 = ISKIP + 1 UXSML = 1.E-30 C C NUMCHK = NCHK LCHK = 1 ICHK = 1 XCHK(1) = 0. YCHK(1) = 0. KFLAG = 0 IZERO = 0 IONE = 1 ITWO = 2 C C C COMPUTE THE X AND Y NORMALIZED (AND POSSIBLY TRANSFORMED) C . DISPLACEMENT COMPONENTS (UX AND VY). C DO 40 J=JS,JEND DO 30 I=IS,IEND UX(I,J) = FU(U(I,J),V(I,J)) VY(I,J) = FV(U(I,J),V(I,J)) IF (UX(I,J).NE.0. .OR. VY(I,J).NE.0.) THEN CON = DISPL/SQRT(UX(I,J)*UX(I,J) + VY(I,J)*VY(I,J)) UX(I,J) = CON*UX(I,J) VY(I,J) = CON*VY(I,J) END IF C C BOOKKEEPING IS DONE IN THE LEAST SIGNIFICANT BITS OF THE UX ARRAY. C . WHEN UX(I,J) IS EXACTLY ZERO THIS CAN PRESENT SOME PROBLEMS. C . TO GET AROUND THIS PROBLEM, SET IT TO A RELATIVELY SMALL NUMBER. C IF(UX(I,J) .EQ. 0.) UX(I,J) = UXSML C C MASK OUT THE LEAST SIGNIFICANT TWO BITS AS FLAGS FOR EACH GRID BOX C . A GRID BOX IS ANY REGION SURROUNDED BY FOUR GRID POINTS. C . FLAG 1 INDICATES WHETHER ANY STREAMLINE HAS PREVIOUSLY PASSED C . THROUGH THIS BOX. C . FLAG 2 INDICATES WHETHER ANY DIRECTIONAL ARROW HAS ALREADY C . APPEARED IN THIS BOX. C . JUDICIOUS USE OF THESE FLAGS PREVENTS OVERCROWDING OF C . STREAMLINES AND DIRECTIONAL ARROWS. C CALL SBYTES( UX(I,J) , IZERO , ISKIP , 2 , 0 , 1 ) C IF (MOD(I,INITA).NE.0 .OR. MOD(J,INITA).NE.0) 1 CALL SBYTES( UX(I,J) , IONE , ISKIP1, 1 , 0 , 1 ) IF (MOD(I,INITB).NE.0 .OR. MOD(J,INITB).NE.0) 1 CALL SBYTES( UX(I,J) , IONE , ISKIP , 1 , 0 , 1 ) C 30 CONTINUE 40 CONTINUE C 50 CONTINUE C C START A STREAMLINE. EXPERIENCE HAS SHOWN THAT A PLEASING PICTURE C . WILL BE PRODUCED IF NEW STREAMLINES ARE STARTED ONLY IN GRID C . BOXES THAT PREVIOUSLY HAVE NOT HAD OTHER STREAMLINES PASS THROUGH C . THEM. AS LONG AS A REASONABLY DENSE PATTERN OF AVAILABLE BOXES C . IS INITIALLY PRESCRIBED, THE ORDER OF SCANNING THE GRID PTS. FOR C . AVAILABLE BOXES IS IMMATERIAL C C FIND AN AVAILABLE BOX FOR STARTING A STREAMLINE C IF (KFLAG.NE.0) GO TO 90 DO 70 J=JS,JEND1 DO 60 I=IS,IEND1 CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) IF ( IAND( IUX , IONE ) .EQ. IZERO ) GO TO 80 60 CONTINUE 70 CONTINUE C C MUST BE NO AVAILABLE BOXES FOR STARTING A STREAMLINE C GO TO 190 80 CONTINUE C C INITILIZE PARAMETERS FOR STARTING A STREAMLINE C . TURN THE BOX OFF FOR STARTING A STREAMLINE C . CHECK TO SEE IF THIS BOX HAS MISSING DATA (IMSG.NE.0). IF SO , C . FIND A NEW STARTING BOX C CALL SBYTES( UX(I,J) , IONE , ISKIP1 , 1 , 0 , 1 ) IF ( IMSG.EQ.0) GO TO 85 IF (U(I,J).EQ.UVMSG .OR. U(I,J+1).EQ.UVMSG .OR. 1 U(I+1,J).EQ.UVMSG .OR. U(I+1,J+1).EQ.UVMSG) GO TO 50 C 85 ISAV = I JSAV = J KFLAG = 1 PLMN1 = +1. GO TO 100 90 CONTINUE C C COME TO HERE TO DRAW IN THE OPPOSITE DIRECTION C KFLAG = 0 PLMN1 = -1. I = ISAV J = JSAV 100 CONTINUE C C INITIATE THE DRAWING SEQUENCE C . START ALL STREAMLINES IN THE CENTER OF A BOX C NBOX = 0 ITER = 0 IF (KFLAG.NE.0) ICHKB = ICHK+1 IF (ICHKB.GT.NUMCHK) ICHKB = 1 X = FLOAT(I)+0.5 Y = FLOAT(J)+0.5 XBASE = X YBASE = Y CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) CALL PLOTIT (IFX,IFY,0) CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) IF ( (KFLAG.EQ.0) .OR. (IAND( IUX , ITWO ) .NE. 0 ) ) GO TO 110 C C GRID BOX MUST BE ELIGIBLE FOR A DIRECTIONAL ARROW C CALL GNEWPT (UX,VY,IMAX,JPTSY) MFLAG = 1 GO TO 160 C 110 CONTINUE C C PLOT LOOP C . CHECK TO SEE IF THE STREAMLINE HAS ENTERED A NEW GRID BOX C IF (I.NE.IFIX(X) .OR. J.NE.IFIX(Y)) GO TO 120 C C MUST BE IN SAME BOX CALCULATE THE DISPLACEMENT COMPONENTS C CALL GNEWPT (UX,VY,IMAX,JPTSY) C C UPDATE THE POSITION AND DRAW THE VECTOR C X = X+PLMN1*DELX Y = Y+PLMN1*DELY CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) CALL PLOTIT (IFX,IFY,1) ITER = ITER+1 C C CHECK STREAMLINE PROGRESS EVERY 'ITERP' OR SO ITERATIONS C IF (MOD(ITER,ITERP).NE.0) GO TO 115 IF (ABS(X-XBASE).LT.DISPC .AND. ABS(Y-YBASE).LT.DISPC ) GO TO 50 XBASE = X YBASE = Y GO TO 110 115 CONTINUE C C SHOULD THE CIRCULAR LISTS BE CHECKED FOR STREAMLINE CROSSOVER C IF ( (ITERC.LT.0) .OR. (MOD(ITER,ITERC).NE.0) ) GO TO 110 C C MUST WANT THE CIRCULAR LIST CHECKED C GO TO 130 120 CONTINUE C C MUST HAVE ENTERED A NEW GRID BOX CHECK FOR THE FOLLOWING : C . (1) ARE THE NEW POINTS ON THE GRID C . (2) CHECK FOR MISSING DATA IF MSG DATA FLAG (IMSG) HAS BEEN SET. C . (3) IS THIS BOX ELIGIBLE FOR A DIRECTIONAL ARROW C . (4) LOCATION OF THIS ENTRY VERSUS OTHER STREAMLINE ENTRIES C NBOX = NBOX+1 C C CHECK (1) C IF (IFIX(X).LT.IS .OR. IFIX(X).GT.IEND1) GO TO 50 IF (IFIX(Y).LT.JS .OR. IFIX(Y).GT.JEND1) GO TO 50 C C CHECK (2) C IF ( IMSG.EQ.0) GO TO 125 II = IFIX(X) JJ = IFIX(Y) IF (U(II,JJ).EQ.UVMSG .OR. U(II,JJ+1).EQ.UVMSG .OR. 1 U(II+1,JJ).EQ.UVMSG .OR. U(II+1,JJ+1).EQ.UVMSG) GO TO 50 125 CONTINUE C C CHECK (3) C CALL GBYTES( UX(I,J) , IUX , ISKIP , 2 , 0 , 1 ) IF ( IAND( IUX , ITWO ) .NE. 0) GO TO 130 MFLAG = 2 GO TO 160 130 CONTINUE C C CHECK (4) C DO 140 LOC=1,LCHK IF (ABS( X-XCHK(LOC) ).GT.CSTOP .OR. 1 ABS( Y-YCHK(LOC) ).GT.CSTOP) GO TO 140 LFLAG = 1 IF (ICHKB.LE.ICHK .AND. LOC.GE.ICHKB .AND. LOC.LE.ICHK) LFLAG = 2 IF (ICHKB.GE.ICHK .AND. (LOC.GE.ICHKB .OR. LOC.LE.ICHK)) LFLAG = 2 IF (LFLAG.EQ.1) GO TO 50 140 CONTINUE LCHK = MIN0(LCHK+1,NUMCHK) ICHK = ICHK+1 IF (ICHK.GT.NUMCHK) ICHK = 1 XCHK(ICHK) = X YCHK(ICHK) = Y I = IFIX(X) J = IFIX(Y) CALL SBYTES( UX(I,J) , IONE , ISKIP1 , 1 , 0 , 1 ) IF (NBOX.LT.5) GO TO 150 ICHKB = ICHKB+1 IF (ICHKB.GT.NUMCHK) ICHKB = 1 150 CONTINUE GO TO 110 C 160 CONTINUE C C THIS SECTION DRAWS A DIRECTIONAL ARROW BASED ON THE MOST RECENT DIS- C . PLACEMENT COMPONENTS ,DELX AND DELY, RETURNED BY GNEWPT. IN EARLIE C . VERSIONS THIS WAS A SEPARATE SUBROUTINE (CALLED DRWDAR). IN THAT C . CASE ,HOWEVER, FX AND FY WERE DEFINED EXTERNAL SINCE THESE C . FUNCTIONS WERE USED BY BOTH DRWSTR AND DRWDAR. IN ORDER TO C . MAKE ALL DEFAULT TRANSFORMATIONS STATEMENT FUNCTIONS I HAVE C . PUT DRWDAR HERE AND I WILL USE MFLAG TO RETURN TO THE CORRECT C . LOCATION IN THE CODE. C C IF ( (DELX.EQ.0.) .AND. (DELY.EQ.0.) ) GO TO 50 IF((ABS(DELX).LE.1.E-15) .AND. (ABS(DELY).LE.1.E-15)) GO TO 50 C CALL SBYTES( UX(I,J) ,IONE , ISKIP , 1 ,0 , 1 ) D = ATAN2(-DELX,DELY) D30 = D+0.5 170 YY = -AROWL*COS(D30)+Y XX = +AROWL*SIN(D30)+X CALL FL2INT (FX(XX,YY),FY(XX,YY),IFXX,IFYY) CALL PLOTIT (IFXX,IFYY,1) CALL FL2INT (FX(X,Y),FY(X,Y),IFX,IFY) CALL PLOTIT (IFX,IFY,0) IF (D30.LT.D) GO TO 180 D30 = D-0.5 GO TO 170 180 IF (MFLAG.EQ.1) GO TO 110 IF (MFLAG.EQ.2) GO TO 130 C 190 CONTINUE C C FLUSH PLOTIT BUFFER C CALL PLOTIT(0,0,0) RETURN END SUBROUTINE GNEWPT (UX,VY,IMAX,JPTSY) C C INTERPOLATION ROUTINE TO CALCULATE THE DISPLACEMANT COMPONENTS C . THE PHILOSPHY HERE IS TO UTILIZE AS MANY POINTS AS POSSIBLE C . (WITHIN REASON) IN ORDER TO OBTAIN A PLEASING AND ACCURATE PLOT. C . INTERPOLATION SCHEMES DESIRED BY OTHER USERS MAY EASILY BE C . SUBSTITUTED IF DESIRED. C DIMENSION UX(IMAX,JPTSY) ,VY(IMAX,JPTSY) COMMON /STR01/ IS ,IEND ,JS ,JEND 1 , IEND1 ,JEND1 ,I ,J 2 , X ,Y ,DELX ,DELY 3 , ICYC1 ,IMSG1 ,IGFL1 COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG 1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP C SAVE C C FDLI - DOUBLE LINEAR INTERPOLATION FORMULA C FBESL - BESSEL 16 PT INTERPOLATION FORMULA ( MOST USED FORMULA ) C FQUAD - QUADRATIC INTERPOLATION FORMULA C FDLI(Z,Z1,Z2,Z3,DX,DY) = (1.-DX)*((1.-DY)*Z +DY*Z1) 1 + DX *((1.-DY)*Z2+DY*Z3) FBESL(Z,ZP1,ZP2,ZM1,DZ)=Z+DZ*(ZP1-Z+0.25*(DZ-1.)*((ZP2-ZP1-Z+ZM1) 1 +0.666667*(DZ-0.5)*(ZP2-3.*ZP1+3.*Z-ZM1))) FQUAD(Z,ZP1,ZM1,DZ)=Z+0.5*DZ*(ZP1-ZM1+DZ*(ZP1-2.*Z+ZM1)) C DX = X-AINT(X) DY = Y-AINT(Y) C IF( IMSG.NE.0.OR.IGFLG.NE.0) GO TO 20 C IM1 = I-1 IP2 = I+2 C C DETERMINE WHICH INTERPOLATION FORMULA TO USE DEPENDING ON I,J LOCATION C . THE FIRST CHECK IS FOR I,J IN THE GRID INTERIOR. C IF (J.GT.JS .AND. J.LT.JEND1 .AND. I.GT.IS .AND. I.LT.IEND1) 1 GO TO 30 IF (J.EQ.JEND1 .AND. I.GT.IS .AND. I.LT.IEND1) GO TO 40 IF (J.EQ.JS) GO TO 20 C IF (ICYC1.EQ.1) GO TO 10 C C MUST NOT BE CYCLIC C IF (I.EQ.IS) GO TO 20 IF (I.EQ.IEND1) GO TO 50 GO TO 20 10 CONTINUE C C MUST BE CYCLIC IN THE X DIRECTION C IF (I.EQ.IS .AND. J.LT.JEND1) GO TO 12 IF (I.EQ.IEND1 .AND. J.LT.JEND1) GO TO 14 IF (J.EQ.JEND1 .AND. I.EQ.IS) GO TO 16 IF (J.EQ.JEND1 .AND. I.EQ.IEND1) GO TO 18 GO TO 20 12 IM1 = IEND1 GO TO 30 14 IP2 = IS+1 GO TO 30 16 IM1 = IEND1 GO TO 40 18 IP2 = IS+1 GO TO 40 C 20 CONTINUE C C DOUBLE LINEAR INTERPOLATION FORMULA. THIS SCHEME WORKS AT ALL POINTS C . BUT THE RESULTING STREAMLINES ARE NOT AS PLEASING AS THOSE DRAWN C . BY FBESL OR FQUAD. CURRENTLY THIS IS USED AT THIS IS UTILIZED C . ONLY AT CERTAIN BOUNDARY POINTS OR IF IGFLG IS NOT EQUAL TO ZERO. C DELX = FDLI (UX(I,J),UX(I,J+1),UX(I+1,J),UX(I+1,J+1),DX,DY) DELY = FDLI (VY(I,J),VY(I,J+1),VY(I+1,J),VY(I+1,J+1),DX,DY) RETURN 30 CONTINUE C C USE A 16 POINT BESSEL INTERPOLATION SCHEME C UJM1 = FBESL (UX(I,J-1),UX(I+1,J-1),UX(IP2,J-1),UX(IM1,J-1),DX) UJ = FBESL (UX(I,J),UX(I+1,J),UX(IP2,J),UX(IM1,J),DX) UJP1 = FBESL (UX(I,J+1),UX(I+1,J+1),UX(IP2,J+1),UX(IM1,J+1),DX) UJP2 = FBESL (UX(I,J+2),UX(I+1,J+2),UX(IP2,J+2),UX(IM1,J+2),DX) DELX = FBESL (UJ,UJP1,UJP2,UJM1,DY) VJM1 = FBESL (VY(I,J-1),VY(I+1,J-1),VY(IP2,J-1),VY(IM1,J-1),DX) VJ = FBESL (VY(I,J),VY(I+1,J),VY(IP2,J),VY(IM1,J),DX) VJP1 = FBESL (VY(I,J+1),VY(I+1,J+1),VY(IP2,J+1),VY(IM1,J+1),DX) VJP2 = FBESL (VY(I,J+2),VY(I+1,J+2),VY(IP2,J+2),VY(IM1,J+2),DX) DELY = FBESL (VJ,VJP1,VJP2,VJM1,DY) RETURN 40 CONTINUE C C 12 POINT INTERPOLATION SCHEME APPLICABLE TO ONE ROW FROM TOP BOUNDARY C UJM1 = FBESL (UX(I,J-1),UX(I+1,J-1),UX(IP2,J-1),UX(IM1,J-1),DX) UJ = FBESL (UX(I,J),UX(I+1,J),UX(IP2,J),UX(IM1,J),DX) UJP1 = FBESL (UX(I,J+1),UX(I+1,J+1),UX(IP2,J+1),UX(IM1,J+1),DX) DELX = FQUAD (UJ,UJP1,UJM1,DY) VJM1 = FBESL (VY(I,J-1),VY(I+1,J-1),VY(IP2,J-1),VY(IM1,J-1),DX) VJ = FBESL (VY(I,J),VY(I+1,J),VY(IP2,J),VY(IM1,J),DX) VJP1 = FBESL (VY(I,J+1),VY(I+1,J+1),VY(IP2,J+1),VY(IM1,J+1),DX) DELY = FQUAD (VJ,VJP1,VJM1,DY) RETURN 50 CONTINUE C C 9 POINT INTERPOLATION SCHEME FOR USE IN THE NON-CYCLIC CASE C . AT I=IEND1 ; JS.LT.J AND J.LE.JEND1 C UJP1 = FQUAD (UX(I,J+1),UX(I+1,J+1),UX(IM1,J+1),DX) UJ = FQUAD (UX(I,J),UX(I+1,J),UX(IM1,J),DX) UJM1 = FQUAD (UX(I,J-1),UX(I+1,J-1),UX(IM1,J-1),DX) DELX = FQUAD (UJ,UJP1,UJM1,DY) VJP1 = FQUAD (VY(I,J+1),VY(I+1,J+1),VY(IM1,J+1),DX) VJ = FQUAD (VY(I,J),VY(I+1,J),VY(IM1,J),DX) VJM1 = FQUAD (VY(I,J-1),VY(I+1,J-1),VY(IM1,J-1),DX) DELY = FQUAD (VJ,VJP1,VJM1,DY) RETURN END SUBROUTINE CHKCYC (U,V,IMAX,JPTSY,IER) C C CHECK FOR CYCLIC CONDITION C DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) COMMON /STR01/ IS ,IEND ,JS ,JEND 1 , IEND1 ,JEND1 ,I ,J 2 , X ,Y ,DELX ,DELY 3 , ICYC1 ,IMSG1 ,IGFL1 C SAVE DO 10 J=JS,JEND IF (U(IS,J).NE.U(IEND,J)) GO TO 20 IF (V(IS,J).NE.V(IEND,J)) GO TO 20 10 CONTINUE C C MUST BE CYCLIC C RETURN 20 CONTINUE C C MUST NOT BE CYCLIC C . CHANGE THE PARAMETER AND SET IER = -1 C ICYC1 = 0 IER = -1 RETURN C C----------------------------------------------------------------------- C REVISION HISTORY C C OCTOBER, 1979 FIRST ADDED TO ULIB C C OCTOBER, 1980 ADDED BUGS SECTION C C JUNE, 1984 REMOVED STATEMENT FUNCTIONS ANDF AND ORF, C CONVERTED TO FORTRAN77 AND GKS. C C MAY, 1988 CHANGED CODE (IN SUBROUTINE DRWSTR) WHICH PROTECTS C UX ELEMENTS FROM BECOMING ZERO. THE ORIGINAL CODE C CAUSED UNDERFLOW ON IBM MACHINES. (DJK) C----------------------------------------------------------------------- C END '\eof' echo CREATE_COLORPL.GKS cat > colorpl.gks<< '\eof' subroutine colorpl(zdat,nn,n1,mm,m1,ism,imap,iflg,vps,nl, . ipal,ilabl,zmin,zmax,izval,ihlflg,ihcflg) c parameter(nl=9,ilb=2) parameter(ilb=2) c parameter(nbnd=nl+1,nlbl=nl+ilb) parameter(niama=900000,mcs=100000) c parameter(niama=1500000,mcs=200000) dimension zdat(nn,mm),rwrk(3000),iwrk(3000),iama(niama) dimension iasf(13) dimension xcra(mcs),ycra(mcs) dimension iaia(100),igia(100) c========================================================================= c Program for plotting the colormap of the zdat(nn,mm) field c c nn - first dimension of the array zdat(nn,mm) c mm - second dimension of the array zdat(nn,mm) c n1 - number of points in the 1st direction to be plotted c m1 - number of points in the 2nd direction to be plotted c nl - number of contouring levels c nl+1 - number of color bands (=nbnd) c ilb - flag for the label bar; (=0) labels alligned with the boxes, c (=1) labels alligned with the partions between the boxes, c (=2) as for (=1) including the ends of the labelbar c ism - flag for smoothing, =1 yes, =0 no c imap - flag for coordinate transformation (see subroutine cpmpxy) c =0 no mapping Cartesian grid, =3 topo-following mapping c supply common/topog/ c iflg - flag for the field c vps - variable that determines the viewport shape c (=0.) shape will be automatically determined to achieve the c optimal fit into the viewport window c (<0.) specifies the exact shape, abs(vps)=width/height c c The table of colors is supplied in the subroutine DFCLRS c There is currently a maximum of 15 colors, color with the index c 1 is used for contours (unless it is changed in the appropriate c place in this program depending on the field plotted), colors c 2-(nl+1) are used for color bands. This is also a place where c the background color can be set up. c c========================================================================== c list of indices and labels dimension lind(101) c dimension lind(nl+1) character*20 llbs(102) c character*20 llbs(nl+2) c routine for coloring areas external colram c GKS aspect source flags data iasf /13*1/ c list of indices for label-bar routine nbnd=nl+1 nlbl=nl+ilb do i=1,nbnd lind(i)=i+1 end do c aspect source flags (?) call gsasf(iasf) c solid fill call gsfais(1) c set the viewport frame call cpseti('SET',1) call cpsetr('VPL - VIEWPORT LEFT' ,.15) call cpsetr('VPR - VIEWPORT RIGHT',.85) call cpsetr('VPB - VIEWPORT BOTTOM',.20) call cpsetr('VPT - VIEWPORT TOP',.90) if (vps.lt.0.) .call cpsetr('VPS - VIEWPORT SHAPE',vps) c format numeric labels call cpseti('NSD - NUMBER OF SIGNIFICANT DIGITS',3) call cpseti('NOF - NUMERIC OMISSION FLAGS',5) c coordinate transformation call cpseti('MAP - MAPPING FLAG',imap) c smoothing if (ism.eq.1) then call cpseti('PIC - POINT INTERPOLATION FOR CONTOURS',2) call cpsetr('T2D - TENSION ON 2D SPLINES',0.) elseif (ism.eq.-1) then call cpseti('PIC - POINT INTERPOLATION FOR CONTOURS',-10) call cpsetr('T2D - TENSION ON 2D SPLINES',0.) elseif (ism.eq.2) then C print *,'smoothing :',ism call cpseti('PIC - POINT INTERPOLATION FOR CONTOURS',0) call cpsetr('SSL - SMOOTHED SEGMENT LENGHT',0.05) !Be carefule call cpsetr('T2D - TENSION ON 2D SPLINES',0.00000000001) elseif (ism.eq.-2) then call cpseti('PIC - POINT INTERPOLATION FOR CONTOURS',0) call cpsetr('T2D - TENSION ON 2D SPLINES',-0.1) else call cpseti('PIC - POINT INTERPOLATION FOR CONTOURS',0) call cpsetr('T2D - TENSION ON 2D SPLINES',0.) endif c contour levels C CLS - Contour Level Selection - how many contours and which level C selection methos is used (16) C 0 - does not pick contour levels at all, C current values NCL, CLV are not changed C -n - generates n contour lines C +n - by default, description p.259 c nl contour levels inside the data (zmin,zmax) interval c (nl+1) bands and (nl+1) colors if (izval.eq.0) then ncl=-nl call cpseti('CLS - CONTOUR LEVEL SELECTOR',ncl) else c nl contour levels inside the user determined interval c (nl+1) bands and (nl+1) colors call cpseti('CLS - CONTOUR LEVEL SELECTOR',0) call cpseti('NCL - NUMBER OF COUNTOUR LEVELS',nl) ciu=(zmax-zmin)/float(nbnd) do i=1,nl clev=zmin + i*ciu call cpseti('PAI - PARAMETER ARRAY INDEX',i) call cpsetr('CLV - COUNTOUR LEVEL VALUES',clev) end do call cpsetr('CIU - CONTOUR INTERVAL USED',ciu) end if call setusv('LW',2000) c intialize area map, contour lines call arinam(iama,niama) c initialize drawing call cprect(zdat,nn,n1,m1,rwrk,3000,iwrk,3000) call cpclam(zdat,rwrk,iwrk,iama) call setusv('LW',1000) c get min and max value if (izval.eq.0) then call cpgetr('ZMN',zmin) call cpgetr('ZMX',zmax) end if c color indices call dfclrs(nl,ipal,zmin,zmax) c color the map call arscam(iama,xcra,ycra,mcs,iaia,igia,100,colram) c check for the constant field flag call cpgeti('CFF - CONSTANT FIELD FLAG',icff) if (icff.ne.0) goto 100 c set up the text color call cpseti('ILC - INFORMATION LABEL TEXT',1) c set up the contour line color if (iflg.eq.11.or.iflg .eq.12) then do i=1,nl call cpseti('PAI - PARAMETER ARRAY INDEX',i) call cpseti('CLC - COUNTOUR LINE COLOR',15) end do else do i=1,nl call cpseti('PAI - PARAMETER ARRAY INDEX',i) call cpseti('CLC - COUNTOUR LINE COLOR',1) end do end if c set up the contour line pattern c dashed lines for negative values, solid lines for positive values do i=1,nl call cpseti('PAI - PARAMETER ARRAY INDEX',i) cval=zmin+real(i)*(zmax-zmin)/float(nbnd) if (cval.lt.0.0) then call cpsetc('CLD - CONTOUR LINE DASH PATTERN', . '$$''''$$''''$$''''$$''''') else if (cval.eq.0.0) then call cpsetc('CLD - INVISIBLE CONTOUR LINE PATTERN', . '''''''''''''''''''''''''''''''''') else call cpsetc('CLD - CONTOUR LINE SOLID PATTERN', . '$$$$$$$$$$$$$$$$') end if end do call cpcldr(zdat,rwrk,iwrk) c contour line labels c LLP - Line Label Positioning: c 0 - no label are drawn c +/-1 - labels are positioned along contour lines by setting up c a dash patern including the label and then drawing the c contour with the Dashed utility (1) c 2 - labels are positioned along contour using moderate cost scheme c -2 - like above but smoothing is suspended durig placement c 3 - more expensive penantly scheme c -3 - like above but smoothing is suspended durig placement c CLU - Contour Level Use Flags: c 0 - no contour line or labels are drawn at this level c 1 - a contour line is drawn without label c 2 - contour labels are drawn but no line is drawn c 3 - both a contour line and labels are drawn c LLO - Line Label Orientation: c 0 - all label are written at the angle specified by LLA (0.0) c =/= 0 parallel to the contour line c LIS - Interval between labeled interval contour, if CLS>0 and CIS>0 (5) c LLS - Line Label Size - specifies size (width) of a character in a contour c line label as a fraction of the width of the wiewport multiple by CWM c LLB - Line Label Box - control how contour line labels are boxed (0) c 0 - Labels drawn by CPLBDR are not boxed c 1 - primer of the box is drawn in the same color as the label c after the label is drawn c 2 - box is filled in the color specified by LBC before label is drawn c 3 - both 1 and 2 c LBC - Label Box Color - filing is done by color index specified by LBC c <0 - current fill area color index is used c >=0 - specifies the color index to be used c 0 - by default (background color) call cpseti('LLP - LINE LABEL POSITIONING',2) call cpseti('LLO - LINE LABEL ORIENTATION',1) LIS0=ilabl C call cpseti('LIS - LABEL INTERVAL SPECIFIER',LIS0) C call cpsetr('CWM - CHARACTER WIDTH MULTIPLER',1.) call cpsetr('LLS - LINE LABEL SIZE',.0125) call cpseti('LBC - LABEL BOX COLOR',0) call cpseti('LLB - LINE LABEL BOX',3) do i=1,nl call cpseti('PAI - PARAMETER ARRAY INDEX',i) call cpseti('CLU - CONTOUR LEVEL USE FLAGS',1) if(ilabl.gt.0) then if(i/LIS0*LIS0.eq.i) . call cpseti('CLU - CONTOUR LEVEL USE FLAGS',3) endif end do c high/low label parameters if (ihlflg.gt.0) then ccwm=1. if((abs(vps) .lt. 1.).and.(vps.ne.0)) ccwm=abs(vps) cils=0.012/ccwm call cpsetr('HLS - HIGH/LOW LABEL SIZE', cils) !Default HLS=.012 C call cpsetr('CWM - CHARACTER WIDTH MULTIPLER',1.) if (ihlflg.eq.1) then call cpsetc('HLT - HIGH/LOW LABEL TEXT STRING','$ZDV$') else if(ihlflg.eq.2) then call cpsetc('HLT - HIGH/LOW LABEL TEXT STRING', 1 'H($ZDV$)''L($ZDV$)') else if(ihlflg.eq.3) then call cpsetc('HLT - HIGH/LOW LABEL TEXT STRING', 1 'H?B?$ZDV$?E?''L?B?$ZDV$?E?') c 1 'H:B:$ZDV$:E:''L:B:$ZDV$:E:') else if(ihlflg.eq.4) then call cpsetc('HLT - HIGH/LOW LABEL TEXT STRING','H''L') endif else call cpsetr('HLS-HIGH/LOW LABEL SIZE', 0.0) endif if ((ihcflg.ge.0).and.(ihcflg.le.4)) then c hachuring flags c HCF = 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 HCS - distance between hachures along contour line, default is 0.1 c HCL - lenght of hachures as a fraction of width of the viewport, (0.004) c HCL>0 hachures are drawn on the downslope side of the contour c HCL<0 hachures are drawn on the upslope side of the contour call cpseti('HCF - HACHURE FLAF',ihcflg) endif 100 continue c information labels if (izval.eq.1) then C $ZMX$ - Maximum value on the data array C $ZMN$ - Minimum value on the data array C $SFU$ - Current scale factor C $CMX$ - Maximum contour level C $CMN$ - Minimum contour level C $CIU$ - Contour interval used call cpsetc('ILT - INFORMATION LABEL TEXT STRING', . 'MIN: $ZMN$, MAX: $ZMX$, CONTOUR INTERVAL $CIU$') else call cpsetc('ILT - INFORMATION LABEL TEXT STRING', . 'CONTOUR FROM $CMN$ TO $CMX$ BY $CIU$') endif call cpsetr('ILX-INFORMATION LABEL X POSITION',0.5) !0.7 call cpsetr('ILY-INFORMATION LABEL Y POSITION',1.05) call cpgetr('ILS',cils) ccwm=1. C call cpsetr('CWM-CHARACTER WIDTH MULTIPLER',ccwm) if((abs(vps) .lt. 1.).and.(vps.ne.0)) ccwm=abs(vps) cils=0.012/ccwm call cpsetr('ILS-INFORMATION LABEL SIZE',cils) call cpseti('ILP-INFORMATION LABEL POSITIONING',0) call cplbdr(zdat,rwrk,iwrk) C call cpsetr('CWM-CHARACTER WIDTH MULTIPLER',1.) c determine the mapping of values vs. colors for the label bar if (izval.eq.0) then call cpgetr('ZMN',zmin) call cpgetr('ZMX',zmax) end if do i=1,nlbl call cpsetr('ZDV - Z DATA VALUE', . ZMIN+REAL(I-1)*(ZMAX-ZMIN)/float(nbnd)) call cpgetc('ZDV - Z DATA VALUE',LLBS(i)) end do c label bar call lbseti('CBL - COLOR OF BOX LINES',1) c call lblbar(0,.15,.85,.075,.175,nbnd,1.,.5,LIND,0, c . LLBS,nlbl,1) call lblbar(0,.15,.85,.005,.055,nbnd,1.,.5,LIND,0, . LLBS,nlbl,1) call bndary return end subroutine colram(xcra,ycra,ncra,iaia,igia,naia) dimension xcra(*),ycra(*),iaia(*),igia(*) ifll=1 do 101 i=1,naia if(iaia(i).lt.0) ifll=0 101 continue if(ifll.ne.0) then ifll=0 do 102 i=1,naia if(igia(i).eq.3) ifll=iaia(i) 102 continue if(ifll.gt.0.and.ifll.lt.101) then call gsfaci(ifll+1) call gfa (ncra-1,xcra,ycra) endif endif return end subroutine dfclrs(nl,ipal,zmin,zmax) dimension rgbv(3,102) c for index 0 (bacgroud color) and index 1 (text color) check ncargdef if ((ipal.ge.10).and.(ipal.le.15)) then iminus=0 iplus=0 if (zmax.le.0) then iminus=nl elseif(zmin.ge.0) then iplus=nl else iminus=abs(float(nl)*zmin/(zmax-zmin))+1 c iplus=abs(float(nl)*zmax/(zmax-zmin))+1 del=(zmax-zmin)/float(nl+1) zmin0=zmin+iminus*del ! check value zmax0=zmin0+del ! around zero if((abs(zmin0)).gt.(abs(zmax0))) iminus=iminus+1 ! for -/+ data iplus=nl-iminus endif endif clear color map do i=2,102 rgbv(1,i)=1.0 rgbv(2,i)=1.0 rgbv(3,i)=1.0 enddo c red into light blue if (ipal.eq.1) then do i=2,nl+2 rgbv(1,i)=.65 rgbv(2,i)=float(i-2)/float(nl) rgbv(3,i)=float(i-2)/float(nl) enddo c + .65, 0., .0, c + .65, .05, .05, c + .65, .1, .1, c + .65, .15, .15, c + .65, .2, .2, c + .65, .25, .25, c + .65, .3, .3, c + .65, .35, .35, c + .65, .4, .4, c + .65, .45, .45, c + .65, .5, .5, c + .65, .55, .55, c + .65, .6, .6, c + .65, .65, .65, c + .65, .7, .7, c + .65, .75, .75, c + .65, .8, .8, c + .65, .85, .85, c + .65, .9, .9, c + .65, .95, .95, c + .65, 1., 1./ else if (ipal.eq.2) then c dark blue into yellow do i=2,nl+2 rgbv(1,i)=.15+float(i-2)*((1.-.15)/float(nl)) rgbv(2,i)=float(i-2)/float(nl) rgbv(3,i)=float(nl+2-i)/float(nl) enddo C + .15, .0, 1., C + .25, .2, .8, C + .35, .3, .7, C + .43, .4, .6, C + .50, .5, .53, C + .60, .6, .47, C + .70, .7, .40, C + .80, .8, .30, C + .9 , .9, .20, C + 1. , 1., .00, else if (ipal.eq.3) then c gray into white do i=2,nl+2 rgbv(1,i)=.3+float(i-2)*((1.-.3)/float(nl)) rgbv(2,i)=.3+float(i-2)*((1.-.3)/float(nl)) rgbv(3,i)=.3+float(i-2)*((1.-.3)/float(nl)) enddo c + .3, .3, .3, c + .35, .35, .35, c + .4, .4, .4, c + .45, .45, .45, c + .5, .5, .5, c + .55, .55, .55, c + .6, .6, .6, c + .65, .65, .65, c + .7, .7, .7, c + .75, .75, .75, c + .8, .8, .8, c + .85, .85, .85, c + .9, .9, .9/ c + .95, .95, .95, c + 1. , 1., 1., c + 1. , 1., 1., c + 1. , 1., 1., c + 1. , 1., 1., c + 1. , 1., 1., c + 1. , 1., 1. / else if (ipal.eq.4) then c white into dark gray (linear scale) do i=2,nl+2 rgbv(1,i)=.3+float(nl+2-i)*((1.-.3)/float(nl)) rgbv(2,i)=.3+float(nl+2-i)*((1.-.3)/float(nl)) rgbv(3,i)=.3+float(nl+2-i)*((1.-.3)/float(nl)) enddo c + 1., 1., 1., c + .924, .924, .924, c + .848, .848, .848, c + .772, .772, .772, c + .696, .696, .696, c + .62, .62, .62, c + .544, .544, .544, c + .468, .468, .468, c + .392, .392, .392, c + .3, .3, .3, c + .3, .3, .3, c + .3, .3, .3, c + .3, .3, .3, c + .3, .3, .3/ else if (ipal.eq.5) then c white into dark gray (quadratic scale) do i=2,nl+2 rgbv(1,i)=.1+float(nl+2-i)*((1.-.1)/float(nl)) rgbv(2,i)=.1+float(nl+2-i)*((1.-.1)/float(nl)) rgbv(3,i)=.1+float(nl+2-i)*((1.-.1)/float(nl)) enddo C + 1., 1., 1., C + .965, .965, .965, C + .915, .915, .915, C + .85, .85, .85, C + .77, .77, .77, C + .72, .72, .72, C + .675, .675, .675, C + .565, .565, .565, C + .46, .46, .46, C + .38, .38, .38, C + .3, .3, .3, C + .22, .22, .22, C + .17, .17, .17, C + .13, .13, .13, C + .09, .09, .09, C + .04, .04, .04, C + 1., 1., 1./ else if (ipal.eq.6) then cc black into yellow, change background color below!!) do i=2,nl+2 rgbv(1,i)=.16+float(i-2)*((1.-.16)/float(nl)) rgbv(2,i)=.16+float(i-2)*((1.-.16)/float(nl)) rgbv(3,i)=.01*exp(float(i-2)/float(nl-3)) enddo C + .16, .16, .04, C + .27, .27, .04, C + .39, .39, .04, C + .51, .51, .04, C + .63, .63, .04, C + .69, .69, .06, C + .75, .75, .09, C + .82, .82, .11, C + .88, .88, .14, C + .94, .94, .16, else if (ipal.eq.7) then c red into dark blue do i=2,nl+2 rgbv(1,i)=1.-float(i-2)/float(nl) rgbv(2,i)=0. rgbv(3,i)=float(i-2)/float(nl) enddo c + 1.0, 0., .0, c + .95, 0., .05, c + .90, 0., .1, c + .85, 0., .15, c + .80, 0., .2, c + .75, 0., .25, c + .70, 0., .3, c + .65, 0., .35, c + .60, 0., .4, c + .55, 0., .45, c + .50, 0., .5, c + .45, 0., .55, c + .40, 0., .6, c + .35, 0., .65, c + .30, 0., .7, c + .25, 0., .75, c + .20, 0., .8, c + .15, 0., .85, c + .10, 0., .9, c + .05, 0., .95, c + 0.0, 0., 1./ else if (ipal.eq.8) then c dark blue into red do i=2,nl+2 rgbv(1,i)=float(i-2)/float(nl) rgbv(2,i)=0. rgbv(3,i)=1.-float(i-2)/float(nl) enddo else if (ipal.eq.9) then cc white do i=2,nl+2 rgbv(1,i)=1. rgbv(2,i)=1. rgbv(3,i)=1. enddo else if ((ipal.eq.10).or.(ipal.eq.11).or.(ipal.eq.12)) then c10 dark blue (violet) - minus, red -plus, max colors for min, max value c11 seledin (blue sky) - minus, red -plus, max colors for min, max value c12 seledin (blue water)- minus, red -plus, max colors for min, max value darks=.8 dark=1.-darks do i=2,nl+2 rgbv(2,i)=0. enddo do i=2,iminus-1+2 if(ipal.eq.10) then rgbv(1,i)=float(i-2)/float(iminus) rgbv(2,i)=float(i-2)/float(iminus) else if(ipal.eq.11) then rgbv(1,i)=float(i-2)/float(iminus) rgbv(2,i)=darks+float(i-2)/float(iminus)*dark else if(ipal.eq.12) then rgbv(1,i)=float(i-2)/float(iminus) rgbv(2,i)=1. endif enddo do i=nl-iplus+2,nl+2 rgbv(3,i)=1.-float(i-nl+iplus-2+1)/float(iplus+1) rgbv(2,i)=1.-float(i-nl+iplus-2+1)/float(iplus+1) enddo else if ((ipal.eq.13).or.(ipal.eq.14).or.(ipal.eq.15)) then c13 dark blue (violet) - minus, red -plus, equal color scale for values c14 seledin (blue sky) - minus, red -plus, equal color scale for values c15 seledin (blue water)- minus, red -plus, equal color scale for values darks=.8 dark=1.-darks do i=2,nl+2 rgbv(2,i)=0. enddo if (iminus.gt.iplus) then skip=float(iplus+1)/float(iminus) do i=2,iminus-1+2 if(ipal.eq.13) then rgbv(1,i)=dark+float(i-2)/float(iminus)*darks rgbv(2,i)=dark+float(i-2)/float(iminus)*darks else if(ipal.eq.14) then rgbv(1,i)=dark+float(i-2)/float(iminus)*darks rgbv(2,i)=darks+float(i-2)/float(iminus)*dark else if(ipal.eq.15) then rgbv(1,i)=dark+float(i-2)/float(iminus)*darks rgbv(2,i)=1. endif enddo do i=nl+2-iplus,nl+2 rgbv(3,i)=1.-float(i-nl+iplus-2+1)/float(iminus)*darks rgbv(2,i)=1.-float(i-nl+iplus-2+1)/float(iminus)*darks enddo elseif (iplus.gt.iminus) then skip=1.-float(iminus)/float(iplus+1) do i=2,iminus-1+2 if(ipal.eq.13) then rgbv(1,i)=dark+(float(i-2)/float(iplus+1)+skip)*darks rgbv(2,i)=dark+(float(i-2)/float(iplus+1)+skip)*darks else if(ipal.eq.14) then rgbv(1,i)=dark+(float(i-2)/float(iplus+1)+skip)*darks rgbv(2,i)=darks+(float(i-2)/float(iplus+1)+skip)*dark else if(ipal.eq.15) then rgbv(1,i)=dark+(float(i-2)/float(iplus+1)+skip)*darks rgbv(2,i)=1. endif enddo do i=nl+2-iplus,nl+2 rgbv(3,i)=1.-float(i-nl+iplus-2+1)/float(iplus+1)*darks rgbv(2,i)=1.-float(i-nl+iplus-2+1)/float(iplus+1)*darks enddo else do i=2,iminus-1+2 if(ipal.eq.13) then rgbv(1,i)=dark+float(i-2)/float(iminus)*darks rgbv(2,i)=dark+float(i-2)/float(iminus)*darks else if(ipal.eq.14) then rgbv(1,i)=dark+float(i-2)/float(iminus)*darks rgbv(2,i)=darks+float(i-2)/float(iminus)*dark else if(ipal.eq.15) then rgbv(1,i)=dark+float(i-2)/float(iminus)*darks rgbv(2,i)=1. endif enddo do i=nl-iplus+2,nl+2 rgbv(3,i)=1.-float(i-nl+iplus-2+1)/float(iplus+1)*darks rgbv(2,i)=1.-float(i-nl+iplus-2+1)/float(iplus+1)*darks enddo endif c if(darks.gt.1.) then c rgbv(1,i)=rgbv(1,i)/darks c rgbv(2,i)=rgbv(2,i)/darks c rgbv(3,i)=rgbv(3,i)/darks c endif else if (ipal.eq.16) then c light blue into light red do i=2,nl+2 rgbv(2,i)=0. enddo ihalf=nl/2 ihalf2=nl-ihalf do i=2,ihalf-1+2 rgbv(1,i)=float(i+ihalf-2)/float(nl) rgbv(2,i)=float(i+ihalf-2)/float(nl) enddo do i=nl-ihalf2+2,nl+2 rgbv(3,i)=1.-float(i-nl+ihalf-2+1)/float(nl) rgbv(2,i)=1.-float(i-nl+ihalf-2+1)/float(nl) enddo darkness=.85 do i=2,nl+2 rgbv(1,i)=rgbv(1,i)*darkness rgbv(2,i)=rgbv(2,i)*darkness rgbv(3,i)=rgbv(3,i)*darkness enddo else if (ipal.eq.17) then rgbv(1,2) =0.800 ! .8 .0 .6 rgbv(2,2) =0.000 rgbv(3,2) =0.600 rgbv(1,3) =0.686 !.686 .0 .6 rgbv(2,3) =0.000 rgbv(3,3) =0.600 rgbv(1,4) =0.571 !.571 .0 .6 rgbv(2,4) =0.000 rgbv(3,4) =0.600 rgbv(1,5) =0.457 !.457 .0 .6 rgbv(2,5) =0.000 rgbv(3,5) =0.600 rgbv(1,6) =0.343 !.343 .0 .6 rgbv(2,6) =0.000 rgbv(3,6) =0.600 rgbv(1,7) =0.229 !.229 .0 .6 rgbv(2,7) =0.000 rgbv(3,7) =0.600 rgbv(1,8) =0.000 rgbv(2,8) =0.000 rgbv(3,8) =0.680 rgbv(1,9) =0.000 rgbv(2,9) =0.000 rgbv(3,9) =0.760 rgbv(1,10)=0.000 rgbv(2,10)=0.000 rgbv(3,10)=0.840 rgbv(1,11)=0.000 rgbv(2,11)=0.000 rgbv(3,11)=0.920 rgbv(1,12)=0.000 rgbv(2,12)=0.314 rgbv(3,12)=1.000 rgbv(1,13)=0.000 rgbv(2,13)=0.429 rgbv(3,13)=1.000 rgbv(1,14)=0.000 rgbv(2,14)=0.543 rgbv(3,14)=1.000 rgbv(1,15)=0.000 rgbv(2,15)=0.657 rgbv(3,15)=1.000 rgbv(1,16)=0.000 rgbv(2,16)=0.771 rgbv(3,16)=1.000 rgbv(1,17)=0.000 rgbv(2,17)=0.886 rgbv(3,17)=1.000 rgbv(1,18)=0.000 rgbv(2,18)=1.000 rgbv(3,18)=1.000 rgbv(1,19)=0.000 rgbv(2,19)=0.400 rgbv(3,19)=0.000 rgbv(1,20)=0.000 rgbv(2,20)=0.431 rgbv(3,20)=0.000 rgbv(1,21)=0.000 rgbv(2,21)=0.462 rgbv(3,21)=0.000 rgbv(1,22)=0.000 rgbv(2,22)=0.492 rgbv(3,22)=0.000 rgbv(1,23)=0.000 rgbv(2,23)=0.523 rgbv(3,23)=0.000 rgbv(1,24)=0.000 rgbv(2,24)=0.554 rgbv(3,24)=0.000 rgbv(1,25)=0.000 rgbv(2,25)=0.585 rgbv(3,25)=0.000 rgbv(1,26)=0.000 rgbv(2,26)=0.615 rgbv(3,26)=0.000 rgbv(1,27)=0.000 rgbv(2,27)=0.646 rgbv(3,27)=0.000 rgbv(1,28)=0.000 rgbv(2,28)=0.677 rgbv(3,28)=0.000 rgbv(1,29)=0.000 rgbv(2,29)=0.708 rgbv(3,29)=0.000 rgbv(1,30)=0.000 rgbv(2,30)=0.738 rgbv(3,30)=0.000 rgbv(1,31)=0.000 rgbv(2,31)=0.769 rgbv(3,31)=0.000 rgbv(1,32)=0.000 rgbv(2,32)=0.800 rgbv(3,32)=0.000 rgbv(1,33)=0.800 rgbv(2,33)=0.450 rgbv(3,33)=0.000 rgbv(1,34)=0.800 rgbv(2,34)=0.483 rgbv(3,34)=0.000 rgbv(1,35)=0.800 rgbv(2,35)=0.517 rgbv(3,35)=0.000 rgbv(1,36)=0.800 rgbv(2,36)=0.550 rgbv(3,36)=0.000 rgbv(1,37)=0.800 rgbv(2,37)=0.583 rgbv(3,37)=0.000 rgbv(1,38)=0.800 rgbv(2,38)=0.617 rgbv(3,38)=0.000 rgbv(1,39)=0.800 rgbv(2,39)=0.650 rgbv(3,39)=0.000 rgbv(1,40)=0.800 rgbv(2,40)=0.699 rgbv(3,40)=0.000 rgbv(1,41)=0.832 rgbv(2,41)=0.747 rgbv(3,41)=0.000 rgbv(1,42)=0.863 rgbv(2,42)=0.796 rgbv(3,42)=0.000 rgbv(1,43)=0.895 rgbv(2,43)=0.844 rgbv(3,43)=0.000 rgbv(1,44)=0.927 rgbv(2,44)=0.893 rgbv(3,44)=0.000 rgbv(1,45)=0.958 rgbv(2,45)=0.941 rgbv(3,45)=0.000 rgbv(1,46)=0.990 rgbv(2,46)=0.990 rgbv(3,46)=0.000 rgbv(1,47)=1.000 rgbv(2,47)=0.300 rgbv(3,47)=0.000 rgbv(1,48)=1.000 rgbv(2,48)=0.364 rgbv(3,48)=0.000 rgbv(1,49)=1.000 rgbv(2,49)=0.429 rgbv(3,49)=0.000 rgbv(1,50)=1.000 rgbv(2,50)=0.493 rgbv(3,50)=0.000 rgbv(1,51)=1.000 rgbv(2,51)=0.557 rgbv(3,51)=0.000 rgbv(1,52)=1.000 rgbv(2,52)=0.621 rgbv(3,52)=0.000 rgbv(1,53)=1.000 rgbv(2,53)=0.686 rgbv(3,53)=0.000 rgbv(1,54)=1.000 rgbv(2,54)=0.750 rgbv(3,54)=0.000 rgbv(1,55)=0.600 rgbv(2,55)=0.000 rgbv(3,55)=0.000 rgbv(1,56)=0.667 rgbv(2,56)=0.000 rgbv(3,56)=0.000 rgbv(1,57)=0.733 rgbv(2,57)=0.000 rgbv(3,57)=0.000 rgbv(1,58)=0.800 rgbv(2,58)=0.000 rgbv(3,58)=0.000 rgbv(1,59)=0.867 rgbv(2,59)=0.000 rgbv(3,59)=0.000 rgbv(1,60)=0.933 rgbv(2,60)=0.000 rgbv(3,60)=0.000 rgbv(1,61)=1.000 rgbv(2,61)=0.000 rgbv(3,61)=0.000 endif c print *,iflg,'Palete:',ipal do 101 i=2,nl+2 c print *,'i=',i,' ',rgbv(1,i),' ',rgbv(2,i),' ',rgbv(3,i) call gscr(1,i,rgbv(1,i),rgbv(2,i),rgbv(3,i)) 101 continue return end subroutine bndary call plotif (0.,0.,0) call plotif (1.,0.,1) call plotif (1.,1.,1) call plotif (0.,1.,1) call plotif (0.,0.,1) call plotif (0.,0.,2) return end subroutine cpmpxy(imap,xinp,yinp,xotp,yotp) c c Transform contours to overlay various mapping transformations: c imap= 0 - Cartesian data: no transformation necessary c imap= 1 - Lat/Lon transformation c imap=-1 - inverse Lat/Lon transformation c imap= 2 - Rho/Theta transformation c imap=-2 - inverse Rho/Theta transformation c imap= 3 - X-identity, Y-terrain-following transformation c common/topog/ ctp(2000),z0,itop c c Handle the EZMAP case ... c if (abs(imap).eq.1) then if (imap.gt.0) then call maptra (yinp,xinp,xotp,yotp) else call maptri (xinp,yinp,yotp,xotp) end if c c ... the polar coordinate case ... c else if (abs(imap).eq.2) then if (imap.gt.0) then xotp=xinp*cos(.017453292519943*yinp) yotp=xinp*sin(.017453292519943*yinp) else xotp=sqrt(xinp*xinp+yinp*yinp) yotp=57.2957795130823*atan2(yinp,xinp) end if c c ... height transformation in the y direction ... c else if(imap.eq.3) then c The height transformation in x direction is linear xotp = xinp c Find next lowest x data point & transform it so that it can be c used as an array index call cpgetr('xc1',xc1) x = xinp-int(xc1) c Distance between next lowest data point and contour point iix=int(x) difx=x-float(iix) c Find next lowest y data point y = yinp c Distance between next lowest data point and contour point iy=int(y) dify=y-float(iy) c Find next highest X and Y data points, c and make sure they are in the domain. ixp1 = min0(jx,iix+1) iyp1 = min0(kx ,iy+1) c Linear interpolation between points to give height at contour point zr=yinp+itop*( ( ctp(ifix(xinp)) . +(ifix(xinp)-xinp)*( ctp(ifix(xinp)) . -ctp(ifix(xinp+1.)) ) )*(z0-yinp) ) yotp=zr c c If imap isn't specified as above, then do an identity transformation. c else xotp = xinp yotp = yinp endif return end subroutine ccm2_rad(th,fth,qv,qc,qr,qia,qib,hx,hy,tlocal)) c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! c history: written September 97 by W. Grabowski c c This is an interface to the CCM2 radiation code. c It assumes that simple microphysics is active. c c IN THE PARALLEL code, each processor calls the subroutine independently c so the dimensions inside CCM2 routine have to match dimensions of arrays c passed. In general, vertical levels are nlev=plev=l-1, and in the c horizontal plane nran=plon=np*mp c c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! include 'param.nml' include 'param.misc' include 'msg.inc' dimension th(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) * fth(1-ih:np+ih, 1-ih:mp+ih, l) common/metric/ zs(1-ih:np+ih,1-ih:mp+ih), . gi(1-ih:np+ih,1-ih:mp+ih), . gmul(l), . c13(1-ih:np+ih,1-ih:mp+ih), . c23(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) cc time in minutes below common/grid/ time,dt,dx,dy,dz,dti,dxi,dyi,dzi,zb,igrid,j3 common/cyclbc/ ibcx,ibcy,ibcz,irlx,irly common/ctherm/ rg,cp,cap,st,g,th00,tt00,pr00,rh00,u00,v00 common/cmoist/ rv,t00,ee0,hlat,hlatv,hlats,hlatf common/profm/tme(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms), . qve(1-ih:nmsp+ih, 1-ih:mmsp+ih, lms) common /thqvbt/vthflx(1-ih:np+ih, 1-ih:mp+ih,l), . vqvflx(1-ih:np+ih, 1-ih:mp+ih,l), . sthflx(1-ih:np+ih, 1-ih:mp+ih,l), . sqvflx(1-ih:np+ih, 1-ih:mp+ih,l), . ceterm(1-ih:np+ih, 1-ih:mp+ih,l), . dsterm(1-ih:np+ih, 1-ih:mp+ih,l), . fmterm(1-ih:np+ih, 1-ih:mp+ih,l), . thlsf(l),qvlsf(l), . radlwh(1-ih:np+ih, 1-ih:mp+ih,l), . radswh(1-ih:np+ih, 1-ih:mp+ih,l) cc radiative fluxes (TO BE WRITTEN TO HISTORY TAPE) common/radflux/ upsw1(1-ih:np+ih,1-ih:mp+ih,l), . dnsw1(1-ih:np+ih,1-ih:mp+ih,l), . uplw1(1-ih:np+ih,1-ih:mp+ih,l), . dnlw1(1-ih:np+ih,1-ih:mp+ih,l) common/ccmrst/ first logical first ccccccccccccccccccccccccccccccccccccccccccccccccccccccc cc communication with radiative tendency routine: cc nran columns are used for radiation cc nz-1 levels in the vertical for radiation model parameter(nran=np*mp,nlev=l-1) dimension parm(nran,13),array(nran,nlev,8) common /com_11/parm,array common /totr/ rads(nran,nlev),radl(nran,nlev) cc temperature tendency due to radiation and radiative fluxes common /rad_save1/ ttend(np,mp,l) common /rad_save2/ upsw(nran,l),dnsw(nran,l), * uplw(nran,l),dnlw(nran,l) ccccccccccccccccccccccccccccccccccccccccccccccccccccccc cc cc cc below is needed only for the simplified microphysics: common/temp_p/ tup,tdn cc statement functions: 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 cc check consistency: nv1 from radiation should be equal to l: if(nlev.ne.l-1) stop 'radiation-levels' cc check if time to call radiation: cc time interval (in minutes) between calls to radiation: rad_int=10. ! does not have to be even number of time steps nrad_int=nint(rad_int*60./dt) cc check if time to call radiation: iter=nint(time*60./dt) if(mod(iter,nrad_int).eq.0 .or. first) then !<--- RAD CALC) then first=.false. cc input data for radiation, get all columns expon=-cp/rg cc coef in quadratic formula for eff ice radii: aa=1.913e-2 bb=.3588 cc=2.146 c cc c cc dayyr is used to pass time to the model cc it includes fraction of the day to pass local time dayyr=354. + time/(24.*60.) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc do 100 j=1,mp do 100 i=1,np ii=(j-1)*mp+i cc here, time is fixed to have solar on all the time and solar constant cc (scon in the code) is decreased (cos is 1 and sol cnst/pi is used) c dayyr=0. parm(ii,1)=dayyr cc rlat is the latitude (longitude is delt with inside the code): c rlat=-3. !equator rlat=40. parm(ii,2)=rlat c c data for levels follow: cc below, k1 is radiation model vertical index (top to bottom), cc k is the dynamnic model vertical index (bottom to top) do 200 k1=1,nlev cc k=nlev-k1+2 preu=1.e3*(the(i,j, k)/tme(i,j, k))**expon pred=1.e3*(the(i,j,k-1)/tme(i,j,k-1))**expon pmid = .5*(preu+pred) tu = th(i,j,k )*tme(i,j,k )/the(i,j,k ) td = th(i,j,k-1)*tme(i,j,k-1)/the(i,j,k-1) t = .5*(tu+td) h2ommr = .5*(qv(i,j,k)+qv(i,j,k-1)) ccc cc c coe_l=comb(t,tdn,tup,0.,1.) ! liquid contribution qca=.5*(qc(i,j,k)+qc(i,j,k-1))*1.e3 CMIREKA qra=.5*(qr(i,j,k)+qr(i,j,k-1))*1.e3 qra=.5*(qia(i,j,k)+qia(i,j,k-1))*1.e3 C qpr=qra*coe_l ! divide between rain and snow C qps=qra-qpr ! divide between rain and snow C qcc=qca*coe_l ! divide between ice and water C qci=qca-qcc ! divide between ice and water cc qltot=qca qitot=qra cc qtot=qltot+qitot if(qtot.le..01) then cldfrc = 0. fraci = 0. wtwp = 0. rief = 0. rwef = 0. else depg=dz rho1=.5*(rho(i,j,k)+rho(i,j,k-1))*gi(i,j) cldfrc = .999 c ----> liquid water path: clwp = rho1*qltot*depg c ----> ice water path: ciwp = rho1*qitot*depg c ----> ratio of ice to (ice+water) fraci=ciwp/(ciwp+clwp+1.e-20) if(fraci.le.1.e-4) fraci=0. c ----> weighted liquid/ice path: wtwp = fraci*ciwp + (1.-fraci)*clwp endif c ----> effective radius for ice: cc include Greg's formula: cc conc_ice=rho1*qitot ! in g/m**3 conc_ice=amax1(1.e-4,amin1(conc_ice,1.)) x=alog10(conc_ice) y=(aa*x+bb)*x+cc rief=10.**y c ----> effective radius for cloud droplets: rwef=10. array(ii,k1,1) = pmid array(ii,k1,2) = t array(ii,k1,3) = h2ommr array(ii,k1,4) = cldfrc array(ii,k1,5) = fraci array(ii,k1,6) = wtwp array(ii,k1,7) = rief array(ii,k1,8) = rwef 200 continue c ps=1.e3*(the(i,j,1)/tme(i,j,1))**expon parm(ii,3)=ps c ts= th(i,j,1)*tme(i,j,1)/the(i,j,1) parm(ii,4)=ts c c tg=thsrf(i,j)/the(i,j,1)*tme(i,j,1) tg=thsrf/the(i,j,1)*tme(i,j,1) parm(ii,5)=tg ! SST c ioro=0 parm(ii,6)=ioro c rghnss=0.01 parm(ii,7)=rghnss c sndpth=0. parm(ii,8)=sndpth c albvss=0.05 parm(ii,9)=albvss c albvsw=0.05 parm(ii,10)=albvsw c albnis=0.05 parm(ii,11)=albnis c albniw=0.05 parm(ii,12)=albniw c frctst=0. parm(ii,13)=frctst c 100 continue c cc cc put solar fluxes to zero in case it is night and CCM2 will not call cc solar routines do j=1,mp do i=1,np ii=(j-1)*mp+i do k=1,l upsw(ii,k)=0. dnsw(ii,k)=0. enddo enddo enddo ccccc cal radiation transfer model: call colmod_ice cc cc do j=1,mp do i=1,np ii=(j-1)*mp+i cc save radiative fluxes (note reverse of indexes): cc convert from cgs into W/m**2 cc NOTE: radiative fluxes should have their halo updated, cc but because we do not use halo's points, we do not do this do k1=1,l k=l-k1+1 upsw1(i,j,k)=upsw(ii,k1)*1.e-3 dnsw1(i,j,k)=dnsw(ii,k1)*1.e-3 uplw1(i,j,k)=uplw(ii,k1)*1.e-3 dnlw1(i,j,k)=dnlw(ii,k1)*1.e-3 enddo cc cc vertical grid structure ----> z cc grnd top cc 1 2 3 4 5 EULAG cc 4 3 2 1 radiation model t tend cc 5 4 3 2 1 radiative fluxes cc cc invert levels: cc uppermost and ground: zero gradient conditions ttend(i,j,1)=radl(ii,nlev)+rads(ii,nlev) ttend(i,j,L)=radl(ii, 1)+rads(ii, 1) radlwh(i,j,1)=radlwh(i,j,1)+radl(ii,nlev)*float(nrad_int) radlwh(i,j,L)=radlwh(i,j,L)+radl(ii, 1)*float(nrad_int) radswh(i,j,1)=radswh(i,j,1)+rads(ii,nlev)*float(nrad_int) radswh(i,j,L)=radswh(i,j,L)+rads(ii, 1)*float(nrad_int) do k=2,l-1 kr=l-k+1 ttend(i,j,k)=.5*(radl(ii,kr)+radl(ii,kr-1) * +rads(ii,kr)+rads(ii,kr-1)) radlwh(i,j,k)=radlwh(i,j,k)+.5*(radl(ii,kr)+radl(ii,kr-1)) * *float(nrad_int) radswh(i,j,k)=radswh(i,j,k)+.5*(rads(ii,kr)+rads(ii,kr-1)) * *float(nrad_int) enddo enddo enddo endif !<--- END OF RAD CALC cc apply radiative tendency: do ip=1,np do jp=1,mp do k=1,l fth(ip,jp,k)=fth(ip,jp,k) . + 2.*ttend(ip,jp,k)*the(ip,jp,k)/tme(ip,jp,k) enddo enddo enddo return end real function ozone(p) parameter (n = 31) real p, $ press(0:n), $ o3mmr(0:n), $ h(0:n), $ z(0:n), $ val data press / 0.029, 0.456, 1.222, 2.320, 4.525, $ 9.100, 18.950, 27.850, 32.500, 37.950, $ 44.450, 52.250, 61.550, 72.750, 86.300, $ 102.350, 121.500, 144.000, 169.000, 197.500, $ 230.000, 266.500, 307.500, 353.500 ,405.000, $ 462.000, 525.500, 596.000, 674.000, 760.000, $ 854.500, 958.500/ data o3mmr / 1.413E-07, 1.182E-06, 4.600E-06, 7.270E-06, $ 1.010E-05, 1.140E-05, 1.195E-05, 7.876E-06, $ 6.529E-06, 5.074E-06, 3.719E-06, 2.591E-06, $ 1.668E-06, 9.800E-07, 5.503E-07, 3.386E-07, $ 2.273E-07, 1.945E-07, 1.660E-07, 1.441E-07, $ 1.215E-07, 1.027E-07, 8.891E-08, 7.945E-08, $ 7.264E-08, 6.870E-08, 6.486E-08, 6.122E-08, $ 5.897E-08, 5.725E-08, 5.431E-08, 5.043E-08/ data h / 0.4270E+00, 0.7660E+00, 0.1098E+01, 0.2205E+01, $ 0.4575E+01, 0.9850E+01, 0.8900E+01, 0.4650E+01, $ 0.5450E+01, 0.6500E+01, 0.7800E+01, 0.9300E+01, $ 0.1120E+02, 0.1355E+02, 0.1605E+02, 0.1915E+02, $ 0.2250E+02, 0.2500E+02, 0.2850E+02, 0.3250E+02, $ 0.3650E+02, 0.4100E+02, 0.4600E+02, 0.5150E+02, $ 0.5700E+02, 0.6350E+02, 0.7050E+02, 0.7800E+02, $ 0.8600E+02, 0.9450E+02, 0.1040E+03, 0.0000E+00/ data z / 0.0000E+00, 0.6561E-05, -0.4576E-05, -0.1350E-06, $ -0.4413E-06, 0.6251E-07, -0.1172E-06, 0.7838E-07, $ -0.1561E-07, 0.1596E-07, 0.8394E-08, 0.5029E-08, $ 0.3734E-08, 0.2415E-08, 0.1251E-08, 0.2715E-09, $ 0.2652E-09, -0.5190E-10, 0.3476E-10, -0.6752E-11, $ 0.8348E-11, 0.4092E-11, 0.3255E-11, 0.1086E-11, $ 0.1536E-11, -0.1840E-12, 0.1374E-12, 0.3961E-12, $ 0.1204E-12, -0.2014E-12, -0.4571E-13, 0./ call splineval(n,press,o3mmr,h,p,z,val) ozone = val end Subroutine splineval(n,t,y,h,x,z,val) C************************************************************* C*Author : Joe Doetzl * C*File name: splineval.f * C*Date : 22-11-91 (dd-mm-yy) * C*Input : n - The number of nodes to be interpolated. * C* t - The nodes to be interpolated. * C* y - An array of function values corresponging* C* to the nodes t. * C* : z - An array of coefficients for a natural * C* cubic spline interpolating the * C* (t(i),y(i)) * C* : h - the width of the intervals [t(i),t(i+1)] * C* : x - the point at which the spline is to be * C* evaluated. * C*Output : val - The value of the spline at the point x. * C*Purpose : To evaluate a natural cubic spline at a given * C* point. * C*Note : n,t,y,z,h are obtained on output from spline.f * C************************************************************* Real t(0:n),y(0:n),z(0:n),h(0:n),x,val Integer Int Logical NonNeg NonNeg = .False. Do i = 1,n-1 If (x - t(n-i) .ge. 0.) Then NonNeg = .True. Int = n-i Goto 10 Endif Enddo 10 If (.Not. NonNeg) Int = 0 Auxa = 1./(6.*h(Int)) * (z(Int+1) - z(Int)) Auxb = z(Int)/2. Auxc = -h(Int)/6.*z(Int+1) - h(Int)/3.*z(Int) + . 1./h(Int)*(y(Int+1) - y(Int)) Auxd = x - t(Int) val = y(Int) + Auxd*(Auxc + Auxd*(Auxb + Auxd*Auxa)) End subroutine colmod_ice c c ccm2 radiation column model c Jeffrey Kiehl and Bruce Briegleb c October 1992 c c c designed to allow column (one dimensional in the vertical) c calculations of ccm2 shortwave and longwave radiation, using c the appropriate radiation routines from ccm2 c c input is a character file containing pertinent user defined c information c c basic idea is to extract ccm2 radiation routines unmodified, c and build a 'driver' that sets input and writes output after c the unmodified ccm2 routine have been executed c c in the 'driver', three interface routines are invoked: c c stparm sets certain model parameters c getdat reads input and computes auxilliary radiation inputs c radini modified form of ccm2 radini; sets radiation constants c c from 'radctl' and on down, the radiation call is the same as used c in ccm2 c c after 'radctl', there is one diagnostic routine and print statements c for output. c c to see what parameters the user can control, see an example input c file; essentially, whatever the radiation needs in the model is what c can be changed; to modify other aspects of the model, the user c must modify the radation routines themselves c c----------------------------------------------------------------------- implicit none c----------------------------------------------------------------------- CINCLUDE param.rad MIREKA include 'param.rad' C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C c----------------------------------------------------------------------- cccccccccccccccccccccccccccccccccccccccccccc cc common to communicate with dynamic model: real rads(plon,plev),radl(plon,plev) common /totr/ rads,radl ccccccccccccccccccccccccccccccccccccccccccccccccccc C C Model time variables C common/comtim/calday ,dtime ,twodt ,nrstrt ,nstep , $ nstepr ,nestep ,nelapse ,nstop ,mdbase , $ msbase ,mdcur ,mscur ,mbdate ,mbsec , $ mcdate ,mcsec ,nndbas ,nnsbas ,nnbdat , $ nnbsec C real calday, ! Current calendar day = julian day + fraction $ dtime, ! Time step in seconds (delta t) $ twodt ! 2 * delta t integer $ nrstrt, ! Starting time step of restart run (constant) $ nstep, ! Current time step $ nstepr, ! Current time step of restart run(updated w/nstep) $ nestep, ! Time step on which to stop run $ nelapse, ! Requested elapsed time for model run $ nstop, ! nestep + 1 $ mdbase, ! Base day of run $ msbase, ! Base seconds of base day $ mdcur, ! Current day of run $ mscur, ! Current seconds of current day $ mbdate, ! Base date of run (yymmdd format) $ mbsec, ! Base seconds of base date $ mcdate, ! Current date of run (yymmdd format) $ mcsec, ! Current seconds of current date $ nndbas, ! User input base day $ nnsbas, ! User input base seconds of input base day $ nnbdat, ! User input base date (yymmdd format) $ nnbsec ! User input base seconds of input base date C c----------------------------------------------------------------------- c c local arguments c integer nrow, ! latitude row index $ ioro(plond) ! land/ocean/sea ice flag c real clat, ! Current latitude (radians) $ sndpth(plond), ! snow depth (liquid water equivalent) $ ts(plond), ! surface air temperature $ tg(plond), ! surface (skin) temperature $ ps(plond), ! surface pressure $ pmid(plond,plev), ! model level pressures $ pint(plond,plevp), ! model interface pressures $ pmln(plond,plev), ! natural log of pmid $ piln(plond,plevp), ! natural log of pint $ t(plond,plev), ! model level temperatures $ h2ommr(plond,plev), ! model level specific humidity $ cldfrc(plond,plevp),! fractional cloud cover $ effcld(plond,plevp),! effective fractional cloud cover $ clwp(plond,plev), ! cloud liquid water path $ plol(plond,plevp), ! o3 pressure weighted path lengths (cm) $ plos(plond,plevp) ! o3 path lengths (cm) c real rel(plond,plev), ! liquid effective drop size (microns) $ rei(plond,plev), ! ice particle size $ fice(plond,plev) ! fractional amount of ice c c output solar c real solin(plond), ! solar incident flux $ fsnt(plond), ! total column absorbed solar flux $ fsns(plond), ! surface absorbed solar flux $ fsntc(plond), ! clr sky total column abs solar flux $ fsnsc(plond), ! clr sky surface abs solar flux $ qrs(plond,plev) ! solar heating rate c c output longwave c real flnt(plond), ! net outgoing lw flx at model top $ flns(plond), ! srf longwave cooling (up-dwn) flux $ flntc(plond), ! clr sky lw flx at model top $ flnsc(plond), ! clr sky lw flx at srf (up-dwn) $ qrl(plond,plev), ! longwave cooling rate $ slwd(plond) ! srf down longwave flux c c surface radiative heating c real srfrad(plond) ! srf radiative heat flux c c local workspace c real coszrs(plond), ! cosine solar zenith angle $ loctim(plond) ! local time of solar computation c real pie, ! for radiation output $ rlat, ! for radiation output $ sol, ! for radiation output $ sab, ! for radiation output $ alb, ! for radiation output $ frs, ! for radiation output $ fsnstm, ! for radiation output $ clatm, ! for radiation output $ scf, ! for radiation output $ albc ! for radiation output c real flw, ! for radiation output $ fla, ! for radiation output $ fld, ! for radiation output $ clt, ! for radiation output $ cls, ! for radiation output $ cls1, ! for radiation output $ cfl, ! for radiation output $ cfn, ! for radiation output $ qrsday, ! for radiation output $ qrlday, ! for radiation output $ pmb ! for radiation output c integer i, ! longitude index $ k ! level index c real gravx, ! gravitational acceleration (m/s**2) $ cpairx, ! heat capacity dry air at constant prs (J/kg/K) $ epsilox, ! ratio mean mol weight h2o to dry air $ stebolx ! Sefan-Boltzmann constant (W/m**2/K**4) c real eccf ! earth/sun distance factor c c------------------------------------------------------------------------ c set parameters in common blocks: c call stparm c call getdat(gravx ,cpairx ,epsilox,stebolx, nrow, $ clat ,ioro ,sndpth ,ts , tg, $ ps ,pmid ,pint ,pmln , piln, $ t ,h2ommr ,plol ,plos , cldfrc, $ clwp ,effcld ,rel ,rei , fice) c call radini(gravx,cpairx,epsilox,stebolx) c c compute radiation c c----------------------------------------------------------------------- call radctl(nrow ,clat ,ioro ,sndpth ,ts , $ tg ,ps ,pmid ,pint ,pmln , $ piln ,t ,h2ommr ,cldfrc ,effcld , $ clwp ,rel ,rei ,fice ,plol , $ plos ,solin ,fsnt ,fsns ,fsntc , $ fsnsc ,qrs ,flnt ,flns ,flntc , $ flnsc ,qrl ,srfrad ) c----------------------------------------------------------------------- c cc load profiles (K/sec) into communication arrays: do 200 k=1,plev do 200 i=1,plon rads(i,k)=qrs(i,k) radl(i,k)=qrl(i,k) 200 continue return end cdir$ nolist subroutine stparm c c set certain model parameters for use in the column radiation model c c anncyc must be set for use in ozone computation c nstep must be 0, as well as irad=1 and iradae=1 so that longwave c absorptivity and emissivity computation will be done c c----------------------------------------------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C c----------------------------------------------------------------------- C C Model grid point resolution parameters. C integer $ plnlv, ! Length of multilevel field slice $ plndlv, ! Length of multilevel 3-d field slice $ pbflnb, ! Length of buffer 1 $ pbflna, ! Length of buffer 2 $ pflenb, ! Length of buffer 1, padded for unblocked I/O $ pflena, ! Length of buffer 2, padded for unblocked I/O $ ptifld, ! Number of fields on time-invariant boundary dataset $ ptvsfld, ! Number of fields on time-variant boundary dataset $ ptvofld, ! Number of fields on ozone dataset $ plenhi, ! Length of integer header record $ plenhc, ! Length of character header record $ plenhr, ! Length of real header record $ ptapes, ! Maximum number of history tapes allowed $ pflds ! Number of fields in master field list integer $ ptileni, ! Length of time-invariant integer header $ ptilenc, ! Length of time-invariant character header $ ptvoleni, ! Length of ozone integer header $ ptvolenc, ! Length of ozone character header $ ptvsleni, ! Length of time-variant integer header $ ptvslenc ! Length of time-variant character header integer $ plenhis, ! Length of integer header scalars $ plenhcs, ! Length of character header scalars $ ptilenis, ! Length of time-invariant integer scalars $ ptilencs, ! Length of time-invariant character scalars $ ptolenis, ! Length of ozone integer header scalars $ ptolencs, ! Length of ozone character header scalars $ ptslenis, ! Length of time-variant integer header scalars $ ptslencs ! Length of time-variant character header scalars C parameter(plnlv=plon*plev,plndlv=plond*plev) C C In pbflnb, 9 multi-level fields include the plev levels of plol and C plos. 2 multi-level fields are pcnst-dependent. C 12 single-level fields include the additional level of plol and plos. C 1 single-level field is pcnst-dependent. There are plevmx sub-surface C temperature fields. (See User's Guide for complete buffer description) C parameter(pbflnb=(9 + 2*pcnst)*plndlv + (12+plevmx+pcnst)*plond, C C In pbflna, there are 6 multi-level and 4 single-level fields. C $ pbflna = (4 + 6*plev)*plond, $ pflenb = ((pbflnb + pbflna)/512 + 1)*512, $ pflena = (pbflna/512 + 1)*512, $ ptapes = 6, C C 8 fields in master list are pcnst-dependent 2 fields occur only C if pcnst > 1 C $ pflds=77+8*pcnst+2*(pcnst-1)+plevmx) parameter(ptifld = 11, ptvsfld = 1, ptvofld = 2) C C There are 37 scalar words in the integer header and 89 scalar words C in the character header C parameter(plenhis=37,plenhcs=89, $ plenhi=plenhis+3*pflds,plenhc=plenhcs+2*pflds, $ plenhr=3*(2*plev + 1) + 2*plat, $ ptilenis=plenhis, ptilencs=plenhcs, $ ptileni=ptilenis+3*ptifld, ptilenc=ptilencs+2*ptifld, $ ptolenis=plenhis, ptolencs=plenhcs, $ ptvoleni=ptolenis+3*ptvofld,ptvolenc=ptolencs+2*ptvofld, $ ptslenis=plenhis, ptslencs=plenhcs, $ ptvsleni=ptslenis+3*ptvsfld,ptvslenc=ptslencs+2*ptvofld) c----------------------------------------------------------------------- C C Model control variables C common/comctl/itsst ,nsrest ,iradae ,irad ,anncyc , $ nlend ,nlres ,nlhst ,lbrnch ,ldebug , $ aeres ,doslt ,ozncyc ,sstcyc integer $ itsst, ! Sea surf. temp. update freq. (iters) $ nsrest, ! Restart flag $ iradae, ! Iteration freq. for absorptivity/emissivity comp $ irad ! Iteration frequency for radiation computation logical $ anncyc, ! Do annual cycle (otherwise perpetual) $ nlend, ! Flag for end of run $ nlres, ! If true, continuation run $ nlhst, ! If true, regeneration run $ lbrnch, ! If true, branch run $ ldebug, ! If in debug mode, link output files to /usr/tmp C ! before mswrite, and remove all but last file $ aeres, ! If true, a/e data will be stored on restart file $ doslt, ! true -> slt, false -> spectral transport $ ozncyc, ! If true, cycle ozone dataset $ sstcyc ! If true, cycle sst dataset C c----------------------------------------------------------------------- C C Model time variables C common/comtim/calday ,dtime ,twodt ,nrstrt ,nstep , $ nstepr ,nestep ,nelapse ,nstop ,mdbase , $ msbase ,mdcur ,mscur ,mbdate ,mbsec , $ mcdate ,mcsec ,nndbas ,nnsbas ,nnbdat , $ nnbsec C real calday, ! Current calendar day = julian day + fraction $ dtime, ! Time step in seconds (delta t) $ twodt ! 2 * delta t integer $ nrstrt, ! Starting time step of restart run (constant) $ nstep, ! Current time step $ nstepr, ! Current time step of restart run(updated w/nstep) $ nestep, ! Time step on which to stop run $ nelapse, ! Requested elapsed time for model run $ nstop, ! nestep + 1 $ mdbase, ! Base day of run $ msbase, ! Base seconds of base day $ mdcur, ! Current day of run $ mscur, ! Current seconds of current day $ mbdate, ! Base date of run (yymmdd format) $ mbsec, ! Base seconds of base date $ mcdate, ! Current date of run (yymmdd format) $ mcsec, ! Current seconds of current date $ nndbas, ! User input base day $ nnsbas, ! User input base seconds of input base day $ nnbdat, ! User input base date (yymmdd format) $ nnbsec ! User input base seconds of input base date C c----------------------------------------------------------------------- C C History tape header: C Record number 1 (integer values) provides description for history C tape output. See the CCM2 User's Guide for description of each C of the individual header variables. C common /comhdi/ $ lenhdi(1) ,mftyp ,mfilh ,mfilth ,nrbd , $ maxsiz ,ndavu ,mxxx ,mlon ,nlonw , $ morec ,mlev ,mtrm ,mtrn ,mtrk , $ nfldh ,nsteph ,nstprh ,nitslf ,ndbase , $ nsbase ,ndcur ,nscur ,nbdate ,nbsec , $ ncdate ,ncsec ,mdt ,mhisf ,mfstrt , $ lenhdc ,lenhdr ,mpsig ,mplat ,mpwts , $ mpflds ,mpcfld ,mflds(3,pflds) C integer lenhdi, ! Length of header record 1 $ mftyp, ! Format code $ mfilh, ! Logical file number $ mfilth, ! Max number of files on history tape $ nrbd, ! Number of records before data records $ maxsiz, ! Length of data record for this volume $ ndavu, ! Length of the data record after unpacking $ mxxx, ! Horizontal domain flag $ mlon, ! Number of longitude points per latitude line $ nlonw, ! Number of longitude data values written $ morec, ! Number of latitude lines or data records $ mlev, ! Number of vertical levels $ mtrm, ! M spectral truncation parameter $ mtrn, ! N spectral truncation parameter $ mtrk ! K spectral truncation parameter integer nfldh, ! Number of fields on the header $ nsteph, ! Iteration number $ nstprh, ! Iteration number for the start of this run $ nitslf, ! Iterations since last file was written $ ndbase, ! Base day number for this case $ nsbase, ! Base number of seconds for this case $ ndcur, ! Current day corresponding to NSTEPH $ nscur, ! Current seconds corresponding to NSTEPH $ nbdate, ! Base date (yr mo day) as 6-digit integer $ nbsec, ! Seconds to complete NODT date $ ncdate, ! Current date (yymmdd) $ ncsec, ! Current seconds for date $ mdt, ! Model timestep in seconds $ mhisf, ! Frequency that history files are written $ mfstrt ! Flag to indicate type of start integer lenhdc, ! Length of header record 2 $ lenhdr, ! Length of header record 3 $ mpsig, ! Pointer to first word of sigma value list $ mplat, ! Pointer to list of latitude lines $ mpwts, ! Pointer to list of Gaussian weights $ mpflds, ! Pointer to header field info integer list $ mpcfld, ! Pointer to field info chararacter list $ mflds ! Array of integer field list information C C C History tape header, record number 2 (character values) C common /comhdc/ $ mcase ,mcstit , $ lnhstc ,ldhstc ,lthstc ,lshstc , $ lnhstf ,ldhstf ,lthstf ,lshstf , $ lnhsti ,ldhsti ,lthsti ,lshsti , $ lnhstt ,ldhstt ,lthstt ,lshstt , $ lnhstvs ,ldhstvs ,lthstvs ,lshstvs , $ lnhstvo ,ldhstvo ,lthstvo ,lshstvo , $ mcflds(2,pflds) C character*8 mcase , ! Case identifier $ ldhstc ,lthstc ,lshstc , ! Current hist tape info $ ldhstf ,lthstf ,lshstf , ! First hist tape info $ ldhsti ,lthsti ,lshsti , ! Initial hist tape info $ ldhstt ,lthstt ,lshstt , ! Boundary hist tape C ! information $ ldhstvs ,lthstvs ,lshstvs , ! SST hist tape info $ ldhstvo ,lthstvo ,lshstvo , ! Ozone hist tape info $ mcflds ! Array of character C ! field list info character*80 mcstit, ! Case title C ! MSS names: $ lnhstc, ! Current history tape $ lnhstf, ! First history tape $ lnhsti, ! Initial history tape $ lnhstt, ! Boundary history tape $ lnhstvs, ! SST history tape $ lnhstvo ! Ozone history tape C C History tape header, record number 3 (real values) C C Real header record contains sigma,latitude and gaussian weights C common /comhdr/ $ sigapb(2*plev+1) ,siga(2*plev+1) ,sigb(2*plev+1) , $ hdlat(plat) ,hdwt(plat) C real sigapb, ! Hybrid A + B coefficients $ siga, ! Hybrid A (pressure) coefficients $ sigb, ! Hybrid B (sigma) coefficients $ hdlat, ! Latitude list (South to North) $ hdwt ! Gaussian weight list. C c----------------------------------------------------------------------- c c... from 'comctl' c anncyc = .true. c c... from 'comtim' c nstep = 0 c c... from 'comctl' c irad = 1 iradae = 1 c return end c----------------------------------------------------------------------- subroutine radoz2(jlat,pmidm1,pintm1,plol,plos) c dummy routine for ccm2 rad return end c----------------------------------------------------------------------- subroutine radrda(nunit,albvss,plon,plat,conv) c dummy routine for ccm2 rad return end c----------------------------------------------------------------------- integer function norsou(nrow) c dummy routine for ccm2 rad norsou = 0 return end c----------------------------------------------------------------------- subroutine getdat(gravx ,cpairx ,epsilox,stebolx, nrow, $ clat ,ioro ,sndpth ,ts , tg, $ ps ,pmid ,pint ,pmln , piln, $ t ,h2ommr ,plol ,plos , cldfrc, $ clwp ,effcld ,rel ,rei , fice) c----------------------------------------------------------------------- c c interface routine for column model that both initializes c certain constants and reads external data: c c o3 mass mixing ratios are read in, but the model also requires the c path lengths; they are computed here c c also, from the cloud input (fraction and liquid water path), the c cloud longwave emissivity must be computed; this is done here c c----------------------------------------------------------------------- implicit none c----------------------------------------------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C c----------------------------------------------------------------------- C ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cc comunication with the dynamic model: dimension parm(plon,13),array(plon,plev,8) real parm,array common /com_11/parm,array cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C Model time variables C common/comtim/calday ,dtime ,twodt ,nrstrt ,nstep , $ nstepr ,nestep ,nelapse ,nstop ,mdbase , $ msbase ,mdcur ,mscur ,mbdate ,mbsec , $ mcdate ,mcsec ,nndbas ,nnsbas ,nnbdat , $ nnbsec C real calday, ! Current calendar day = julian day + fraction $ dtime, ! Time step in seconds (delta t) $ twodt ! 2 * delta t integer $ nrstrt, ! Starting time step of restart run (constant) $ nstep, ! Current time step $ nstepr, ! Current time step of restart run(updated w/nstep) $ nestep, ! Time step on which to stop run $ nelapse, ! Requested elapsed time for model run $ nstop, ! nestep + 1 $ mdbase, ! Base day of run $ msbase, ! Base seconds of base day $ mdcur, ! Current day of run $ mscur, ! Current seconds of current day $ mbdate, ! Base date of run (yymmdd format) $ mbsec, ! Base seconds of base date $ mcdate, ! Current date of run (yymmdd format) $ mcsec, ! Current seconds of current date $ nndbas, ! User input base day $ nnsbas, ! User input base seconds of input base day $ nnbdat, ! User input base date (yymmdd format) $ nnbsec ! User input base seconds of input base date C c----------------------------------------------------------------------- C C Surface albedo data C C The albedos are computed for a model grid box by ascribing values to C 1x1 degree points of a vegetation dataset, then linearly averaging C for each grid box; ocean and land values are averaged together along C coastlines; the fraction of every grid box that has strong zenith C angle dependence is included also (see Briegleb, Bruce P., 1992: C Delta-Eddington Approximation for Solar Radiation in the NCAR C Community Climate Model, Journal of Geophysical Research, Vol 97, D7, C pp7603-7612). C common/crdalb/albvss(plond,plat),albvsw(plond,plat), $ albnis(plond,plat),albniw(plond,plat), $ frctst(plond,plat) C C vis = 0.2 - 0.7 micro-meters wavelength range C nir = 0.7 - 5.0 micro-meters wavelength range C C szad = strong zenith angle dependent C wzad = weak zenith angle dependent C real albvss, ! Grid box alb for vis over szad surfaces $ albvsw, ! Grid box alb for vis over wzad surfaces $ albnis, ! Grid box alb for nir over szad surfaces $ albniw, ! Grid box alb for nir over wzad surfaces $ frctst ! Fraction of area in grid box with szad surfaces C C Surface boundary data C C Vegtyp is used to specify the thermal properites of the surface, as C well as determine the location of permanent land ice points; it is the C dominant surface type within the model grid box based on the 1x1 C degree resolution vegetation dataset; it is encoded in the following C manner: C C 1 ocean C 2 sea ice C 3 permanent land ice C 4 tropical evergreen forest C 5 deciduous forest C 6 grassland/tundra C 7 desert C C Rghnss is the aerodynamic roughness length for the grid box, computed C by linear averaging of the values ascribed to the 1x1 degree C resolution vegetation dataset; ocean and land values are averaged C together along coastlines. C C Evapf is the ratio of actual to potential evaporation, and is computed C from the 1x1 degree resolution vegetation dataset in a manner similar C to the aerodynamic roughness. C C Vevapf allows for variable snow cover, where the underlying C evaporability factor is modified. C C Snwjan and snwjly are mean climatological snow depths (liquid water C equivalent) used to compute the prescribed daily values of snow cover. C common/crdsrf/vegtyp(plond,plat),rghnss(plond,plat), $ evapf (plond,plat),vevapf(plond,plat), $ snwjan(plond,plat),snwjly(plond,plat) C real vegtyp, ! Surface thermal type, based on veg type $ rghnss, ! Aerodynamic roughness length $ evapf , ! Constant surface evaporability $ vevapf, ! Variable surface evaporability $ snwjan, ! Snow cover (liq water equiv) for January $ snwjly ! Snow cover (liq water equiv) for July C c----------------------------------------------------------------------- C C Radiation constants C common/crdcon/gravit ,rga ,cpair ,epsilo ,sslp , $ stebol ,rgsslp ,co2vmr ,dpfo3 ,dpfco2 , $ dayspy ,pie C real gravit, ! Acceleration of gravity $ rga, ! 1./gravit $ cpair, ! Specific heat of dry air $ epsilo, ! Ratio of mol. wght of H2O to dry air $ sslp, ! Standard sea-level pressure $ stebol, ! Stefan-Boltzmann's constant $ rgsslp, ! 0.5/(gravit*sslp) $ co2vmr, ! CO2 volume mixing ratio $ dpfo3, ! Voigt correction factor for O3 $ dpfco2, ! Voigt correction factor for CO2 $ dayspy, ! Number of days per 1 year $ pie ! 3.14..... C c----------------------------------------------------------------------- c c output arguments c real gravx, ! gravitational acceleration (m/s**2) $ cpairx, ! heat capacity dry air at constant prs (J/kg/K) $ epsilox, ! ratio mean mol weight h2o to dry air $ stebolx ! Sefan-Boltzmann constant (W/m**2/K**4) c integer nrow, ! model latitude index $ ioro(plond) ! land surface flag c real clat, ! model latitude in radians $ sndpth(plond), ! snow depth (liquid water equivalent) $ ts(plond), ! surface (air) temperature $ tg(plond), ! surface (skin) temperature $ ps(plond), ! model surface pressure field $ pmid(plond,plev), ! pressure at model mid-levels $ pint(plond,plevp), ! pressure at model interfaces $ pmln(plond,plev), ! ln(pmid) $ piln(plond,plevp), ! ln(pint) $ t(plond,plev), ! atmospheric temperature $ h2ommr(plond,plev), ! moisture field $ plol(plond,plevp), ! o3 pressure weighted path length $ plos(plond,plevp), ! o3 path length $ cldfrc(plond,plevp),! cloud fraction $ clwp(plond,plev), ! cloud liquid water path (g/m**2) $ effcld(plond,plevp) ! effective cloud fraction c real rel(plond,plev), ! liquid effective drop size (microns) $ rei(plond,plev), ! ice particle size $ junk(plond,plev), ! ice particle size $ fice(plond,plev) ! fractional amount of ice c c local workspace c real dayyr(plond), ! day of year $ rlat(plond), ! latitude input $ pie1, ! pie $ o3mmr(plond,plev), ! o3 mass mixing ratio $ emis(plond,plev), ! cloud emissivity for longwave $ ptop, ! top layer interface pressure $ pbot ! bottom layer interface pressure c real co2mix ! co2 volume mixing ratio read in c integer lev(plev), ! level input $ i, ! longitude index $ k ! level index c character*80 label c real gravit1, ! gravitational acceleration in cm/s**2 $ v0, ! volume of a gas at stp (cm**3/mol) $ p0, ! standard pressure (dynes/cm**2) $ amd, ! effective molecular weight of dry air (g/mol) $ amo, ! molecular weight of ozone (g/mol) $ cpl, ! constant in ozone path length to mixing ratio $ cpwpl, ! pressure weighted ozone path length constant $ vmmr, ! ozone volume mixing ratio $ reice, ! ice particle size $ reliq ! liquid particle size c data v0 / 22413.6 / data p0 / 1.01325e6 / data amd / 28.9644 / data amo / 48.0000 / real ozone external ozone c c----------------------------------------------------------------------- c c set fundamental constants (mks): c gravx = 9.80616 cpairx = 1.00464e3 epsilox = 0.622 stebolx = 5.67e-8 c nrow = 1 c c begin read of data: c do 100 i=1,plon c dayyr(i) =parm(i,1) rlat(i) =parm(i,2) ps(i) =parm(i,3) ts(i) =parm(i,4) tg(i) =parm(i,5) ioro(i) =parm(i,6) rghnss(i,1) =parm(i,7) sndpth(i) =parm(i,8) albvss(i,1) =parm(i,9) albvsw(i,1) =parm(i,10) albnis(i,1) =parm(i,11) albniw(i,1) =parm(i,12) frctst(i,1) =parm(i,13) co2vmr =3.3e-4 c do 200 k=1,plev pmid(i,k) =array(i,k,1) t(i,k) =array(i,k,2) h2ommr(i,k) =array(i,k,3) cldfrc(i,k) =array(i,k,4) fice(i,k) =array(i,k,5) clwp(i,k) =array(i,k,6) rei(i,k) =array(i,k,7) rel(i,k) =array(i,k,8) o3mmr(i,k)=ozone(pmid(i,k)) if( cldfrc(i,k) .gt. 0.99999 ) cldfrc(i,k) = .99 200 continue c c..... currently, cld requires extrae 'below surface' value: c cldfrc(i,plevp) = 0.0 c c.......... convert pressures from mb to pascals and define c.......... interface pressures: c ps(i) = ps(i) * 100. do 125 k=1,plev c pmid(i,k) = pmid(i,k) * 100. pmln(i,k) = alog(pmid(i,k)) c 125 continue do 150 k=1,plevp c if( k .eq. 1 ) then pint(i,k) = pmid(i,k) / 2.0 else if ( k .gt. 1 .and. k .le. plev ) then pint(i,k) = 0.5 * (pmid(i,k-1) + pmid(i,k)) else if ( k .eq. plevp ) then pint(i,k) = ps(i) endif piln(i,k) = alog(pint(i,k)) c 150 continue c c 100 continue c calday = dayyr(1) pie = 4.*atan(1.) clat = rlat(1)*(pie/180.) c c compute ozone path lengths from mixing ratio: c c constants for following sums: c gravit = gravx * 100. cpl = v0 / (amd * gravit) cpwpl = 0.5 * v0 / (amd * gravit * p0) vmmr = amd / amo c do 225 i=1,plon c c set top level to space path lengths: c pbot = pint(i,1) * 10. c plos(i,1) = cpl * vmmr * o3mmr(i,1) * pbot c plol(i,1) = cpwpl * vmmr * o3mmr(i,1) * + (pbot*pbot) c ptop = 0.0 c c set rest of level path lengths: c do 250 k=2,plevp c ptop = pint(i,k-1) * 10. pbot = pint(i,k) * 10. c plos(i,k) = plos(i,k-1) + + (cpl * vmmr * o3mmr(i,k-1) * (pbot - ptop)) c plol(i,k) = plol(i,k-1) + + (cpwpl * vmmr * o3mmr(i,k-1) * + (pbot*pbot - ptop*ptop)) c 250 continue 225 continue c c c compute effective cloud cover c call cldems(clwp, fice, rei, emis) c do 300 k=1,plev do 400 i=1,plon effcld(i,k) = cldfrc(i,k)*emis(i,k) 400 continue 300 continue c c cloud cover at surface interface always zero c do 500 i=1,plon effcld(i,plevp) = 0. cldfrc(i,plevp) = 0. 500 continue return end c----------------------------------------------------------------------- subroutine cldems(clwp, fice, rei, emis) C----------------------------------------------------------------------- C C Compute cloud emissivity using cloud liquid water path (g/m**2) C C---------------------------Code history-------------------------------- C C Original version: J. Kiehl C Standardized: J. Rosinski, June 1992 C Reviewed: J. Hack, J. Kiehl, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C----------------------------------------------------------------------- real kabsl ! longwave absorption coeff (m**2/g) parameter (kabsl = 0.090361) C------------------------------Arguments-------------------------------- C C Input arguments C real clwp(plond,plev), ! cloud liquid water path (g/m**2) $ rei(plond,plev), ! ice particle size (microns) $ fice(plond,plev) ! fractional amount of ice C C Output arguments C real emis(plond,plev) ! cloud emissivity (fraction) C C---------------------------Local workspace----------------------------- C integer i,k ! longitude, level indices real kabs, ! longwave absorption coefficient $ kabsi ! ice absorption coefficient C C----------------------------------------------------------------------- C do k=1,plev do i=1,plon kabsi = 0.005 + 1./rei(i,k) kabs = kabsl*(1.-fice(i,k))+kabsi*fice(i,k) emis(i,k) = 1. - exp(-1.66*kabs*clwp(i,k)) c emis(i,k) = 1. - exp(amax1(-25.,-1.66*kabs*clwp(i,k))) end do end do C return end subroutine radini(gravx ,cpairx ,epsilox ,stebolx ) C----------------------------------------------------------------------- C C Initialize various constants for radiation scheme; note that C the radiation scheme uses cgs units. C C---------------------------Code history-------------------------------- C C Original version: CCM1 C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C------------------------------Commons---------------------------------- C C Water vapor narrow band constants for longwave radiation computations C common/crdcae/realk(2), st(2), a1(2), a2(2), b1(2), b2(2), $ coefa(3,4),coefb(4,4),coefc(3,4),coefd(4,4), $ coefe(3,4),coeff(6,2),coefg(2,4),coefh(2,4), $ coefi(6,2),coefj(3,2),coefk(3,2), $ c1(4),c2(4),c3(4),c4(4),c5(4),c6(4),c7(4),c8,c9, $ c10,c11,c12,c13,c14,c15,c16,c17,c18,c19,c20,c21, $ c22,c23,c24,c25,c26,c27,c28,c29,c30,c31, $ fwcoef,fwc1,fwc2,fc1,cfa1 C real realk, ! H2O narrow band parameter $ st, ! H2O narrow band parameter $ a1,a2, ! Temperature correction terms for H2O path $ b1,b2 ! Temperature correction terms for H2O path C C Constant coefficients for water vapor absorptivity and emissivity C real coefa,coefb,coefc,coefd,coefe,coeff, $ coefg,coefh,coefi,coefj,coefk, $ c1, c2, c3, c4, c5, c6, c7,c8 ,c9 ,c10, $ c11,c12,c13,c14,c15,c16,c17,c18,c19,c20, $ c21,c22,c23,c24,c25,c26,c27,c28,c29,c30,c31 C C Farwing correction constants for narrow-band emissivity model, C introduced to account for the deficiencies in narrow-band model C used to derive the emissivity; tuned with Arking's line-by-line C calculations. C real fwcoef, $ fwc1,fwc2, $ fc1, $ cfa1 C C------------------------------Arguments-------------------------------- C C Radiation constants C common/crdcon/gravit ,rga ,cpair ,epsilo ,sslp , $ stebol ,rgsslp ,co2vmr ,dpfo3 ,dpfco2 , $ dayspy ,pie C real gravit, ! Acceleration of gravity $ rga, ! 1./gravit $ cpair, ! Specific heat of dry air $ epsilo, ! Ratio of mol. wght of H2O to dry air $ sslp, ! Standard sea-level pressure $ stebol, ! Stefan-Boltzmann's constant $ rgsslp, ! 0.5/(gravit*sslp) $ co2vmr, ! CO2 volume mixing ratio $ dpfo3, ! Voigt correction factor for O3 $ dpfco2, ! Voigt correction factor for CO2 $ dayspy, ! Number of days per 1 year $ pie ! 3.14..... C C------------------------------Arguments-------------------------------- C C Input arguments C real gravx, ! Acceleration of gravity (MKS) $ cpairx, ! Specific heat of dry air (MKS) $ epsilox, ! Ratio of mol. wght of H2O to dry air $ stebolx ! Stefan-Boltzmann's constant (MKS) C C---------------------------Local variables----------------------------- C integer iband ! H2O band index C C /CRDCAE/ C H2O EMISSIVITY AND ABSORTIVITY COEFFICIENTS C data coefd/7.03047e-01,-2.63501e-03,-1.57023e-06,0.0, $ 5.29269e-01,-3.14754e-03, 4.39595e-06,0.0, $ 7.88193e-02, 1.31290e-03, 4.25827e-06,-1.23982e-08, $ 1.62744e-01, 2.22847e-03, 2.60102e-06,-4.30133e-08/ C data coefb/8.85675e+00,-3.51620e-02, 2.38653e-04,-1.71439e-06, $ 5.73841e+00,-1.91919e-02, 1.65993e-04,-1.54665e-06, $ 6.64034e+00, 1.56651e-02,-9.73357e-05, 0.0, $ 7.09281e+00, 1.40056e-02,-1.15774e-04, 0.0/ C data coefe/3.93137e-02,-4.34341e-05,3.74545e-07, $ 3.67785e-02,-3.10794e-05,2.94436e-07, $ 7.42500e-02, 3.97397e-05,0.0, $ 7.52859e-02, 4.18073e-05,0.0/ C data coefa/1.01400e+00,6.41695e-03,2.85787e-05, $ 1.01320e+00,6.86400e-03,2.96961e-05, $ 1.02920e+00,1.01680e-02,5.30226e-05, $ 1.02743e+00,9.85113e-03,5.00233e-05/ C data coefc/9.90127e-01,1.22475e-03,4.90135e-06, $ 9.89753e-01,1.97081e-03,3.42046e-06, $ 9.75230e-01,1.03341e-03,0.0, $ 9.77366e-01,8.60014e-04,0.0/ C data coeff/2.2037 e-01,1.39719e-03,-7.32011e-06, $ -1.40262e-08,2.13638e-10,-2.35955e-13, $ 3.07431e-01,8.27225e-04,-1.30067e-05, $ 3.49847e-08,2.07835e-10,-1.98937e-12/ C data coefg/9.04489e+00,-9.56499e-03, $ 1.80898e+01,-1.91300e-02, $ 8.72239e+00,-9.53359e-03, $ 1.74448e+01,-1.90672e-02/ C data coefh/5.46557e+01,-7.30387e-02, $ 1.09311e+02,-1.46077e-01, $ 5.11479e+01,-6.82615e-02, $ 1.02296e+02,-1.36523e-01/ C data coefi/3.31654e-01,-2.86103e-04,-7.87860e-06, $ 5.88187e-08,-1.25340e-10,-1.37731e-12, $ 3.14365e-01,-1.33872e-03,-2.15585e-06, $ 6.07798e-08,-3.45612e-10,-9.34139e-15/ C data coefj/2.82096e-02,2.47836e-04,1.16904e-06, $ 9.27379e-02,8.04454e-04,6.88844e-06/ C data coefk/2.48852e-01,2.09667e-03,2.60377e-06, $ 1.03594e+00,6.58620e-03,4.04456e-06/ C C NARROW BAND DATA FOR H2O C 200CM DATA FOR 800-1000 CM-1 AND 1000-1200 CM-1. C data realk/ 0.18967069430426e-04, 0.70172244841851e-04 / data st / 0.31930234492350e-03, 0.97907319939060e-03 / data a1 / 0.28775403075736e-01, 0.23236701470511e-01 / data a2 / -0.57966222388131e-04,-0.95105504388411e-04 / data b1 / 0.29927771523756e-01, 0.21737073577293e-01 / data b2 / -0.86322071248593e-04,-0.78543550629536e-04 / C C----------------------------------------------------------------------- C C Set general radiation consts; convert to cgs units where appropriate: C gravit = 100.*gravx rga = 1./gravit cpair = 1.e4*cpairx epsilo = epsilox sslp = 1.013250e6 stebol = 1.e3*stebolx rgsslp = 0.5/(gravit*sslp) dpfo3 = 2.5e-3 dpfco2 = 5.0e-3 dayspy = 365. pie = 4.*atan(1.) C C Coefficients for h2o emissivity and absorptivity. C do iband=1,4 c1(iband) = coefe(3,iband)/coefe(2,iband) c2(iband) = coefb(3,iband)/coefb(2,iband) c3(iband) = coefb(4,iband)/coefb(3,iband) c4(iband) = coefd(3,iband)/coefd(2,iband) c5(iband) = coefd(4,iband)/coefd(3,iband) c6(iband) = coefa(3,iband)/coefa(2,iband) c7(iband) = coefc(3,iband)/coefc(2,iband) end do c8 = coeff(3,1)/coeff(2,1) c9 = coeff(3,2)/coeff(2,2) c10 = coeff(4,1)/coeff(3,1) c11 = coeff(4,2)/coeff(3,2) c12 = coeff(5,1)/coeff(4,1) c13 = coeff(5,2)/coeff(4,2) c14 = coeff(6,1)/coeff(5,1) c15 = coeff(6,2)/coeff(5,2) c16 = coefj(3,1)/coefj(2,1) c17 = coefk(3,1)/coefk(2,1) c18 = coefi(3,1)/coefi(2,1) c19 = coefi(3,2)/coefi(2,2) c20 = coefi(4,1)/coefi(3,1) c21 = coefi(4,2)/coefi(3,2) c22 = coefi(5,1)/coefi(4,1) c23 = coefi(5,2)/coefi(4,2) c24 = coefi(6,1)/coefi(5,1) c25 = coefi(6,2)/coefi(5,2) c26 = coefj(3,2)/coefj(2,2) c27 = coefk(3,2)/coefk(2,2) c28 = .5 c29 = .002053 c30 = .1 c31 = 3.0e-5 cfa1 = .61 C C Initialize further longwave constants referring to far wing C correction; R&D refers to: C C Ramanathan, V. and P.Downey, 1986: A Nonisothermal C Emissivity and Absorptivity Formulation for Water Vapor C Journal of Geophysical Research, vol. 91., D8, pp 8649-8666 C fwcoef = .1 ! See eq(33) R&D fwc1 = .30 ! See eq(33) R&D fwc2 = 4.5 ! See eq(33) and eq(34) in R&D fc1 = 2.6 ! See eq(34) R&D C C Ozone intialization removed C return end subroutine radctl(lat ,clat ,ioro ,sndpth ,ts , $ tg ,ps ,pmid ,pint ,pmln , $ piln ,t ,h2ommr ,cld ,effcld , $ clwp ,rel ,rei ,fice ,plol , $ plos ,solin ,fsnt ,fsns ,fsntc , $ fsnsc ,qrs ,flnt ,flns ,flntc , $ flnsc ,qrl ,srfrad, hx,hy ) C----------------------------------------------------------------------- C C Driver for radiation computation. C C Radiation uses cgs units, so conversions must be done from C model fields to radiation fields. C C Calling sequence: C C radoz2 Interpolates ozone paths to model interface pressures C C radinp Converts units of model fields and computes ozone C mixing ratio for solar scheme C C radcsw Performs solar computation C radalb Computes surface albedos C radded Computes delta-Eddington solution C radclr Computes diagnostic clear sky fluxes C C radclw Performs longwave computation C C radtpl Computes path quantities C radems Computes emissivity C radabs Computes absorptivity C C radout Converts radiation fluxes to mks units; computes C surface radiative flux for surface computations C C---------------------------Code history-------------------------------- C C Original version: CCM1 C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) MIREKA integer i real sabs(plon),ldown(plon),lnet(plon) common /surfflux/sabs,ldown,lnet real hx(plon),hy(plon) C C------------------------------Commons---------------------------------- C C Model control variables C common/comctl/itsst ,nsrest ,iradae ,irad ,anncyc , $ nlend ,nlres ,nlhst ,lbrnch ,ldebug , $ aeres ,doslt ,ozncyc ,sstcyc integer $ itsst, ! Sea surf. temp. update freq. (iters) $ nsrest, ! Restart flag $ iradae, ! Iteration freq. for absorptivity/emissivity comp $ irad ! Iteration frequency for radiation computation logical $ anncyc, ! Do annual cycle (otherwise perpetual) $ nlend, ! Flag for end of run $ nlres, ! If true, continuation run $ nlhst, ! If true, regeneration run $ lbrnch, ! If true, branch run $ ldebug, ! If in debug mode, link output files to /usr/tmp C ! before mswrite, and remove all but last file $ aeres, ! If true, a/e data will be stored on restart file $ doslt, ! true -> slt, false -> spectral transport $ ozncyc, ! If true, cycle ozone dataset $ sstcyc ! If true, cycle sst dataset C C----------------------------------------------------------------------- C C Model time variables C common/comtim/calday ,dtime ,twodt ,nrstrt ,nstep , $ nstepr ,nestep ,nelapse ,nstop ,mdbase , $ msbase ,mdcur ,mscur ,mbdate ,mbsec , $ mcdate ,mcsec ,nndbas ,nnsbas ,nnbdat , $ nnbsec C real calday, ! Current calendar day = julian day + fraction $ dtime, ! Time step in seconds (delta t) $ twodt ! 2 * delta t integer $ nrstrt, ! Starting time step of restart run (constant) $ nstep, ! Current time step $ nstepr, ! Current time step of restart run(updated w/nstep) $ nestep, ! Time step on which to stop run $ nelapse, ! Requested elapsed time for model run $ nstop, ! nestep + 1 $ mdbase, ! Base day of run $ msbase, ! Base seconds of base day $ mdcur, ! Current day of run $ mscur, ! Current seconds of current day $ mbdate, ! Base date of run (yymmdd format) $ mbsec, ! Base seconds of base date $ mcdate, ! Current date of run (yymmdd format) $ mcsec, ! Current seconds of current date $ nndbas, ! User input base day $ nnsbas, ! User input base seconds of input base day $ nnbdat, ! User input base date (yymmdd format) $ nnbsec ! User input base seconds of input base date C C------------------------------Arguments-------------------------------- C C Input arguments C integer lat ! Latitude row index real clat ! Current latitude (radians) integer ioro(plond) ! Land/ocean/sea ice flag real sndpth(plond), ! Snow depth (liquid water equivalent) $ ts(plond), ! Surface air temperature $ tg(plond), ! Surface (skin) temperature $ ps(plond), ! Surface pressure $ pmid(plond,plev), ! Model level pressures $ pint(plond,plevp), ! Model interface pressures $ pmln(plond,plev), ! Natural log of pmid $ piln(plond,plevp), ! Natural log of pint $ t(plond,plev), ! Model level temperatures $ h2ommr(plond,plev), ! Model level specific humidity $ cld(plond,plevp), ! Fractional cloud cover $ effcld(plond,plevp),! Effective fractional cloud cover $ clwp(plond,plev), ! Cloud liquid water path $ plol(plond,plevp), ! O3 pressure weighted path lengths (cm) $ plos(plond,plevp) ! O3 path lengths (cm) real rel(plond,plev), ! liquid effective drop size (microns) $ rei(plond,plev), ! ice particle size $ fice(plond,plev) ! fractional amount of ice C C Output solar arguments C real solin(plond), ! Solar incident flux $ fsnt(plond), ! Net column abs solar flux at model top $ fsns(plond), ! Surface absorbed solar flux $ fsntc(plond), ! Clr sky total column abs solar flux $ fsnsc(plond), ! Clr sky surface abs solar flux $ qrs(plond,plev) ! Solar heating rate C C Output longwave arguments C real flnt(plond), ! Net outgoing lw flx at model top $ flns(plond), ! Srf longwave cooling (up-dwn) flux $ flntc(plond), ! Clr sky lw flx at model top $ flnsc(plond), ! Clr sky lw flx at srf (up-dwn) $ qrl(plond,plev), ! Longwave cooling rate $ slwd(plond) ! Srf down longwave flux C C Output surface radiative heating arguments C real srfrad(plond) ! Srf solar absorbed + down longwave flux C C---------------------------Local variables----------------------------- C real pbr(plond,plev), ! Model mid-level pressures (dynes/cm2) $ pnm(plond,plevp), ! Model interface pressures (dynes/cm2) $ o3mmr(plond,plev), ! Ozone mass mixing ratio $ plco2(plond,plevp), ! Prs weighted CO2 path $ plh2o(plond,plevp), ! Prs weighted H2O path $ tclrsf(plond,plevp),! Total clear sky fraction, level to space $ coszrs(plond), ! Cosine solar zenith angle $ eccf ! Earth/sun distance factor C external radinp, ! Computes latitude dependent radiation input $ radcsw, ! Computes solar radiation $ radclw, ! Computes longwave radiation $ radout ! Sets radiation output and converts units C C----------------------------------------------------------------------- C C Set ozone C if (anncyc) then if (nstep.eq.0 .or. iradae.eq.1 .or. $ (mod(nstep-1,iradae).eq.0 .and. nstep.ne.1) ) then call radoz2(lat ,pint ,plol ,plos ) end if else if(nstep.eq.0) call radoz2(lat ,pint ,plol ,plos ) end if C C Set latitude dependent radiation input C call radinp(clat ,pmid ,pint ,h2ommr ,cld , $ plos ,pbr ,pnm ,plco2 ,plh2o , $ tclrsf ,eccf ,coszrs ,o3mmr,hx,hy ) C C Solar radiation computation C call radcsw(lat ,rel ,rei ,fice ,ioro , $ sndpth ,pnm ,h2ommr ,cld ,clwp , $ o3mmr ,eccf ,coszrs ,solin ,qrs , $ fsns ,fsnt ,fsnsc ,fsntc ) C C Longwave radiation computation C call radclw(lat ,tg ,plol ,plos ,t , $ h2ommr ,pbr ,pnm ,pmln ,piln , $ plco2 ,plh2o ,effcld ,tclrsf ,qrl , $ flns ,flnt ,flnsc ,flntc ,slwd ) C C Set output radiation fields C call radout(solin ,fsnt ,fsns ,fsntc ,fsnsc , $ flnt ,flns ,flntc ,flnsc ,slwd , $ srfrad ) C CMIREKA do i=1,plon sabs(i)=fsns(i) ldown(i)=slwd(i)*1.e-3 lnet(i)=flns(i) enddo return end subroutine radinp(clat ,pmid ,pint ,h2ommr ,cld , $ plos ,pmidrd ,pintrd ,plco2 ,plh2o , $ tclrsf ,eccf ,coszrs ,o3mmr,hx,hy) CMIREKA ADDED hx and hy - terrain slope C----------------------------------------------------------------------- C C Sets latitude and time dependent arrays for input to solar C and longwave radiation. C C Computes solar input (earth-sun distance factor and cosine solar C zenith angle), converts model pressures to cgs, computes C path length arrays needed for the longwave radiation, C and computes ozone mixing ratio, needed for the solar C radiation. C C---------------------------Code history-------------------------------- C C Original version: CCM1 C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) CMIREKA real hx(plon),hy(plon) C C------------------------------Commons---------------------------------- C C Model time variables C common/comtim/calday ,dtime ,twodt ,nrstrt ,nstep , $ nstepr ,nestep ,nelapse ,nstop ,mdbase , $ msbase ,mdcur ,mscur ,mbdate ,mbsec , $ mcdate ,mcsec ,nndbas ,nnsbas ,nnbdat , $ nnbsec C real calday, ! Current calendar day = julian day + fraction $ dtime, ! Time step in seconds (delta t) $ twodt ! 2 * delta t integer $ nrstrt, ! Starting time step of restart run (constant) $ nstep, ! Current time step $ nstepr, ! Current time step of restart run(updated w/nstep) $ nestep, ! Time step on which to stop run $ nelapse, ! Requested elapsed time for model run $ nstop, ! nestep + 1 $ mdbase, ! Base day of run $ msbase, ! Base seconds of base day $ mdcur, ! Current day of run $ mscur, ! Current seconds of current day $ mbdate, ! Base date of run (yymmdd format) $ mbsec, ! Base seconds of base date $ mcdate, ! Current date of run (yymmdd format) $ mcsec, ! Current seconds of current date $ nndbas, ! User input base day $ nnsbas, ! User input base seconds of input base day $ nnbdat, ! User input base date (yymmdd format) $ nnbsec ! User input base seconds of input base date C C----------------------------------------------------------------------- C C Radiation constants C common/crdcon/gravit ,rga ,cpair ,epsilo ,sslp , $ stebol ,rgsslp ,co2vmr ,dpfo3 ,dpfco2 , $ dayspy ,pie C real gravit, ! Acceleration of gravity $ rga, ! 1./gravit $ cpair, ! Specific heat of dry air $ epsilo, ! Ratio of mol. wght of H2O to dry air $ sslp, ! Standard sea-level pressure $ stebol, ! Stefan-Boltzmann's constant $ rgsslp, ! 0.5/(gravit*sslp) $ co2vmr, ! CO2 volume mixing ratio $ dpfo3, ! Voigt correction factor for O3 $ dpfco2, ! Voigt correction factor for CO2 $ dayspy, ! Number of days per 1 year $ pie ! 3.14..... C C------------------------------Arguments-------------------------------- C C Input arguments C real clat, ! Current latitude (radians) $ pmid(plond,plev), ! Pressure at model mid-levels (pascals) $ pint(plond,plevp), ! Pressure at model interfaces (pascals) $ h2ommr(plond,plev), ! H2o mass mixing ratio $ cld(plond,plevp), ! Fractional cloud cover $ plos(plond,plevp) ! O3 path length (cm) C C Output arguments C real pmidrd(plond,plev), ! Pressure at mid-levels (dynes/cm*2) $ pintrd(plond,plevp),! Pressure at interfaces (dynes/cm*2) $ plco2(plond,plevp), ! Vert. pth lngth of co2 (prs-weighted) $ plh2o(plond,plevp), ! Vert. pth lngth h2o vap.(prs-weighted) $ tclrsf(plond,plevp) ! Product of clr-sky fractions from top C ! of atmosphere to level. real eccf, ! Earth-sun distance factor $ coszrs(plond), ! Cosine solar zenith angle $ o3mmr(plond,plev) ! Ozone mass mixing ratio C C---------------------------Local variables----------------------------- C integer i, ! Longitude loop index $ k ! Vertical loop index C real phi, ! Greenwich calendar day + local time + long offset $ theta, ! Earth orbit seasonal angle in radians $ delta, ! Solar declination angle in radians $ sinc, ! Sine of latitude $ cosc, ! Cosine of latitude $ sind, ! Sine of declination $ cosd, ! Cosine of declination $ v0 , ! Volume of a gas at stp (cm**3/mol) $ p0 , ! Standard pressure (dynes/cm**2) $ amd, ! Effective molecular weight of dry air (g/mol) $ amo, ! Molecular weight of ozone (g/mol) $ amco2, ! Molecular weight of co2 (g/mol) $ cpl, ! Constant in ozone path length to mixing ratio $ cpwpl, ! Const in co2 mixing ratio to path length conversn $ vmmr ! Ozone volume mixing ratio save v0, p0 ,amd ,amo ,amco2 C data v0 / 22413.6 / data p0 / 1.01325e6 / data amd / 28.9644 / data amo / 48.0000 / data amco2 / 44.0000 / C C----------------------------------------------------------------------- C C Compute solar distance factor and cosine solar zenith angle usi C day value where a round day (such as 213.0) refers to 0z at C Greenwich longitude. C C Use formulas from Paltridge, G.W. and C.M.R. Platt 1976: Radiative C Processes in Meterology and Climatology, Elsevier Scientific C Publishing Company, New York p. 57, p. 62,63. C C Compute eccentricity factor (sun-earth distance factor) C theta = 2.*pie*calday/dayspy eccf = 1.000110 + .034221*cos(theta) + .001280*sin(theta) + $ .000719*cos(2.*theta) + .000077*sin(2.*theta) C C Solar declination in radians: C delta = .006918 - .399912*cos(theta) + .070257*sin(theta) - $ .006758*cos(2.*theta) + .000907*sin(2.*theta) - $ .002697*cos(3.*theta) + .001480*sin(3.*theta) C C Compute local cosine solar zenith angle, C sinc = sin(clat) sind = sin(delta) cosc = cos(clat) cosd = cos(delta) C C Calday is the calender day for Greenwich, including fraction C of day; the fraction of the day represents a local time at C Greenwich; to adjust this to produce a true instantaneous time C For other longitudes, we must correct for the local time change: C do i=1,plon c phi = calday + (real(i-1)/real(plon)) phi = calday c-----> for GATE substract 23.5/360. to account for longitude c-----> offset for GATE area (23.5 deg W); calday is Greenwich c phi = phi - 23.5/360. coszrs(i) = sinc*sind - cosc*cosd*cos(2.*pie*phi) coszrs(i) = (coszrs(i) -hx(i)*cosd*sin(2.*pie*phi) - . hy(i)*(sinc*cosd*cos(2.*pie*phi)-cosc*sind))/ . sqrt(1.+hx(i)**2.+hy(i)**2.) cc for constant zenith angle: c coszrs(i) = 1. end do C C Convert pressure from pascals to dynes/cm2 C do k=1,plev do i=1,plon pmidrd(i,k) = pmid(i,k)*10.0 pintrd(i,k) = pint(i,k)*10.0 end do end do do i=1,plon pintrd(i,plevp) = pint(i,plevp)*10.0 end do C C Compute path quantities used in the longwave radiation: C vmmr = amco2 / amd cpwpl = vmmr * 0.5 / (gravit * p0) do i=1,plon plh2o(i,1) = rgsslp*h2ommr(i,1)*pintrd(i,1)*pintrd(i,1) plco2(i,1) = co2vmr*cpwpl*pintrd(i,1)*pintrd(i,1) tclrsf(i,1) = 1. end do do k=1,plev do i=1,plon plh2o(i,k+1) = plh2o(i,k) + rgsslp* $ (pintrd(i,k+1)**2 - pintrd(i,k)**2)*h2ommr(i,k) plco2(i,k+1) = co2vmr*cpwpl*pintrd(i,k+1)**2 tclrsf(i,k+1) = tclrsf(i,k)*(1.-cld(i,k+1)) end do end do C C Compute ozone mixing ratio from path lengths: C cpl = v0 / (amd * gravit) vmmr = amd / amo C do k=1,plev do i=1,plon o3mmr(i,k) = (plos(i,k+1)-plos(i,k)) $ /(cpl*vmmr*(pintrd(i,k+1)-pintrd(i,k))) end do end do C return end subroutine radout(solin ,fsnt ,fsns ,fsntc ,fsnsc , $ flnt ,flns ,flntc ,flnsc ,slwd , $ srfrad ) C----------------------------------------------------------------------- C C Change units of the radiative fluxes from cgs to mks for output C C Compute the absorbed solar plus down longwave flux at the surface C for the surface temperature computation. C C---------------------------Code history-------------------------------- C C Original version: CCM1 C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C------------------------------Arguments-------------------------------- C C Input arguments C real solin(plond), ! Instantaneous incident solar $ fsnt(plond), ! Net column absorbed solar flux at model top $ fsns(plond), ! Surface absorbed solar flux $ fsntc(plond), ! Clear sky total column abs solar flux $ fsnsc(plond), ! Clear sky surface absorbed solar flux $ flnt(plond), ! Net up flux top of model (up-dwn flx) $ flns(plond), ! Longwave cooling of surface (up-dwn flx) $ flntc(plond), ! Clr sky net up flx at model top (up-dwn flx) $ flnsc(plond), ! Clr sky lw cooling of srf (up-dwn flx) $ slwd(plond), ! Surface longwave down flux $ srfrad(plond) ! Surface radiative heat flux (fsns+swld) C C---------------------------Local variables----------------------------- C integer i ! Longitude index real cgsmks ! cgs to mks conversion factor for fluxes save cgsmks C data cgsmks / 1.e-3 / C C----------------------------------------------------------------------- C CDIR$ IVDEP C C Compute total radiative heating flux for the surface, C converting units from cgs to mks: C do i=1,plon srfrad(i) = (fsns(i) + slwd(i)) * cgsmks end do C C Convert units from cgs to mks in solar fluxes: C do i=1,plon solin(i) = solin(i) * cgsmks fsnt(i) = fsnt(i) * cgsmks fsns(i) = fsns(i) * cgsmks fsntc(i) = fsntc(i) * cgsmks fsnsc(i) = fsnsc(i) * cgsmks end do C C Convert units from cgs to mks in longwave fluxes: C do i=1,plon flnt(i) = flnt(i) * cgsmks flns(i) = flns(i) * cgsmks flntc(i) = flntc(i) * cgsmks flnsc(i) = flnsc(i) * cgsmks end do C return end subroutine radclw(lat ,tg ,plol ,plos ,tnm , $ qnm ,pmid ,pint ,pmln ,piln , $ plco2 ,plh2o ,cld ,tclrsf ,qrl , $ flns ,flnt ,flnsc ,flntc ,slwd ) C----------------------------------------------------------------------- C C Compute longwave radiation heating rates and boundary fluxes C C Uses broad band absorptivity/emissivity method to compute clear sky; C assumes randomly overlapped clouds with variable cloud emissivity to C include effects of clouds. C C Computes clear sky absorptivity/emissivity at lower frequency (in C general) than the model radiation frequency; uses previously computed C and stored values for efficiency C C Note: This subroutine contains vertical indexing which proceeds C from bottom to top rather than the top to bottom indexing C used in the rest of the model. C C---------------------------Code history-------------------------------- C C Original version: CCM1 C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C----------------------------------------------------------------------- integer plevp2,plevp3,plevp4 parameter (plevp2=plev+2,plevp3=plev+3,plevp4=plev+4) C------------------------------Commons---------------------------------- C C Logical unit numbers and related variables C integer $ pnrg1, ! maximum number of primary C ! regeneration files $ pnrg2 ! maximum number of secondary C ! regeneration files parameter (pnrg1 = 5) parameter (pnrg2 = 5) common/comlun/nsds ,nrg ,nrg1 ,nrg2 ,nra1 , $ nrb1 ,nprint ,nout , $ ninit ,nbndti ,nozone ,nsst , $ nabem ,lutag(99) common/comlun/rg1lat ,rg1siz ,rg1buf ,nnrg1 , $ rg2lat ,rg2siz ,rg2buf ,nnrg2 , $ mxszrg ,nrefrq ,lrewrt common/comlunc/rg1ext ,rg2ext C integer nsds, ! restart dataset unit $ nrg, ! master regeneration dataset unit $ nrg1(pnrg1), ! primary regeneration dataset units $ nrg2(pnrg2), ! secondary regeneration dataset units $ nra1, ! a work file $ nrb1, ! b work file $ nprint, ! alternate print unit $ nout, ! print unit $ ninit, ! initial dataset unit $ nbndti, ! time-invariant boundary dataset $ nozone, ! ozone dataset $ nsst, ! sst dataset $ nabem ! absorptivity/emissivity work file logical lutag ! list of flags marking logical units in use integer $ rg1lat(pnrg1+1), ! latitude list for primary regen datasets $ rg1siz(pnrg1), ! file sizes for preallocation $ rg1buf, ! buffer length for assign $ nnrg1, ! number of primary regen files written $ rg2lat(pnrg2+1), ! lat list for secondary regen datasets $ rg2siz(pnrg2), ! file size for preallocation $ rg2buf, ! buffer length for assign $ nnrg2, ! number of secondary regen files written $ mxszrg, ! max size of a regen file (megabytes) $ nrefrq ! frequency of regeneration file writes logical lrewrt ! Set true when it is time to write regen C ! files character*2 $ rg1ext(pnrg1), ! file extension for primary regen files $ rg2ext(pnrg2) ! file extension for secondary regen files C C----------------------------------------------------------------------- C C Model time variables C common/comtim/calday ,dtime ,twodt ,nrstrt ,nstep , $ nstepr ,nestep ,nelapse ,nstop ,mdbase , $ msbase ,mdcur ,mscur ,mbdate ,mbsec , $ mcdate ,mcsec ,nndbas ,nnsbas ,nnbdat , $ nnbsec C real calday, ! Current calendar day = julian day + fraction $ dtime, ! Time step in seconds (delta t) $ twodt ! 2 * delta t integer $ nrstrt, ! Starting time step of restart run (constant) $ nstep, ! Current time step $ nstepr, ! Current time step of restart run(updated w/nstep) $ nestep, ! Time step on which to stop run $ nelapse, ! Requested elapsed time for model run $ nstop, ! nestep + 1 $ mdbase, ! Base day of run $ msbase, ! Base seconds of base day $ mdcur, ! Current day of run $ mscur, ! Current seconds of current day $ mbdate, ! Base date of run (yymmdd format) $ mbsec, ! Base seconds of base date $ mcdate, ! Current date of run (yymmdd format) $ mcsec, ! Current seconds of current date $ nndbas, ! User input base day $ nnsbas, ! User input base seconds of input base day $ nnbdat, ! User input base date (yymmdd format) $ nnbsec ! User input base seconds of input base date C C----------------------------------------------------------------------- C C Radiation constants C common/crdcon/gravit ,rga ,cpair ,epsilo ,sslp , $ stebol ,rgsslp ,co2vmr ,dpfo3 ,dpfco2 , $ dayspy ,pie C real gravit, ! Acceleration of gravity $ rga, ! 1./gravit $ cpair, ! Specific heat of dry air $ epsilo, ! Ratio of mol. wght of H2O to dry air $ sslp, ! Standard sea-level pressure $ stebol, ! Stefan-Boltzmann's constant $ rgsslp, ! 0.5/(gravit*sslp) $ co2vmr, ! CO2 volume mixing ratio $ dpfo3, ! Voigt correction factor for O3 $ dpfco2, ! Voigt correction factor for CO2 $ dayspy, ! Number of days per 1 year $ pie ! 3.14..... C C----------------------------------------------------------------------- C C Model control variables C common/comctl/itsst ,nsrest ,iradae ,irad ,anncyc , $ nlend ,nlres ,nlhst ,lbrnch ,ldebug , $ aeres ,doslt ,ozncyc ,sstcyc integer $ itsst, ! Sea surf. temp. update freq. (iters) $ nsrest, ! Restart flag $ iradae, ! Iteration freq. for absorptivity/emissivity comp $ irad ! Iteration frequency for radiation computation logical $ anncyc, ! Do annual cycle (otherwise perpetual) $ nlend, ! Flag for end of run $ nlres, ! If true, continuation run $ nlhst, ! If true, regeneration run $ lbrnch, ! If true, branch run $ ldebug, ! If in debug mode, link output files to /usr/tmp C ! before mswrite, and remove all but last file $ aeres, ! If true, a/e data will be stored on restart file $ doslt, ! true -> slt, false -> spectral transport $ ozncyc, ! If true, cycle ozone dataset $ sstcyc ! If true, cycle sst dataset C C----------------------------------------------------------------------- C C Parameter definitions of record lengths for longwave radiation C absorptivity and emissivity (abs/ems) dataset C integer $ plenblk, ! blocked length of abs/ems data record $ pnabebf, ! number of 512 word blocks per abs/ems record $ plngbuf ! unblocked length of abs/ems data record C parameter (plenblk=plond*plevp*plevp + plond*plev*4 + plond*plevp) parameter (pnabebf=plenblk/512 + 1) parameter (plngbuf=512*pnabebf) C C------------------------------Arguments-------------------------------- C C Input arguments C integer lat ! Model latitude index real tg(plond), ! Ground (skin) temperature $ plol(plond,plevp), ! O3 pressure wghted path length $ plos(plond,plevp) ! O3 path length C C Input arguments which are only passed to other routines C real tnm(plond,plev), ! Level temperature $ qnm(plond,plev), ! Level moisture field $ pmid(plond,plev), ! Level pressure $ pint(plond,plevp), ! Model interface pressure $ pmln(plond,plev), ! Ln(pmid) $ piln(plond,plevp), ! Ln(pint) $ plco2(plond,plevp), ! Path length co2 $ plh2o(plond,plevp) ! Path length h2o C C Input/Output arguments C real cld(plond,plevp), ! Cloud cover $ tclrsf(plond,plevp) ! Clear sky fraction C C Output arguments C real qrl(plond,plev), ! Longwave heating rate $ flns(plond), ! Surface cooling flux $ flnt(plond), ! Net outgoing flux $ flnsc(plond), ! Clear sky surface cooing $ flntc(plond), ! Net clear sky outgoing flux $ slwd(plond) ! Down longwave flux at surface C C---------------------------Local variables----------------------------- C integer i, ! Longitude index $ k, ! Level index $ k1, ! Level index $ k2, ! Level index $ k3, ! Level index $ km, ! Level index $ kmm, ! Level index $ km1, ! Level index $ km2, ! Level index $ km3, ! Level index $ km4 ! Level index C integer itop, ! Level index $ icld, ! Level index $ klo, ! Level index $ khi, ! Level index $ mp1, ! Level index $ mp12, ! Level index $ mm1, ! Level index $ nptsc ! Level index C real sum, ! Integral of absorptivity X dB $ tmp1, ! Temporary 1 $ absbt(plond) ! Downward emission at model top C real co2em(plond,plevp), ! Layer co2 normalized planck funct. derivative $ co2eml(plond,plev), ! Interface co2 normalized planck funct. deriv. $ delt(plond), ! Diff t**4 mid layer to top interface $ delt1(plond), ! Diff t**4 lower intrfc to mid layer $ bk1(plond), ! Absrptvty for vertical quadrature $ bk2(plond), ! Absrptvty for vertical quadrature $ ful(plond,plevp), ! Total upwards longwave flux $ fsul(plond,plevp), ! Clear sky upwards longwave flux $ fdl(plond,plevp), ! Total downwards longwave flux $ fsdl(plond,plevp), ! Clear sky downwards longwv flux $ fclb4(plond,plev), ! Sig t**4 for cld bottom interfc $ fclt4(plond,plev), ! Sig t**4 for cloud top interfc $ s(plond,plevp,plevp) ! Flx integral sum real absnxt(plond,plev,4), ! Nearest layer absorptivities $ abstot(plond,plevp,plevp), ! Non-adjacent lyr absorptivites $ emstot(plond,plevp), ! Total emissivity $ tplnka(plond,plevp), ! Planck fnctn tmp $ s2c(plond,plevp), ! H2o cont amount $ s2t(plond,plevp), ! H2o cont tmp $ w(plond,plevp), ! H2o path $ tplnke(plond) ! Planck fnctn tmp real h2otr(plond,plevp), ! H2o trnmsn for o3 overlap $ co2t(plond,plevp), ! Prs wghted tmp path $ tint(plond,plevp), ! Interface tmp $ tint4(plond,plevp), ! Interface tmp**4 $ tlayr(plond,plevp), ! Level tmp $ tlayr4(plond,plevp) ! Level tmp**4 integer ipos(plond), ! Array for specified condition $ indxc(plond), ! Indices for cloud covered points $ klov(plond), ! Cloud lowest level index $ khiv(plond) ! Cloud highest level index real absems(plngbuf) ! Absorbs's and emiss's in buffer C C------------------------------Equivalences----------------------------- C equivalence (abstot,absems(1 )), $ (absnxt,absems(1 + plond*plevp*plevp )), $ (emstot,absems(1 + plond*plevp*plevp + plond*plev*4)) C C------------------------------Externals-------------------------------- C external radtpl, ! Compute path lengths $ radems, ! H2o,co2,o3 emissivity $ radabs, ! H2o,co2,o3 absorptivity $ writeric, ! Write for abs/ems $ readric ! Read for abs/ems C C----------------------------------------------------------------------- cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real upsw,dnsw,uplw,dnlw ! upward and downward fluxes common/rad_save2/ upsw(plon,plevp),dnsw(plon,plevp), * uplw(plon,plevp),dnlw(plon,plevp) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C Initialize and recompute the tclrsf array C do k=1,plev do i=1,plon fclb4(i,k) = 0. fclt4(i,k) = 0. tclrsf(i,k+1) = tclrsf(i,k)*(1. - cld(i,k+1)) end do end do C C Calculate some temperatures needed to derive absorptivity and C emissivity, as well as some h2o path lengths C call radtpl(tnm ,tg ,qnm ,pmid ,pint , $ plh2o ,tplnka ,s2c ,s2t ,w , $ tplnke ,tint ,tint4 ,tlayr ,tlayr4 , $ pmln ,piln ) C C Do emissivity and absorptivity calculations only if abs/ems C computation C if(nstep.eq.0 .or. iradae.eq.1 .or. $ (mod(nstep-1,iradae).eq.0 .and. nstep.ne.1)) then C C Compute total emissivity: C call radems(s2c ,s2t ,w ,tplnke ,plh2o , $ pint ,plco2 ,tint ,tint4 ,tlayr , $ tlayr4 ,plol ,plos ,co2em ,co2eml , $ co2t ,h2otr ,emstot ) C C Compute total absorptivity: C call radabs(pmid ,pint ,co2em ,co2eml ,tplnka , $ s2c ,s2t ,w ,h2otr ,plco2 , $ plh2o ,co2t ,tint ,tlayr ,plol , $ plos ,pmln ,piln ,abstot ,absnxt ) C call writeric(nabem ,absems(1),plngbuf ,lat ) else C C Retrieve total absorptivity and emissivity from last abs/ems C computation C call readric(nabem ,absems(1),plngbuf ,lat ) end if C C Compute fluxes and cooling rates. Initialize longitude index subset. C do i=1,plon ipos(i) = 1 end do C C Find the lowest and highest level cloud for each grid point C C Note: Vertical indexing here proceeds from bottom to top C do 100 i=1,plon klov(i) = 0 do k=1,plev if(cld(i,plevp2-k) .gt. 0.0)then klov(i) = k go to 100 end if end do 100 continue C C Note: Vertical indexing here proceeds from bottom to top C do 200 i=1,plon khiv(i) = klov(i) itop = klov(i) if(itop.eq.0) itop = 1 do k=plev,itop,-1 if(cld(i,plevp2-k) .gt. 0.0)then khiv(i) = k go to 200 end if end do 200 continue C C Note: Vertical indexing here proceeds from bottom to top C do i=1,plon if(klov(i).ne.0)then do k=klov(i),khiv(i) fclt4(i,plevp-k) = stebol*tint4(i,plevp2-k) fclb4(i,plevp-k) = stebol*tint4(i,plevp3-k) end do end if end do C C Compute sums used in integrals (all longitude points) C C Definition of bk1 & bk2 depends on finite differencing. for C trapezoidal rule bk1=bk2. trapezoidal rule applied for nonadjacent C layers only. C C delt=t**4 in layer above current sigma level km. C delt1=t**4 in layer below current sigma level km. C do i=1,plon delt(i) = tint4(i,plev) - tlayr4(i,plevp) delt1(i) = tlayr4(i,plevp) - tint4(i,plevp) s(i,plevp,plevp) = stebol*(delt1(i)*absnxt(i,plev,1) + $ delt (i)*absnxt(i,plev,4)) s(i,plev,plevp) = stebol*(delt (i)*absnxt(i,plev,2) + $ delt1(i)*absnxt(i,plev,3)) end do do k=1,plev-1 do i=1,plon bk2(i) = (abstot(i,k,plev) + abstot(i,k,plevp))*0.5 bk1(i) = bk2(i) s(i,k,plevp) = stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i)) end do end do C C All k, km>1 C do 300 km=plev,2,-1 do i=1,plon delt(i) = tint4(i,km-1) - tlayr4(i,km) delt1(i) = tlayr4(i,km) - tint4(i,km) end do do k=plevp,1,-1 if (k.eq.km) then do i=1,plon bk2(i) = absnxt(i,km-1,4) bk1(i) = absnxt(i,km-1,1) end do else if(k.eq.km-1) then do i=1,plon bk2(i) = absnxt(i,km-1,2) bk1(i) = absnxt(i,km-1,3) end do else do i=1,plon bk2(i) = (abstot(i,k,km-1) + abstot(i,k,km))*0.5 bk1(i) = bk2(i) end do end if do i=1,plon s(i,k,km) = s(i,k,km+1) + stebol* $ (bk2(i)*delt(i) + bk1(i)*delt1(i)) end do end do 300 continue C C Computation of clear sky fluxes always set first level of fsul C do i=1,plon fsul(i,plevp) = stebol*(tg(i)**4) end do C C All longitude points C do k=1,plev do i=1,plon tmp1 = fsul(i,plevp) - stebol*tint4(i,plevp) fsul(i,k) = fsul(i,plevp) - abstot(i,k,plevp)*tmp1 + $ s(i,k,k+1) end do end do C C Downward clear sky fluxes store intermediate quantities in down flux C do k=1,plevp do i=1,plon fsdl(i,k) = stebol*(tplnke(i)**4)*emstot(i,k) end do end do C C Store the downward emission from level 1 = total gas emission * sigma C t**4. fsdl does not yet include all terms C do i=1,plon absbt(i) = fsdl(i,plevp) end do C C fsdl(i,plevp) assumes isothermal layer C do k=2,plev do i=1,plon fsdl(i,k) = fsdl(i,k) - (s(i,k,2) - s(i,k,k+1)) end do end do do i=1,plon fsdl(i,plevp) = absbt(i) - s(i,plevp,2) end do C C Computation of the upward fluxes C C First set fluxes to clear sky values, then modify for clouds C do k=1,plevp do i=1,plon ful(i,k) = fsul(i,k) fdl(i,k) = fsdl(i,k) end do end do C C Modifications for clouds C C Further qualify longitude subset for computations by changing ipos C from 1 to 2 where there are clouds (total cloud fraction <= 1.e-3 C treated as clear) C do i=1,plon if((1.-tclrsf(i,plevp)) .gt. 1.e-3) then ipos(i) = 2 end if end do C C Generate longitude index list (indxc) for cloud modifications C call wheneq(plon,ipos,1,2,indxc,nptsc) C C Compute downflux at level 1 for cloudy sky C do icld=1,nptsc i = indxc(icld) C C First clear sky flux plus flux from cloud at level 1 C fdl(i,plevp) = fsdl(i,plevp)*tclrsf(i,plev)/ $ tclrsf(i,plevp-khiv(i)) + fclb4(i,plev-1)*cld(i,plev) end do C C Flux emitted by other layers C C Note: Vertical indexing here proceeds from bottom to top C do icld=1,nptsc i = indxc(icld) do km=3,khiv(i) km1 = plevp - km km2 = plevp2 - km km4 = plevp4 - km tmp1 = cld(i,km2)*tclrsf(i,plev)/tclrsf(i,km2) fdl(i,plevp) = fdl(i,plevp) + $ (fclb4(i,km1) - s(i,plevp,km4))*tmp1 end do end do C C Begin outer longitude loop for cloud modifications (operate on points C with clouds only) C C Note: Vertical indexing here proceeds from bottom to top C do 400 icld=1,nptsc i = indxc(icld) klo = klov(i) khi = khiv(i) mp1 = khi + 1 mp12 = plevp2 - mp1 mm1 = khi - 1 do k=klo,mm1 k1 = plevp - k k2 = plevp2 - k k3 = plevp3 - k sum = fsul(i,k2)*(tclrsf(i,plevp)/tclrsf(i,k1)) do km=klo,k km1 = plevp - km km2 = plevp2 - km km3 = plevp3 - km sum = sum + (fclt4(i,km1) + s(i,k2,k3) - s(i,k2,km3))* $ cld(i,km2)*(tclrsf(i,km1)/tclrsf(i,k1)) end do ful(i,k2) = sum end do do k=khi,plevp k2 = plevp2 - k k3 = plevp3 - k sum = fsul(i,k2)*tclrsf(i,plevp)/tclrsf(i,mp12) do km=klo,khi km1 = plevp - km km2 = plevp2 - km km3 = plevp3 - km sum = sum + (cld(i,km2)*tclrsf(i,km1)/tclrsf(i,mp12))* $ (fclt4(i,km1) + s(i,k2,k3) - s(i,k2,km3)) end do ful(i,k2) = sum end do C C Computation of the downward fluxes C C Note: Vertical indexing here proceeds from bottom to top C do k=2,mm1 k1 = plevp - k k2 = plevp2 - k k3 = plevp3 - k sum = 0. kmm = max0(k+1,klo) do km=kmm,khi km1 = plevp - km km2 = plevp2 - km km4 = plevp4 - km sum = sum + (cld(i,km2)*tclrsf(i,k1)/tclrsf(i,km2))* $ (fclb4(i,km1) - s(i,k2,km4) + s(i,k2,k3)) end do fdl(i,k2) = sum + fsdl(i,k2)*(tclrsf(i,k1)/tclrsf(i,mp12)) end do cccccccccccccccccCCCCCCCCCCCC c print*,'***** cld: ',cld c print*,'***** tclrsf: ',tclrsf c print*,'***** fsdl: ',fsdl cccccccccccccccccCCCCCCCCCCCC C C End cloud modification longitude loop C 400 continue C C Back to original longitude subset. C Put down longwave flux in local array. C do i=1,plon slwd(i) = fdl(i,plevp) flns(i) = ful(i,plevp) - fdl(i,plevp) end do C C All longitudes: store history tape quantities C do i=1,plon C C Net flux C flns(i) = ful(i,plevp) - fdl(i,plevp) C C Clear sky flux at top of atmosphere C flntc(i) = fsul(i,1) flnsc(i) = fsul(i,plevp) - fsdl(i,plevp) C C Outgoing ir C flnt(i) = ful(i,1) - fdl(i,1) end do C C Computation of longwave heating (k per sec) C do k=1,plev do i=1,plon qrl(i,k) = (ful(i,k) - fdl(i,k) - ful(i,k+1) + fdl(i,k+1))* $ gravit/((pint(i,k) - pint(i,k+1))*cpair) end do end do c Save lw fluxes: do k=1,plevp do i=1,plon uplw(i,k) = ful(i,k) dnlw(i,k) = fdl(i,k) end do end do C return end subroutine radtpl(tnm ,tg ,qnm ,pbr ,pnm , $ plh2o ,tplnka ,s2c ,s2t ,w , $ tplnke ,tint ,tint4 ,tlayr ,tlayr4 , $ pmln ,piln ) C----------------------------------------------------------------------- C C Compute temperatures and path lengths for longwave radiation C C---------------------------Code history-------------------------------- C C Original version: CCM1 C Standardized: L. Buja, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C------------------------------Commons---------------------------------- C C Radiation constants C common/crdcon/gravit ,rga ,cpair ,epsilo ,sslp , $ stebol ,rgsslp ,co2vmr ,dpfo3 ,dpfco2 , $ dayspy ,pie C real gravit, ! Acceleration of gravity $ rga, ! 1./gravit $ cpair, ! Specific heat of dry air $ epsilo, ! Ratio of mol. wght of H2O to dry air $ sslp, ! Standard sea-level pressure $ stebol, ! Stefan-Boltzmann's constant $ rgsslp, ! 0.5/(gravit*sslp) $ co2vmr, ! CO2 volume mixing ratio $ dpfo3, ! Voigt correction factor for O3 $ dpfco2, ! Voigt correction factor for CO2 $ dayspy, ! Number of days per 1 year $ pie ! 3.14..... C C------------------------------Arguments-------------------------------- C C Input arguments C real tnm(plond,plev), ! Model level temperatures $ tg(plond), ! Surface skin temperature $ qnm(plond,plev), ! Model level specific humidity $ pbr(plond,plev), ! Pressure at model mid-levels (dynes/cm2) $ pnm(plond,plevp), ! Pressure at model interfaces (dynes/cm2) $ plh2o(plond,plevp) ! Pressure weighted h2o path C C Output arguments C real tplnka(plond,plevp), ! Level temperature from interface temperatures $ s2c(plond,plevp), ! H2o continuum path length $ s2t(plond,plevp), ! H2o tmp and prs wghtd path length $ w(plond,plevp), ! H2o path length $ tplnke(plond), ! Equal to tplnka $ tint(plond,plevp), ! Layer interface temperature $ tint4(plond,plevp), ! Tint to the 4th power $ tlayr(plond,plevp), ! K-1 level temperature $ tlayr4(plond,plevp), ! Tlayr to the 4th power $ pmln(plond,plev), ! Ln(pmidm1) $ piln(plond,plevp) ! Ln(pintm1) C C---------------------------Local variables----------------------------- C integer i, ! Longitude index $ k ! Level index real r296, ! Inverse stand temp for h2o continuum $ repsil, ! Inver ratio mol weight h2o to dry air $ dy, ! Thickness of layer for tmp interp $ dpnm, ! Pressure thickness of layer $ dpnmsq, ! Prs squared difference across layer $ rtnm ! Inverse level temperature C C----------------------------------------------------------------------- C r296 = 1./296. repsil = 1./epsilo C C Set the top and bottom intermediate level temperatures, C top level planck temperature and top layer temp**4. C C Tint is lower interface temperature C (not available for bottom layer, so use ground temperature) C do i=1,plon tint(i,plevp) = tg(i) tint4(i,plevp) = tint(i,plevp)**4 tplnka(i,1) = tnm(i,1) tint(i,1) = tplnka(i,1) tlayr4(i,1) = tplnka(i,1)**4 tint4(i,1) = tlayr4(i,1) end do C C Intermediate level temperatures are computed using temperature C at the full level below less dy*delta t,between the full level C do k=2,plev do i=1,plon dy = (piln(i,k) - pmln(i,k))/(pmln(i,k-1) - pmln(i,k)) tint(i,k) = tnm(i,k) - dy*(tnm(i,k)-tnm(i,k-1)) tint4(i,k) = tint(i,k)**4 end do end do C C Now set the layer temp=full level temperatures and establish a C planck temperature for absorption (tplnka) which is the average C the intermediate level temperatures. Note that tplnka is not C equal to the full level temperatures. C do k=2,plevp do i=1,plon tlayr(i,k) = tnm(i,k-1) tlayr4(i,k) = tlayr(i,k)**4 tplnka(i,k) = .5*(tint(i,k) + tint(i,k-1)) end do end do C C Calculate tplank for emissivity calculation. C Assume isothermal tplnke i.e. all levels=ttop. C do i=1,plon tplnke(i) = tplnka(i,1) tlayr(i,1) = tint(i,1) end do C C Now compute h2o path fields: C do i=1,plon s2t(i,1) = plh2o(i,1) * tnm(i,1) w(i,1) = (plh2o(i,1)*2.) / pnm(i,1) s2c(i,1) = plh2o(i,1) * qnm(i,1) * repsil end do do k=1,plev do i=1,plon dpnm = pnm(i,k+1) - pnm(i,k) dpnmsq = pnm(i,k+1)**2 - pnm(i,k)**2 rtnm = 1./tnm(i,k) s2t(i,k+1) = s2t(i,k) + rgsslp*dpnmsq*qnm(i,k)*tnm(i,k) w(i,k+1) = w(i,k) + rga*qnm(i,k)*dpnm s2c(i,k+1) = s2c(i,k) + rgsslp*dpnmsq*qnm(i,k)* $ exp(1800.*(rtnm - r296))*qnm(i,k)*repsil end do end do C return end subroutine radabs(pbr ,pnm ,co2em ,co2eml ,tplnka , $ s2c ,s2t ,w ,h2otr ,plco2 , $ plh2o ,co2t ,tint ,tlayr ,plol , $ plos ,pmln ,piln ,abstot ,absnxt ) C----------------------------------------------------------------------- C C Compute absorptivities for h2o, co2, and o3 C C h2o .... Uses nonisothermal emissivity for water vapor from C Ramanathan, V. and P.Downey, 1986: A Nonisothermal C Emissivity and Absorptivity Formulation for Water Vapor C Journal of Geophysical Research, vol. 91., D8, pp 8649-8666 C C co2 .... Uses absorptance parameterization of the 15 micro-meter C (500 - 800 cm-1) band system of Carbon Dioxide, from C Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization C of the Absorptance Due to the 15 micro-meter Band System C of Carbon Dioxide Jouranl of Geophysical Research, C vol. 96., D5, pp 9013-9019 C C o3 .... Uses absorptance parameterization of the 9.6 micro-meter C band system of ozone, from Ramanathan, V. and R.Dickinson, C 1979: The Role of stratospheric ozone in the zonal and C seasonal radiative energy balance of the earth-troposphere C system. Journal of the Atmospheric Sciences, Vol. 36, C pp 1084-1104 C C Computes individual absorptivities for non-adjacent layers, accounting C for band overlap, and sums to obtain the total; then, computes the C nearest layer contribution. C C---------------------------Code history-------------------------------- C C Original version: CCM1 C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C------------------------------Commons---------------------------------- C C Water vapor narrow band constants for longwave radiation computations C common/crdcae/realk(2), st(2), a1(2), a2(2), b1(2), b2(2), $ coefa(3,4),coefb(4,4),coefc(3,4),coefd(4,4), $ coefe(3,4),coeff(6,2),coefg(2,4),coefh(2,4), $ coefi(6,2),coefj(3,2),coefk(3,2), $ c1(4),c2(4),c3(4),c4(4),c5(4),c6(4),c7(4),c8,c9, $ c10,c11,c12,c13,c14,c15,c16,c17,c18,c19,c20,c21, $ c22,c23,c24,c25,c26,c27,c28,c29,c30,c31, $ fwcoef,fwc1,fwc2,fc1,cfa1 C real realk, ! H2O narrow band parameter $ st, ! H2O narrow band parameter $ a1,a2, ! Temperature correction terms for H2O path $ b1,b2 ! Temperature correction terms for H2O path C C Constant coefficients for water vapor absorptivity and emissivity C real coefa,coefb,coefc,coefd,coefe,coeff, $ coefg,coefh,coefi,coefj,coefk, $ c1, c2, c3, c4, c5, c6, c7,c8 ,c9 ,c10, $ c11,c12,c13,c14,c15,c16,c17,c18,c19,c20, $ c21,c22,c23,c24,c25,c26,c27,c28,c29,c30,c31 C C Farwing correction constants for narrow-band emissivity model, C introduced to account for the deficiencies in narrow-band model C used to derive the emissivity; tuned with Arking's line-by-line C calculations. C real fwcoef, $ fwc1,fwc2, $ fc1, $ cfa1 C C----------------------------------------------------------------------- C C Radiation constants C common/crdcon/gravit ,rga ,cpair ,epsilo ,sslp , $ stebol ,rgsslp ,co2vmr ,dpfo3 ,dpfco2 , $ dayspy ,pie C real gravit, ! Acceleration of gravity $ rga, ! 1./gravit $ cpair, ! Specific heat of dry air $ epsilo, ! Ratio of mol. wght of H2O to dry air $ sslp, ! Standard sea-level pressure $ stebol, ! Stefan-Boltzmann's constant $ rgsslp, ! 0.5/(gravit*sslp) $ co2vmr, ! CO2 volume mixing ratio $ dpfo3, ! Voigt correction factor for O3 $ dpfco2, ! Voigt correction factor for CO2 $ dayspy, ! Number of days per 1 year $ pie ! 3.14..... C C------------------------------Arguments-------------------------------- C C Input arguments C real pbr(plond,plev), ! Prssr at mid-levels (dynes/cm2) $ pnm(plond,plevp), ! Prssr at interfaces (dynes/cm2) $ co2em(plond,plevp), ! Co2 emissivity function $ co2eml(plond,plev), ! Co2 emissivity function $ tplnka(plond,plevp), ! Planck fnctn level temperature $ s2c(plond,plevp), ! H2o continuum path length $ s2t(plond,plevp), ! H2o tmp and prs wghted path $ w(plond,plevp), ! H2o prs wghted path $ h2otr(plond,plevp), ! H2o trnsmssn fnct for o3 overlap $ plco2(plond,plevp), ! Co2 prs wghted path length $ plh2o(plond,plevp), ! H2o prs wfhted path length $ co2t(plond,plevp), ! Tmp and prs wghted path length $ tint(plond,plevp), ! Interface temperatures $ tlayr(plond,plevp), ! K-1 level temperatures $ plol(plond,plevp), ! Ozone prs wghted path length $ plos(plond,plevp) ! Ozone path length real pmln(plond,plev), ! Ln(pmidm1) $ piln(plond,plevp) ! Ln(pintm1) C C Output arguments C real abstot(plond,plevp,plevp), ! Total absorptivity $ absnxt(plond,plev,4) ! Total nearest layer absorptivity C C---------------------------Local variables----------------------------- C integer i, ! Longitude index $ k, ! Level index $ k1, ! Level index $ k2, ! Level index $ kn, ! Nearest level index $ iband ! Band index C real pnew(plond), ! Effective pressure for H2O vapor linewidth $ trline(plond,2), ! Transmission due to H2O lines in window $ u(plond), ! Pressure weighted H2O path length $ tbar(plond,4), ! Mean layer temperature $ emm(plond,4), ! Mean co2 emissivity $ o3emm(plond,4), ! Mean o3 emissivity $ o3bndi, ! Ozone band parameter $ temh2o(plond,4), ! Mean layer temperature equivalent to tbar $ k21, ! Exponential coefficient used to calculate C ! rotation band transmissvty in the 650-800 C ! cm-1 region (tr1) $ k22, ! Exponential coefficient used to calculate C ! rotation band transmissvty in the 500-650 C ! cm-1 region (tr2) $ uc1(plond) ! H2o continuum pathlength in 500-800 cm-1 real to3h2o(plond), ! H2o trnsmsn for overlap with o3 $ pi, ! For co2 absorptivity computation $ sqti(plond), ! Used to store sqrt of mean temperature $ et, ! Co2 hot band factor $ et2, ! Co2 hot band factor squared $ et4, ! Co2 hot band factor to fourth power $ omet, ! Co2 stimulated emission term $ f1co2, ! Co2 central band factor $ f2co2(plond), ! Co2 weak band factor $ f3co2(plond), ! Co2 weak band factor $ t1co2(plond), ! Overlap factr weak bands on strong band $ sqwp, ! Sqrt of co2 pathlength $ f1sqwp(plond) ! Main co2 band factor real oneme, ! Co2 stimulated emission term $ alphat, ! Part of the co2 stimulated emission term $ wco2, ! Constants used to define co2 pathlength $ posqt, ! Effective pressure for co2 line width $ u7, ! Co2 hot band path length $ u8, ! Co2 hot band path length $ u9, ! Co2 hot band path length $ u13, ! Co2 hot band path length $ rbeta7, ! Inverse of co2 hot band line width par $ rbeta8, ! Inverse of co2 hot band line width par $ rbeta9, ! Inverse of co2 hot band line width par $ rbeta13 ! Inverse of co2 hot band line width par real tpatha(plond), ! For absorptivity computation $ a, ! Eq(2) in table A3a of R&D $ abso(plond,6), ! Absorptivity for various gases/bands $ dtp(plond), ! Path temp minus 300 K used in h2o C ! rotation band absorptivity $ dtx(plond), ! Planck temperature minus 250 K $ dty(plond), ! Path temperature minus 250 K $ dtz(plond), ! Planck temperature minus 300 K $ term1(plond,4), ! Equation(5) in table A3a of R&D(1986) $ term2(plond,4) ! Delta a(Te) in table A3a of R&D(1986) real term3(plond,4), ! DB/dT function for rotation and C ! vibration-rotation band absorptivity $ term4(plond,4), ! Equation(6) in table A3a of R&D(1986) $ term5(plond,4), ! Delta a(Tp) in table A3a of R&D(1986) $ term6(plond,plevp),! DB/dT function for window region $ term7(plond,2), ! Kl_inf(i) in eq(8) of table A3a of R&D $ term8(plond,2), ! Delta kl_inf(i) in eq(8) $ term9(plond,plevp),! DB/dT function for 500-800 cm-1 region $ tr1, ! Eqn(6) in table A2 of R&D for 650-800 $ tr10(plond), ! Eqn (6) times eq(4) in table A2 C ! of R&D for 500-650 cm-1 region $ tr2 ! Eqn(6) in table A2 of R&D for 500-650 real tr5, ! Eqn(4) in table A2 of R&D for 650-800 $ tr6, ! Eqn(4) in table A2 of R&D for 500-650 $ tr9(plond), ! Equation (6) times eq(4) in table A2 C ! of R&D for 650-800 cm-1 region $ uc(plond) ! Y + 0.002U in eq(8) of table A2 of R&D real sqrtu(plond), ! Sqrt of pressure weighted h20 pathlength $ fwk(plond), ! Equation(33) in R&D far wing correction $ fwku(plond), ! GU term in eqs(1) and (6) in table A2 $ r2st(2), ! 1/(2*beta) in eq(10) in table A2 $ dtyp15(plond), ! DeltaTp in eqs(11) & (12) in table A3a $ dtyp15sq(plond), ! (DeltaTp)^2 in eqs(11) & (12) table A3a $ to3co2(plond), ! P weighted temp in ozone band model $ dpnm(plond), ! Pressure difference between two levels $ pnmsq(plond,plevp),! Pressure squared $ dw(plond), ! Amount of h2o between two levels $ uinpl(plond,4), ! Nearest layer subdivision factor $ winpl(plond,4), ! Nearest layer subdivision factor $ zinpl(plond,4), ! Nearest layer subdivision factor $ pinpl(plond,4), ! Nearest layer subdivision factor $ dplh2o(plond) ! Difference in press weighted h2o amount real r80257, ! Conversion factor for h2o pathlength $ r293, ! 1/293 $ r250, ! 1/250 $ r3205, ! Line width factor for o3 (see R&Di) $ r300, ! 1/300 $ rsslp, ! Reciprocal of sea level pressure $ r2sslp ! 1/2 of rsslp real ds2c, ! Y in eq(7) in table A2 of R&D $ a11, ! A1 in table A3b for rotation band absorptivity $ a31, ! A3 in table A3b for rotation band absorptivity $ a21, ! First part in numerator of A2 in table A3b $ a22, ! Second part in numerator of A2 in table A3b $ a23, ! Denominator of A2 in table A3b (rotation band) $ t1t4, ! Eq(3) in table A3a of R&D $ t2t5, ! Eq(4) in table A3a of R&D $ rsum, ! Eq(1) in table A2 of R&D $ a41, ! Numerator in A2 in Vib-rot abstivity(table A3b) $ a51, ! Denominator in A2 in Vib-rot (table A3b) $ a61 ! A3 factor for Vib-rot band in table A3b real phi, ! Eq(11) in table A3a of R&D $ psi, ! Eq(12) in table A3a of R&D $ cf812, ! Eq(11) in table A2 of R&D $ ubar, ! H2o scaled path see comment for eq(10) table A2 $ pbar, ! H2o scaled pres see comment for eq(10) table A2 $ g4 ! Arguement in exp() in eq(10) table A2 C real dplos, ! Ozone pathlength eq(A2) in R&Di $ dplol, ! Presure weighted ozone pathlength $ tlocal, ! Local interface temperature $ beta, ! Ozone mean line parameter eq(A3) in R&Di C (includes Voigt line correction factor) $ rphat, ! Effective pressure for ozone beta $ tcrfac, ! Ozone temperature factor table 1 R&Di $ tmp1, ! Ozone band factor see eq(A1) in R&Di $ u1, ! Effective ozone pathlength eq(A2) in R&Di $ realnu, ! 1/beta factor in ozone band model eq(A1) $ tmp2, ! Ozone band factor see eq(A1) in R&Di $ u2, ! Effective ozone pathlength eq(A2) in R&Di $ rsqti ! Reciprocal of sqrt of path temperature C real tpath, ! Path temperature used in co2 band model $ tmp3, ! Weak band factor see K&B $ rdpnmsq, ! Reciprocal of difference in press^2 $ rdpnm, ! Reciprocal of difference in press $ p1, ! Mean pressure factor $ p2, ! Mean pressure factor $ dtym10, ! T - 260 used in eq(9) and (10) table A3a $ dplco2, ! Co2 pathlength $ corfac, ! Correction factors in table A3b $ g2, ! Part of arguement in eq(10) in table A2 $ te, ! A_0 T factor in ozone model table 1 of R&Di $ denom ! Denominator in eq(8) of table A3a of R&D C C Transmission terms for various spectral intervals: C real trab1(plond), ! H2o 0 - 800 cm-1 $ trab2(plond), ! H2o 500 - 800 cm-1 $ trab3(plond), ! Co2 band system $ trab4(plond), ! H2o 800 - 1000 cm-1 $ trab5(plond), ! 9.6 micrometer band $ trab6(plond), ! H2o 1000 - 1200 cm-1 $ trab7(plond) ! H2o 1200 - 2200 cm-1 C real bndfct, ! Band absorptance parameter for co2 $ absbnd ! Proportional to co2 band absorptance C real dbvtit(plond,plevp), ! Intrfc drvtv plnck fnctn for o3 $ dbvtly(plond,plev) ! Level drvtv plnck fnctn for o3 C C--------------------------Statement function--------------------------- C real dbvt,t ! Planck fnctn tmp derivative for o3 C dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ $ (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t) C C----------------------------------------------------------------------- C C Initialize C do k=1,plev do i=1,plon dbvtly(i,k) = dbvt(tlayr(i,k+1)) dbvtit(i,k) = dbvt(tint(i,k)) end do end do do i=1,plon dbvtit(i,plevp) = dbvt(tint(i,plevp)) end do C r80257 = 1./8.0257e-04 r293 = 1./293. r250 = 1./250. r3205 = 1./.3205 r300 = 1./300. rsslp = 1./sslp r2sslp = 1./(2.*sslp) r2st(1) = 1./(2.*st(1)) r2st(2) = 1./(2.*st(2)) bndfct = 2.0*22.18/(sqrt(196.)*300.) C C Non-adjacent layer absorptivity: C C abso(i,1) 0 - 800 cm-1 h2o rotation band C abso(i,2) 1200 - 2200 cm-1 h2o vibration-rotation band C abso(i,3) 800 - 1200 cm-1 h2o window C abso(i,4) 500 - 800 cm-1 h2o rotation band overlap with co2 C abso(i,5) o3 9.6 micrometer band (nu3 and nu1 bands) C abso(i,6) co2 15 micrometer band system C do k=1,plevp do i=1,plon pnmsq(i,k) = pnm(i,k)**2 dtx(i) = tplnka(i,k) - 250. term6(i,k) = coeff(1,2) + coeff(2,2)*dtx(i)* $ (1. + c9*dtx(i)*(1. + c11*dtx(i)* $ (1. + c13*dtx(i)*(1. + c15*dtx(i))))) term9(i,k) = coefi(1,2) + coefi(2,2)*dtx(i)* $ (1. + c19*dtx(i)*(1. + c21*dtx(i)* $ (1. + c23*dtx(i)*(1. + c25*dtx(i))))) end do end do C C Non-nearest layer level loops C do 200 k1=plevp,1,-1 do 100 k2=plevp,1,-1 if(k1.eq.k2) go to 100 do i=1,plon dplh2o(i) = plh2o(i,k1) - plh2o(i,k2) u(i) = abs(dplh2o(i)) sqrtu(i) = sqrt(u(i)) ds2c = abs(s2c(i,k1) - s2c(i,k2)) dw(i) = abs(w(i,k1) - w(i,k2)) uc1(i) = (ds2c + 1.7e-3*u(i))*(1. + 2.*ds2c)/ $ (1. + 15.*ds2c) uc(i) = ds2c + 2.e-3*u(i) end do do i=1,plon pnew(i) = u(i)/dw(i) tpatha(i) = (s2t(i,k1) - s2t(i,k2))/dplh2o(i) dtx(i) = tplnka(i,k2) - 250. dty(i) = tpatha(i) - 250. dtyp15(i) = dty(i) + 15. dtyp15sq(i) = dtyp15(i)**2 dtz(i) = dtx(i) - 50. dtp(i) = dty(i) - 50. end do do iband=2,4,2 do i=1,plon term1(i,iband) = coefe(1,iband) + coefe(2,iband)* $ dtx(i)*(1. + c1(iband)*dtx(i)) term2(i,iband) = coefb(1,iband) + coefb(2,iband)* $ dtx(i)*(1. + c2(iband)*dtx(i)* $ (1. + c3(iband)*dtx(i))) term3(i,iband) = coefd(1,iband) + coefd(2,iband)* $ dtx(i)*(1. + c4(iband)*dtx(i)* $ (1. + c5(iband)*dtx(i))) term4(i,iband) = coefa(1,iband) + coefa(2,iband)* $ dty(i)*(1. + c6(iband)*dty(i)) term5(i,iband) = coefc(1,iband) + coefc(2,iband)* $ dty(i)*(1. + c7(iband)*dty(i)) end do end do C C abso(i,1) 0 - 800 cm-1 h2o rotation band C do i=1,plon a11 = 0.44 + 3.380e-4*dtz(i) - 1.520e-6*dtz(i)*dtz(i) a31 = 1.05 - 6.000e-3*dtp(i) + 3.000e-6*dtp(i)*dtp(i) a21 = 1.00 + 1.717e-3*dtz(i) - 1.133e-5*dtz(i)*dtz(i) a22 = 1.00 + 4.443e-3*dtp(i) + 2.750e-5*dtp(i)*dtp(i) a23 = 1.00 + 3.600*sqrtu(i) corfac = a31*(a11 + ((2.*a21*a22)/a23)) t1t4 = term1(i,2)*term4(i,2) t2t5 = term2(i,2)*term5(i,2) a = t1t4 + t2t5/(1. + t2t5*sqrtu(i)*corfac) fwk(i) = fwcoef + fwc1/(1. + fwc2*u(i)) fwku(i) = fwk(i)*u(i) rsum = exp(-a*(sqrtu(i) + fwku(i))) abso(i,1) = (1. - rsum)*term3(i,2) C trab1(i) = rsum end do C C abso(i,2) 1200 - 2200 cm-1 h2o vibration-rotation band C do i=1,plon a41 = 1.75 - 3.960e-03*dtz(i) a51 = 1.00 + 1.3*sqrtu(i) a61 = 1.00 + 1.250e-03*dtp(i) + 6.250e-05*dtp(i)*dtp(i) corfac = .29*(1. + a41/a51)*a61 t1t4 = term1(i,4)*term4(i,4) t2t5 = term2(i,4)*term5(i,4) a = t1t4 + t2t5/(1. + t2t5*sqrtu(i)*corfac) rsum = exp(-a*(sqrtu(i) + fwku(i))) abso(i,2) = (1. - rsum)*term3(i,4) C trab7(i) = rsum end do C C Line transmission in 800-1000 and 1000-1200 cm-1 intervals C do k=1,2 do i=1,plon phi = exp(a1(k)*dtyp15(i) + a2(k)*dtyp15sq(i)) psi = exp(b1(k)*dtyp15(i) + b2(k)*dtyp15sq(i)) ubar = dw(i)*phi*1.66*r80257 pbar = pnew(i)*(psi/phi) cf812 = cfa1 + (1. - cfa1)/(1. + ubar*pbar*10.) g2 = 1. + ubar*4.0*st(k)*cf812/pbar g4 = realk(k)*pbar*r2st(k)*(sqrt(g2) - 1.) trline(i,k) = exp(-g4) end do end do do i=1,plon term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)* $ (1. + c16*dty(i)) term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)* $ (1. + c17*dty(i)) term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)* $ (1. + c26*dty(i)) term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)* $ (1. + c27*dty(i)) end do C C abso(i,3) 800 - 1200 cm-1 h2o window C abso(i,4) 500 - 800 cm-1 h2o rotation band overlap with co2 C do i=1,plon k21 = term7(i,1) + term8(i,1)/ $ (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrtu(i)) k22 = term7(i,2) + term8(i,2)/ $ (1. + (c28 + c29*(dty(i)-10.))*sqrtu(i)) tr1 = exp(-(k21*(sqrtu(i) + fc1*fwku(i)))) tr2 = exp(-(k22*(sqrtu(i) + fc1*fwku(i)))) tr5 = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i))) tr6 = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i))) tr9(i) = tr1*tr5 tr10(i) = tr2*tr6 trab2(i) = 0.65*tr9(i) + 0.35*tr10(i) trab4(i) = exp(-(coefg(1,3) + coefg(2,3)*dtx(i))*uc(i)) trab6(i) = exp(-(coefg(1,4) + coefg(2,4)*dtx(i))*uc(i)) abso(i,3) = term6(i,k2)*(1. - .5*trab4(i)*trline(i,2) - $ .5*trab6(i)*trline(i,1)) abso(i,4) = term9(i,k2)*.5*(tr1 - tr9(i) + tr2 - tr10(i)) end do if(k2.lt.k1) then do i=1,plon to3h2o(i) = h2otr(i,k1)/h2otr(i,k2) end do else do i=1,plon to3h2o(i) = h2otr(i,k2)/h2otr(i,k1) end do end if C C abso(i,5) o3 9.6 micrometer band (nu3 and nu1 bands) C do i=1,plon dpnm(i) = pnm(i,k1) - pnm(i,k2) to3co2(i)=(pnm(i,k1)*co2t(i,k1) - pnm(i,k2)*co2t(i,k2))/ $ dpnm(i) te = (to3co2(i)*r293)**.7 dplos = plos(i,k1) - plos(i,k2) dplol = plol(i,k1) - plol(i,k2) u1 = 18.29*abs(dplos)/te u2 = .5649*abs(dplos)/te rphat = dplol/dplos tlocal = tint(i,k2) tcrfac = sqrt(tlocal*r250)*te beta = r3205*(rphat + dpfo3*tcrfac) realnu = te/beta tmp1 = u1/sqrt(4. + u1*(1. + realnu)) tmp2 = u2/sqrt(4. + u2*(1. + realnu)) o3bndi = 74.*te*alog(1. + tmp1 + tmp2) abso(i,5) = o3bndi*to3h2o(i)*dbvtit(i,k2) C trab5(i) = 1.-(o3bndi/(1060-980.)) end do C C abso(i,6) co2 15 micrometer band system C do i=1,plon sqwp = sqrt(abs(plco2(i,k1) - plco2(i,k2))) et = exp(-480./to3co2(i)) sqti(i) = sqrt(to3co2(i)) rsqti = 1./sqti(i) et2 = et*et et4 = et2*et2 omet = 1. - 1.5*et2 f1co2 = 899.70*omet* $ (1. + 1.94774*et + 4.73486*et2)*rsqti f1sqwp(i) = f1co2*sqwp t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti)) oneme = 1. - et2 alphat = oneme**3*rsqti pi = abs(dpnm(i)) wco2 = 2.5221*co2vmr*pi*rga u7 = 4.9411e4*alphat*et2*wco2 u8 = 3.9744e4*alphat*et4*wco2 u9 = 1.0447e5*alphat*et4*et2*wco2 u13 = 2.8388e3*alphat*et4*wco2 tpath = to3co2(i) tlocal = tint(i,k2) tcrfac = sqrt(tlocal*r250*tpath*r300) posqt = ((pnm(i,k2) + pnm(i,k1))*r2sslp + $ dpfco2*tcrfac)*rsqti rbeta7 = 1./(5.3228*posqt) rbeta8 = 1./(10.6576*posqt) rbeta9 = rbeta7 rbeta13 = rbeta9 f2co2(i) = (u7/sqrt(4. + u7*(1. + rbeta7))) + $ (u8/sqrt(4. + u8*(1. + rbeta8))) + $ (u9/sqrt(4. + u9*(1. + rbeta9))) f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13)) end do if (k2.ge.k1) then do i=1,plon sqti(i) = sqrt(tlayr(i,k2)) end do end if C do i=1,plon tmp1 = alog(1. + f1sqwp(i)) tmp2 = alog(1. + f2co2(i)) tmp3 = alog(1. + f3co2(i)) absbnd = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i) abso(i,6) = trab2(i)*co2em(i,k2)*absbnd C trab3(i) = 1. - bndfct*absbnd end do C C Sum total absorptivity C do i=1,plon abstot(i,k1,k2) = abso(i,1) + abso(i,2) + abso(i,3) + $ abso(i,4) + abso(i,5) + abso(i,6) end do 100 continue 200 continue ! End of non-nearest layer level loops C C Non-adjacent layer absorptivity: C C abso(i,1) 0 - 800 cm-1 h2o rotation band C abso(i,2) 1200 - 2200 cm-1 h2o vibration-rotation band C abso(i,3) 800 - 1200 cm-1 h2o window C abso(i,4) 500 - 800 cm-1 h2o rotation band overlap with co2 C abso(i,5) o3 9.6 micrometer band (nu3 and nu1 bands) C abso(i,6) co2 15 micrometer band system C C Nearest layer level loop C do 500 k2=plev,1,-1 do i=1,plon tbar(i,1) = 0.5*(tint(i,k2+1) + tlayr(i,k2+1)) emm(i,1) = 0.5*(co2em(i,k2+1) + co2eml(i,k2)) tbar(i,2) = 0.5*(tlayr(i,k2+1) + tint(i,k2)) emm(i,2) = 0.5*(co2em(i,k2) + co2eml(i,k2)) tbar(i,3) = 0.5*(tbar(i,2) + tbar(i,1)) emm(i,3) = emm(i,1) tbar(i,4) = tbar(i,3) emm(i,4) = emm(i,2) o3emm(i,1) = 0.5*(dbvtit(i,k2+1) + dbvtly(i,k2)) o3emm(i,2) = 0.5*(dbvtit(i,k2) + dbvtly(i,k2)) o3emm(i,3) = o3emm(i,1) o3emm(i,4) = o3emm(i,2) temh2o(i,1) = tbar(i,1) temh2o(i,2) = tbar(i,2) temh2o(i,3) = tbar(i,1) temh2o(i,4) = tbar(i,2) dpnm(i) = pnm(i,k2+1) - pnm(i,k2) end do do i=1,plon rdpnmsq = 1./(pnmsq(i,k2+1) - pnmsq(i,k2)) rdpnm = 1./dpnm(i) p1 = .5*(pbr(i,k2) + pnm(i,k2+1)) p2 = .5*(pbr(i,k2) + pnm(i,k2 )) uinpl(i,1) = (pnmsq(i,k2+1) - p1**2)*rdpnmsq uinpl(i,2) = -(pnmsq(i,k2 ) - p2**2)*rdpnmsq uinpl(i,3) = -(pnmsq(i,k2 ) - p1**2)*rdpnmsq uinpl(i,4) = (pnmsq(i,k2+1) - p2**2)*rdpnmsq winpl(i,1) = (.5*( pnm(i,k2+1) - pbr(i,k2)))*rdpnm winpl(i,2) = (.5*(-pnm(i,k2 ) + pbr(i,k2)))*rdpnm winpl(i,3) = (.5*( pnm(i,k2+1) + pbr(i,k2)) - pnm(i,k2 ))* $ rdpnm winpl(i,4) = (.5*(-pnm(i,k2 ) - pbr(i,k2)) + pnm(i,k2+1))* $ rdpnm tmp1 = 1./(piln(i,k2+1) - piln(i,k2)) tmp2 = piln(i,k2+1) - pmln(i,k2) tmp3 = piln(i,k2 ) - pmln(i,k2) zinpl(i,1) = (.5*tmp2 )*tmp1 zinpl(i,2) = ( - .5*tmp3)*tmp1 zinpl(i,3) = (.5*tmp2 - tmp3)*tmp1 zinpl(i,4) = ( tmp2 - .5*tmp3)*tmp1 pinpl(i,1) = 0.5*(p1 + pnm(i,k2+1)) pinpl(i,2) = 0.5*(p2 + pnm(i,k2 )) pinpl(i,3) = 0.5*(p1 + pnm(i,k2 )) pinpl(i,4) = 0.5*(p2 + pnm(i,k2+1)) end do do 400 kn=1,4 do i=1,plon u(i) = uinpl(i,kn)*abs(plh2o(i,k2) - plh2o(i,k2+1)) sqrtu(i) = sqrt(u(i)) dw(i) = abs(w(i,k2) - w(i,k2+1)) pnew(i) = u(i)/(winpl(i,kn)*dw(i)) ds2c = abs(s2c(i,k2) - s2c(i,k2+1)) uc1(i) = uinpl(i,kn)*ds2c uc1(i) = (uc1(i) + 1.7e-3*u(i))*(1. + 2.*uc1(i))/ $ (1. + 15.*uc1(i)) uc(i) = uinpl(i,kn)*ds2c + 2.e-3*u(i) end do do i=1,plon dtx(i) = temh2o(i,kn) - 250. dty(i) = tbar(i,kn) - 250. dtyp15(i) = dty(i) + 15. dtyp15sq(i) = dtyp15(i)**2 dtz(i) = dtx(i) - 50. dtp(i) = dty(i) - 50. end do do iband=2,4,2 do i=1,plon term1(i,iband) = coefe(1,iband) + coefe(2,iband)* $ dtx(i)*(1. + c1(iband)*dtx(i)) term2(i,iband) = coefb(1,iband) + coefb(2,iband)* $ dtx(i)*(1. + c2(iband)*dtx(i)* $ (1. + c3(iband)*dtx(i))) term3(i,iband) = coefd(1,iband) + coefd(2,iband)* $ dtx(i)*(1. + c4(iband)*dtx(i)* $ (1. + c5(iband)*dtx(i))) term4(i,iband) = coefa(1,iband) + coefa(2,iband)* $ dty(i)*(1. + c6(iband)*dty(i)) term5(i,iband) = coefc(1,iband) + coefc(2,iband)* $ dty(i)*(1. + c7(iband)*dty(i)) end do end do C C abso(i,1) 0 - 800 cm-1 h2o rotation band C do i=1,plon a11 = 0.44 + 3.380e-4*dtz(i) - 1.520e-6*dtz(i)*dtz(i) a31 = 1.05 - 6.000e-3*dtp(i) + 3.000e-6*dtp(i)*dtp(i) a21 = 1.00 + 1.717e-3*dtz(i) - 1.133e-5*dtz(i)*dtz(i) a22 = 1.00 + 4.443e-3*dtp(i) + 2.750e-5*dtp(i)*dtp(i) a23 = 1.00 + 3.600*sqrtu(i) corfac = a31*(a11 + ((2.*a21*a22)/a23)) t1t4 = term1(i,2)*term4(i,2) t2t5 = term2(i,2)*term5(i,2) a = t1t4 + t2t5/(1. + t2t5*sqrtu(i)*corfac) fwk(i) = fwcoef + fwc1/(1. + fwc2*u(i)) fwku(i) = fwk(i)*u(i) rsum = exp(-a*(sqrtu(i) + fwku(i))) abso(i,1) = (1. - rsum)*term3(i,2) C trab1(i) = rsum end do C C abso(i,2) 1200 - 2200 cm-1 h2o vibration-rotation band C do i=1,plon a41 = 1.75 - 3.960e-03*dtz(i) a51 = 1.00 + 1.3*sqrtu(i) a61 = 1.00 + 1.250e-03*dtp(i) + 6.250e-05*dtp(i)*dtp(i) corfac = .29*(1. + a41/a51)*a61 t1t4 = term1(i,4)*term4(i,4) t2t5 = term2(i,4)*term5(i,4) a = t1t4 + t2t5/(1. + t2t5*sqrtu(i)*corfac) rsum = exp(-a*(sqrtu(i) + fwku(i))) abso(i,2) = (1. - rsum)*term3(i,4) C trab7(i) = rsum end do C C Line transmission in 800-1000 and 1000-1200 cm-1 intervals C do k=1,2 do i=1,plon phi = exp(a1(k)*dtyp15(i) + a2(k)*dtyp15sq(i)) psi = exp(b1(k)*dtyp15(i) + b2(k)*dtyp15sq(i)) ubar = dw(i)*phi*winpl(i,kn)*1.66*r80257 pbar = pnew(i)*(psi/phi) cf812 = cfa1 + (1. - cfa1)/(1. + ubar*pbar*10.) g2 = 1. + ubar*4.0*st(k)*cf812/pbar g4 = realk(k)*pbar*r2st(k)*(sqrt(g2) - 1.) trline(i,k) = exp(-g4) end do end do do i=1,plon term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)* $ (1. + c16*dty(i)) term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)* $ (1. + c17*dty(i)) term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)* $ (1. + c26*dty(i)) term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)* $ (1. + c27*dty(i)) end do C C abso(i,3) 800 - 1200 cm-1 h2o window C abso(i,4) 500 - 800 cm-1 h2o rotation band overlap with co2 C do i=1,plon dtym10 = dty(i) - 10. denom = 1. + (c30 + c31*dtym10*dtym10)*sqrtu(i) k21 = term7(i,1) + term8(i,1)/denom denom = 1. + (c28 + c29*dtym10 )*sqrtu(i) k22 = term7(i,2) + term8(i,2)/denom term9(i,2) = coefi(1,2) + coefi(2,2)*dtx(i)* $ (1. + c19*dtx(i)*(1. + c21*dtx(i)* $ (1. + c23*dtx(i)*(1. + c25*dtx(i))))) tr1 = exp(-(k21*(sqrtu(i) + fc1*fwku(i)))) tr2 = exp(-(k22*(sqrtu(i) + fc1*fwku(i)))) tr5 = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i))) tr6 = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i))) tr9(i) = tr1*tr5 tr10(i) = tr2*tr6 trab2(i)= 0.65*tr9(i) + 0.35*tr10(i) trab4(i)= exp(-(coefg(1,3) + coefg(2,3)*dtx(i))*uc(i)) trab6(i)= exp(-(coefg(1,4) + coefg(2,4)*dtx(i))*uc(i)) term6(i,2) = coeff(1,2) + coeff(2,2)*dtx(i)* $ (1. + c9*dtx(i)*(1. + c11*dtx(i)* $ (1. + c13*dtx(i)*(1. + c15*dtx(i))))) abso(i,3) = term6(i,2)*(1. - .5*trab4(i)*trline(i,2) - $ .5*trab6(i)*trline(i,1)) abso(i,4) = term9(i,2)*.5*(tr1 - tr9(i) + tr2 - tr10(i)) end do C C abso(i,5) o3 9.6 micrometer (nu3 and nu1 bands) C do i=1,plon te = (tbar(i,kn)*r293)**.7 dplos = abs(plos(i,k2+1) - plos(i,k2)) u1 = zinpl(i,kn)*18.29*dplos/te u2 = zinpl(i,kn)*.5649*dplos/te tlocal = tbar(i,kn) tcrfac = sqrt(tlocal*r250)*te beta = r3205*(pinpl(i,kn)*rsslp + dpfo3*tcrfac) realnu = te/beta tmp1 = u1/sqrt(4. + u1*(1. + realnu)) tmp2 = u2/sqrt(4. + u2*(1. + realnu)) o3bndi = 74.*te*alog(1. + tmp1 + tmp2) abso(i,5) = o3bndi*o3emm(i,kn)* $ (h2otr(i,k2+1)/h2otr(i,k2)) C trab5(i) = 1.-(o3bndi/(1060-980.)) end do C C abso(i,6) co2 15 micrometer band system C do 300 i=1,plon dplco2 = plco2(i,k2+1) - plco2(i,k2) sqwp = sqrt(uinpl(i,kn)*dplco2) et = exp(-480./tbar(i,kn)) sqti(i) = sqrt(tbar(i,kn)) rsqti = 1./sqti(i) et2 = et*et et4 = et2*et2 omet = (1. - 1.5*et2) f1co2 = 899.70*omet* $ (1. + 1.94774*et + 4.73486*et2)*rsqti f1sqwp(i)= f1co2*sqwp t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti)) oneme = 1. - et2 alphat = oneme**3*rsqti pi = abs(dpnm(i))*winpl(i,kn) wco2 = 2.5221*co2vmr*pi*rga u7 = 4.9411e4*alphat*et2*wco2 u8 = 3.9744e4*alphat*et4*wco2 u9 = 1.0447e5*alphat*et4*et2*wco2 u13 = 2.8388e3*alphat*et4*wco2 tpath = tbar(i,kn) tlocal = tbar(i,kn) tcrfac = sqrt((tlocal*r250)*(tpath*r300)) posqt = (pinpl(i,kn)*rsslp + dpfco2*tcrfac)*rsqti rbeta7 = 1./(5.3228*posqt) rbeta8 = 1./(10.6576*posqt) rbeta9 = rbeta7 rbeta13 = rbeta9 f2co2(i) = u7/sqrt(4. + u7*(1. + rbeta7)) + $ u8/sqrt(4. + u8*(1. + rbeta8)) + $ u9/sqrt(4. + u9*(1. + rbeta9)) f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13)) tmp1 = alog(1. + f1sqwp(i)) tmp2 = alog(1. + f2co2(i)) tmp3 = alog(1. + f3co2(i)) absbnd = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i) abso(i,6)= trab2(i)*emm(i,kn)*absbnd C trab3(i) = 1. - bndfct*absbnd 300 continue C C Total next layer absorptivity: C do i=1,plon absnxt(i,k2,kn) = abso(i,1) + abso(i,2) + abso(i,3) + $ abso(i,4) + abso(i,5) + abso(i,6) end do 400 continue 500 continue ! end of nearest layer level loop C return end subroutine radems(s2c ,s2t ,w ,tplnke ,plh2o , $ pnm ,plco2 ,tint ,tint4 ,tlayr , $ tlayr4 ,plol ,plos ,co2em ,co2eml , $ co2t ,h2otr ,emstot ) C----------------------------------------------------------------------- C C Compute emissivity for H2O, CO2, O3 C C H2O .... Uses nonisothermal emissivity for water vapor from C Ramanathan, V. and P.Downey, 1986: A Nonisothermal C Emissivity and Absorptivity Formulation for Water Vapor C Jouranl of Geophysical Research, vol. 91., D8, pp 8649-8666 C C C CO2 .... Uses absorptance parameterization of the 15 micro-meter C (500 - 800 cm-1) band system of Carbon Dioxide, from C Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization C of the Absorptance Due to the 15 micro-meter Band System C of Carbon Dioxide Jouranl of Geophysical Research, C vol. 96., D5, pp 9013-9019 C C O3 .... Uses absorptance parameterization of the 9.6 micro-meter C band system of ozone, from Ramanathan, V. and R. Dickinson, C 1979: The Role of stratospheric ozone in the zonal and C seasonal radiative energy balance of the earth-troposphere C system. Journal of the Atmospheric Sciences, Vol. 36, C pp 1084-1104 C C Computes individual emissivities, accounting for band overlap, and C sums to obtain the total. C C---------------------------Code history-------------------------------- C C Original version: CCM1 C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C------------------------------Commons---------------------------------- C C Water vapor narrow band constants for longwave radiation computations C common/crdcae/realk(2), st(2), a1(2), a2(2), b1(2), b2(2), $ coefa(3,4),coefb(4,4),coefc(3,4),coefd(4,4), $ coefe(3,4),coeff(6,2),coefg(2,4),coefh(2,4), $ coefi(6,2),coefj(3,2),coefk(3,2), $ c1(4),c2(4),c3(4),c4(4),c5(4),c6(4),c7(4),c8,c9, $ c10,c11,c12,c13,c14,c15,c16,c17,c18,c19,c20,c21, $ c22,c23,c24,c25,c26,c27,c28,c29,c30,c31, $ fwcoef,fwc1,fwc2,fc1,cfa1 C real realk, ! H2O narrow band parameter $ st, ! H2O narrow band parameter $ a1,a2, ! Temperature correction terms for H2O path $ b1,b2 ! Temperature correction terms for H2O path C C Constant coefficients for water vapor absorptivity and emissivity C real coefa,coefb,coefc,coefd,coefe,coeff, $ coefg,coefh,coefi,coefj,coefk, $ c1, c2, c3, c4, c5, c6, c7,c8 ,c9 ,c10, $ c11,c12,c13,c14,c15,c16,c17,c18,c19,c20, $ c21,c22,c23,c24,c25,c26,c27,c28,c29,c30,c31 C C Farwing correction constants for narrow-band emissivity model, C introduced to account for the deficiencies in narrow-band model C used to derive the emissivity; tuned with Arking's line-by-line C calculations. C real fwcoef, $ fwc1,fwc2, $ fc1, $ cfa1 C C----------------------------------------------------------------------- C C Radiation constants C common/crdcon/gravit ,rga ,cpair ,epsilo ,sslp , $ stebol ,rgsslp ,co2vmr ,dpfo3 ,dpfco2 , $ dayspy ,pie C real gravit, ! Acceleration of gravity $ rga, ! 1./gravit $ cpair, ! Specific heat of dry air $ epsilo, ! Ratio of mol. wght of H2O to dry air $ sslp, ! Standard sea-level pressure $ stebol, ! Stefan-Boltzmann's constant $ rgsslp, ! 0.5/(gravit*sslp) $ co2vmr, ! CO2 volume mixing ratio $ dpfo3, ! Voigt correction factor for O3 $ dpfco2, ! Voigt correction factor for CO2 $ dayspy, ! Number of days per 1 year $ pie ! 3.14..... C C------------------------------Arguments-------------------------------- C C Input arguments C real s2c(plond,plevp), ! H2o continuum path length $ s2t(plond,plevp), ! Tmp and prs wghted h2o path length $ w(plond,plevp), ! H2o path length $ tplnke(plond), ! Layer planck temperature $ plh2o(plond,plevp), ! H2o prs wghted path length $ pnm(plond,plevp), ! Model interface pressure $ plco2(plond,plevp), ! Prs wghted path of co2 $ tint(plond,plevp), ! Model interface temperatures $ tint4(plond,plevp), ! Tint to the 4th power $ tlayr(plond,plevp), ! K-1 model layer temperature $ tlayr4(plond,plevp), ! Tlayr to the 4th power $ plol(plond,plevp), ! Pressure wghtd ozone path $ plos(plond,plevp) ! Ozone path C C Output arguments C real emstot(plond,plevp), ! Total emissivity $ co2em(plond,plevp), ! Layer co2 normalzd plnck funct drvtv $ co2eml(plond,plev), ! Intrfc co2 normalzd plnck func drvtv $ co2t(plond,plevp), ! Tmp and prs weighted path length $ h2otr(plond,plevp) ! H2o transmission over o3 band C C---------------------------Local variables----------------------------- C integer $ i, ! Longitude index $ k, ! Level index] $ k1, ! Level index $ iband ! H2o band index C C Local variables for H2O: C real h2oems(plond,plevp),! H2o emissivity $ tpathe(plond), ! Used to compute h2o emissivity $ a(plond), ! Eq(2) in table A3a of R&D $ corfac(plond), ! Correction factors in table A3b $ dtp(plond), ! Path temperature minus 300 K used in C h2o rotation band absorptivity $ dtx(plond), ! Planck temperature minus 250 K $ dty(plond), ! Path temperature minus 250 K $ dtz(plond), ! Planck temperature minus 300 K $ emis(plond,4), ! Total emissivity (h2o+co2+o3) $ rsum(plond), ! Eq(1) in table A2 of R&D $ term1(plond,4), ! Equation(5) in table A3a of R&D(1986) $ term2(plond,4) ! Delta a(Te) in table A3a of R&D(1986) real term3(plond,4), ! B(T) function for rotation and C vibration-rotation band emissivity $ term4(plond,4), ! Equation(6) in table A3a of R&D(1986) $ term5(plond,4), ! Delta a(Tp) in table A3a of R&D(1986) $ term6(plond,2), ! B(T) function for window region $ term7(plond,2), ! Kl_inf(i) in eq(8) of table A3a of R&D $ term8(plond,2), ! Delta kl_inf(i) in eq(8) $ term9(plond,2), ! B(T) function for 500-800 cm-1 region $ tr1(plond), ! Equation(6) in table A2 for 650-800 $ tr2(plond), ! Equation(6) in table A2 for 500-650 $ tr3(plond) ! Equation(4) in table A2 for 650-800 real tr4(plond), ! Equation(4),table A2 of R&D for 500-650 $ tr7(plond), ! Equation (6) times eq(4) in table A2 C ! of R&D for 650-800 cm-1 region $ tr8(plond), ! Equation (6) times eq(4) in table A2 C ! of R&D for 500-650 cm-1 region $ uc(plond), ! Y + 0.002U in eq(8) of table A2 of R&D $ pnew(plond), ! Effective pressure for h2o linewidth $ trline(plond,2), ! Transmission due to H2O lines in window $ k21(plond), ! Exponential coefficient used to calc C ! rot band transmissivity in the 650-800 C ! cm-1 region (tr1) $ k22(plond), ! Exponential coefficient used to calc C ! rot band transmissivity in the 500-650 C ! cm-1 region (tr2) $ u(plond), ! Pressure weighted H2O path length $ uc1(plond), ! H2o continuum pathlength 500-800 cm-1 $ r80257 ! Conversion factor for h2o pathlength real a11, ! A1 in table A3b for rotation band emiss $ a31, ! A3 in table A3b for rotation band emiss $ a21, ! First part in numerator of A2 table A3b $ a22, ! Second part in numertor of A2 table A3b $ a23, ! Denominator of A2 table A3b (rot band) $ t1t4, ! Eq(3) in table A3a of R&D $ t2t5, ! Eq(4) in table A3a of R&D $ fwk, ! Equation(33) in R&D far wing correction $ a41, ! Numerator in A2 in Vib-rot (table A3b) $ a51, ! Denominator in A2 in Vib-rot(table A3b) $ a61, ! A3 factor for Vib-rot band in table A3b $ phi, ! Eq(11) in table A3a of R&D $ psi, ! Eq(12) in table A3a of R&D $ ubar, ! H2o scaled path comment eq(10) table A2 $ g1, ! Part of eq(10) table A2 $ pbar, ! H2o scaled pres comment eq(10) table A2 $ g3, ! Part of eq(10) table A2 $ g2, ! Part of arguement in eq(10) in table A2 $ g4, ! Arguement in exp() in eq(10) table A2 $ cf812 ! Eq(11) in table A2 of R&D real troco2(plond,plevp) ! H2o overlap factor for co2 absorption C C Local variables for CO2: C real co2ems(plond,plevp), ! Co2 emissivity $ co2plk(plond), ! Used to compute co2 emissivity $ sum(plond), ! Used to calculate path temperature $ t1i, ! Co2 hot band temperature factor $ sqti, ! Sqrt of temperature $ pi, ! Pressure used in co2 mean line width $ et, ! Co2 hot band factor $ et2, ! Co2 hot band factor $ et4, ! Co2 hot band factor $ omet, ! Co2 stimulated emission term $ ex ! Part of co2 planck function real f1co2, ! Co2 weak band factor $ f2co2, ! Co2 weak band factor $ f3co2, ! Co2 weak band factor $ t1co2, ! Overlap factor weak bands strong band $ sqwp, ! Sqrt of co2 pathlength $ f1sqwp, ! Main co2 band factor $ oneme, ! Co2 stimulated emission term $ alphat, ! Part of the co2 stimulated emiss term $ wco2, ! Consts used to define co2 pathlength $ posqt, ! Effective pressure for co2 line width $ rbeta7, ! Inverse of co2 hot band line width par $ rbeta8, ! Inverse of co2 hot band line width par $ rbeta9, ! Inverse of co2 hot band line width par $ rbeta13 ! Inverse of co2 hot band line width par real tpath, ! Path temp used in co2 band model $ tmp1, ! Co2 band factor $ tmp2, ! Co2 band factor $ tmp3, ! Co2 band factor $ tlayr5, ! Temperature factor in co2 Planck func $ rsqti, ! Reciprocal of sqrt of temperature $ exm1sq ! Part of co2 Planck function real u7, ! Absorber amount for various co2 band systems $ u8, ! Absorber amount for various co2 band systems $ u9, ! Absorber amount for various co2 band systems $ u13 ! Absorber amount for various co2 band systems real r250, ! Inverse 250K $ r300, ! Inverse 300K $ rsslp ! Inverse standard sea-level pressure C C Local variables for O3: C real o3ems(plond,plevp), ! Ozone emissivity $ dbvtt(plond), ! Tmp drvtv of planck fctn for tplnke $ te, ! Temperature factor $ u1, ! Path length factor $ u2, ! Path length factor $ phat, ! Effecitive path length pressure $ tlocal, ! Local planck function temperature $ tcrfac, ! Scaled temperature factor $ beta, ! Absorption funct factor voigt effect $ realnu, ! Absorption function factor $ o3bndi ! Band absorption factor C C Transmission terms for various spectral intervals: C real trem1(plond), ! H2o 0 - 800 cm-1 $ trem2(plond), ! H2o 500 - 800 cm-1 $ trem3(plond), ! Co2 500 - 800 cm-1 $ trem4(plond), ! H2o 800 - 1000 cm-1 $ trem5(plond), ! O3 9.6 micro-meter band $ trem6(plond), ! H2o 1000 - 1200 cm-1 $ trem7(plond) ! H2o 1200 - 2200 cm-1 real bndfct, ! Band absorptance parameter for co2 $ absbnd ! Proportional to co2 band absorptance C C---------------------------Statement functions------------------------- C C Statement functions C Derivative of planck function at 9.6 micro-meter wavelength, and C an absorption function factor: C real dbvt,fo3,t,ux,vx C dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ $ (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t) C fo3(ux,vx)=ux/sqrt(4.+ux*(1.+vx)) C C----------------------------------------------------------------------- C C Initialize C r80257 = 1./8.0257e-04 C r250 = 1./250. r300 = 1./300. rsslp = 1./sslp C C Planck function for co2 C do i=1,plon ex = exp(960./tplnke(i)) co2plk(i) = 5.e8/((tplnke(i)**4)*(ex - 1.)) co2t(i,1) = tplnke(i) sum(i) = co2t(i,1)*pnm(i,1) end do k = 1 do k1=plevp,2,-1 k = k + 1 do i=1,plon sum(i) = sum(i) + tlayr(i,k)*(pnm(i,k)-pnm(i,k-1)) ex = exp(960./tlayr(i,k1)) tlayr5 = tlayr(i,k1)*tlayr4(i,k1) co2eml(i,k1-1) = 1.2e11*ex/(tlayr5*(ex - 1.)**2) co2t(i,k) = sum(i)/pnm(i,k) end do end do bndfct = 2.0*22.18/(sqrt(196.)*300.) C C Initialize planck function derivative for O3 C do i=1,plon dbvtt(i) = dbvt(tplnke(i)) end do C C Interface loop C do 200 k1=1,plevp C C H2O emissivity C C emis(i,1) 0 - 800 cm-1 rotation band C emis(i,2) 1200 - 2200 cm-1 vibration-rotation band C emis(i,3) 800 - 1200 cm-1 window C emis(i,4) 500 - 800 cm-1 rotation band overlap with co2 C C For the p type continuum C do i=1,plon uc(i) = s2c(i,k1) + 2.e-3*plh2o(i,k1) u(i) = plh2o(i,k1) pnew(i) = u(i)/w(i,k1) C C Apply scaling factor for 500-800 continuum C uc1(i) = (s2c(i,k1) + 1.7e-3*plh2o(i,k1))* $ (1. + 2.*s2c(i,k1))/(1. + 15.*s2c(i,k1)) tpathe(i) = s2t(i,k1)/plh2o(i,k1) end do do i=1,plon dtx(i) = tplnke(i) - 250. dty(i) = tpathe(i) - 250. dtz(i) = dtx(i) - 50. dtp(i) = dty(i) - 50. end do do iband=1,3,2 do i=1,plon term1(i,iband) = coefe(1,iband) + coefe(2,iband)* $ dtx(i)*(1. + c1(iband)*dtx(i)) term2(i,iband) = coefb(1,iband) + coefb(2,iband)* $ dtx(i)*(1. + c2(iband)*dtx(i)* $ (1. + c3(iband)*dtx(i))) term3(i,iband) = coefd(1,iband) + coefd(2,iband)* $ dtx(i)*(1. + c4(iband)*dtx(i)* $ (1. + c5(iband)*dtx(i))) term4(i,iband) = coefa(1,iband) + coefa(2,iband)* $ dty(i)*(1. + c6(iband)*dty(i)) term5(i,iband) = coefc(1,iband) + coefc(2,iband)* $ dty(i)*(1. + c7(iband)*dty(i)) end do end do C C emis(i,1) 0 - 800 cm-1 rotation band C do i=1,plon a11 = .37 - 3.33e-5*dtz(i) + 3.33e-6*dtz(i)*dtz(i) a31 = 1.07 - 1.00e-3*dtp(i) + 1.475e-5*dtp(i)*dtp(i) a21 = 1.3870 + 3.80e-3*dtz(i) - 7.8e-6*dtz(i)*dtz(i) a22 = 1.0 - 1.21e-3*dtp(i) - 5.33e-6*dtp(i)*dtp(i) a23 = 0.9 + 2.62*sqrt(u(i)) corfac(i) = a31*(a11 + ((a21*a22)/a23)) t1t4 = term1(i,1)*term4(i,1) t2t5 = term2(i,1)*term5(i,1) a(i) = t1t4 + t2t5/(1. + t2t5*sqrt(u(i))*corfac(i)) fwk = fwcoef + fwc1/(1. + fwc2*u(i)) rsum(i) = exp(-a(i)*(sqrt(u(i)) + fwk*u(i))) emis(i,1) = (1. - rsum(i))*term3(i,1) C trem1(i) = rsum(i) C C emis(i,2) 1200 - 2200 cm-1 vibration-rotation band C a41 = 1.75 - 3.96e-3*dtz(i) a51 = 1.00 + 1.3*sqrt(u(i)) a61 = 1.00 + 1.25e-3*dtp(i) + 6.25e-5*dtp(i)*dtp(i) corfac(i)= .3*(1. + (a41)/(a51))*a61 t1t4 = term1(i,3)*term4(i,3) t2t5 = term2(i,3)*term5(i,3) a(i) = t1t4 + t2t5/(1. + t2t5*sqrt(u(i))*corfac(i)) fwk = fwcoef + fwc1/(1. + fwc2*u(i)) rsum(i) = exp(-a(i)*(sqrt(u(i)) + fwk*u(i))) emis(i,2)= (1. - rsum(i))*term3(i,3) C trem7(i) = rsum(i) end do C C Line transmission in 800-1000 and 1000-1200 cm-1 intervals C do k=1,2 do i=1,plon phi = a1(k)*(dty(i) + 15.) + a2(k)*(dty(i) + 15.)**2 psi = b1(k)*(dty(i) + 15.) + b2(k)*(dty(i) + 15.)**2 phi = exp(phi) psi = exp(psi) ubar = w(i,k1)*phi ubar = (ubar*1.66)*r80257 pbar = pnew(i)*(psi/phi) cf812 = cfa1 + ((1.-cfa1)/(1. + ubar*pbar*10.)) g1 = (realk(k)*pbar)/(2.*st(k)) g2 = 1. + (ubar*4.0*st(k)*cf812)/pbar g3 = sqrt(g2) - 1. g4 = g1*g3 trline(i,k) = exp(-g4) end do end do do i=1,plon term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1.+c16*dty(i)) term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1.+c17*dty(i)) term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1.+c26*dty(i)) term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1.+c27*dty(i)) end do C C emis(i,3) 800 - 1200 cm-1 window C do i=1,plon term6(i,1) = coeff(1,1) + coeff(2,1)*dtx(i)* $ (1. + c8*dtx(i)*(1. + c10*dtx(i)* $ (1. + c12*dtx(i)*(1. + c14*dtx(i))))) trem4(i) = exp(-(coefg(1,1)+coefg(2,1)*dtx(i))*uc(i)) $ *trline(i,2) trem6(i) = exp(-(coefg(1,2)+coefg(2,2)*dtx(i))*uc(i)) $ *trline(i,1) emis(i,3) = term6(i,1)*(1. - .5*trem4(i) -.5*trem6(i)) C C emis(i,4) 500 - 800 cm-1 rotation band overlap with co2 C k21(i) = term7(i,1) + term8(i,1)/ $ (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrt(u(i))) k22(i) = term7(i,2) + term8(i,2)/ $ (1. + (c28 + c29*(dty(i)-10.))*sqrt(u(i))) term9(i,1) = coefi(1,1) + coefi(2,1)*dtx(i)* $ (1. + c18*dtx(i)*(1. + c20*dtx(i)* $ (1. + c22*dtx(i)*(1. + c24*dtx(i))))) fwk = fwcoef + fwc1/(1.+fwc2*u(i)) tr1(i) = exp(-(k21(i)*(sqrt(u(i)) + fc1*fwk*u(i)))) tr2(i) = exp(-(k22(i)*(sqrt(u(i)) + fc1*fwk*u(i)))) tr3(i) = exp(-((coefh(1,1) + coefh(2,1)*dtx(i))*uc1(i))) tr4(i) = exp(-((coefh(1,2) + coefh(2,2)*dtx(i))*uc1(i))) tr7(i) = tr1(i)*tr3(i) tr8(i) = tr2(i)*tr4(i) emis(i,4) = term9(i,1)*.5*(tr1(i)-tr7(i) + tr2(i)-tr8(i)) h2oems(i,k1) = emis(i,1)+emis(i,2)+emis(i,3)+emis(i,4) troco2(i,k1) = 0.65*tr7(i) + 0.35*tr8(i) C trem2(i) = troco2(i,k1) end do C C CO2 emissivity for 15 micron band system C do 100 i=1,plon t1i = exp(-480./co2t(i,k1)) sqti = sqrt(co2t(i,k1)) rsqti = 1./sqti et = t1i et2 = et*et et4 = et2*et2 omet = 1. - 1.5*et2 f1co2 = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti sqwp = sqrt(plco2(i,k1)) f1sqwp = f1co2*sqwp t1co2 = 1./(1. + 245.18*omet*sqwp*rsqti) oneme = 1. - et2 alphat = oneme**3*rsqti wco2 = 2.5221*co2vmr*pnm(i,k1)*rga u7 = 4.9411e4*alphat*et2*wco2 u8 = 3.9744e4*alphat*et4*wco2 u9 = 1.0447e5*alphat*et4*et2*wco2 u13 = 2.8388e3*alphat*et4*wco2 C tpath = co2t(i,k1) tlocal = tplnke(i) tcrfac = sqrt((tlocal*r250)*(tpath*r300)) pi = pnm(i,k1)*rsslp + 2.*dpfco2*tcrfac posqt = pi/(2.*sqti) rbeta7 = 1./( 5.3288*posqt) rbeta8 = 1./ (10.6576*posqt) rbeta9 = rbeta7 rbeta13= rbeta9 f2co2 = (u7/sqrt(4. + u7*(1. + rbeta7))) + $ (u8/sqrt(4. + u8*(1. + rbeta8))) + $ (u9/sqrt(4. + u9*(1. + rbeta9))) f3co2 = u13/sqrt(4. + u13*(1. + rbeta13)) tmp1 = alog(1. + f1sqwp) tmp2 = alog(1. + f2co2) tmp3 = alog(1. + f3co2) absbnd = (tmp1 + 2.*t1co2*tmp2 + 2.*tmp3)*sqti co2ems(i,k1) = troco2(i,k1)*absbnd*co2plk(i) ex = exp(960./tint(i,k1)) exm1sq = (ex - 1.)**2 co2em(i,k1) = 1.2e11*ex/(tint(i,k1)*tint4(i,k1)*exm1sq) C trem3(i) = 1. - bndfct*absbnd 100 continue C C O3 emissivity C do i=1,plon h2otr(i,k1) = exp(-12.*s2c(i,k1)) te = (co2t(i,k1)/293.)**.7 u1 = 18.29*plos(i,k1)/te u2 = .5649*plos(i,k1)/te phat = plos(i,k1)/plol(i,k1) tlocal = tplnke(i) tcrfac = sqrt(tlocal*r250)*te beta = (1./.3205)*((1./phat) + (dpfo3*tcrfac)) realnu = (1./beta)*te o3bndi = 74.*te*(tplnke(i)/375.)* $ alog(1. + fo3(u1,realnu) + fo3(u2,realnu)) o3ems(i,k1) = dbvtt(i)*h2otr(i,k1)*o3bndi C trem5(i) = 1.-(o3bndi/(1060-980.)) end do C C Total emissivity: C do i=1,plon emstot(i,k1) = h2oems(i,k1) + co2ems(i,k1) + o3ems(i,k1) end do 200 continue ! End of interface loop C return end subroutine radalb(lat ,ioro ,sndpth ,coszrs ,albs , $ albl ,albsd ,albld ) C----------------------------------------------------------------------- C C Compute surface albedos C C Computes surface albedos for direct/diffuse incident radiation for C two spectral intervals: C s = 0.2-0.7 micro-meters C l = 0.7-5.0 micro-meters C C Uses knowledge of surface type to specify albedo, as follows: C C Ocean Uses solar zenith angle to compute albedo for direct C radiation; diffuse radiation values constant; albedo C independent of spectral interval and other physical C factors such as ocean surface wind speed. C C Land without Albedos specified by two dimensional surface albedo C snow fields, which distinguish surfaces with strong solar C zenith angle dependence from those with weaker solar C zenith angle dependence; alb independent of surface C moisture or other physical factors. C C Land with snow Snow depth (liquid water equivalent) used, along with C aerodynamic roughness to define a horizontal fraction C of land surface covered with snow; snow albedos are C comptd as functions of solar zenith angle; these snow C albedos are then weighted by the horizontal fraction C of coverage with the underlying surface albedos C computed above to produce total grid mean albedo. C C land with ice Surface albedos specified as functions of spectral C interval; combined with overlying snow in a similar C manner to the case of land with snow. C C Ocean with Surface albs specified; combined with overlying snow C sea ice in a similar manner to the case of land with snow. C C Note, the code collects together surfaces of the same type for various C computations in order to vectorize longitude loops. C C For more details , see Briegleb, Bruce P., 1992: Delta-Eddington C Approximation for Solar Radiation in the NCAR Community Climate Model, C Journal of Geophysical Research, Vol 97, D7, pp7603-7612). C C The details of the land surface albedo arrays can be found in the C common block description below. C C---------------------------Code history-------------------------------- C C Original version: CCM1 C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C------------------------------Commons---------------------------------- C C Surface albedo data C C The albedos are computed for a model grid box by ascribing values to C 1x1 degree points of a vegetation dataset, then linearly averaging C for each grid box; ocean and land values are averaged together along C coastlines; the fraction of every grid box that has strong zenith C angle dependence is included also (see Briegleb, Bruce P., 1992: C Delta-Eddington Approximation for Solar Radiation in the NCAR C Community Climate Model, Journal of Geophysical Research, Vol 97, D7, C pp7603-7612). C common/crdalb/albvss(plond,plat),albvsw(plond,plat), $ albnis(plond,plat),albniw(plond,plat), $ frctst(plond,plat) C C vis = 0.2 - 0.7 micro-meters wavelength range C nir = 0.7 - 5.0 micro-meters wavelength range C C szad = strong zenith angle dependent C wzad = weak zenith angle dependent C real albvss, ! Grid box alb for vis over szad surfaces $ albvsw, ! Grid box alb for vis over wzad surfaces $ albnis, ! Grid box alb for nir over szad surfaces $ albniw, ! Grid box alb for nir over wzad surfaces $ frctst ! Fraction of area in grid box with szad surfaces C C Surface boundary data C C Vegtyp is used to specify the thermal properites of the surface, as C well as determine the location of permanent land ice points; it is the C dominant surface type within the model grid box based on the 1x1 C degree resolution vegetation dataset; it is encoded in the following C manner: C C 1 ocean C 2 sea ice C 3 permanent land ice C 4 tropical evergreen forest C 5 deciduous forest C 6 grassland/tundra C 7 desert C C Rghnss is the aerodynamic roughness length for the grid box, computed C by linear averaging of the values ascribed to the 1x1 degree C resolution vegetation dataset; ocean and land values are averaged C together along coastlines. C C Evapf is the ratio of actual to potential evaporation, and is computed C from the 1x1 degree resolution vegetation dataset in a manner similar C to the aerodynamic roughness. C C Vevapf allows for variable snow cover, where the underlying C evaporability factor is modified. C C Snwjan and snwjly are mean climatological snow depths (liquid water C equivalent) used to compute the prescribed daily values of snow cover. C common/crdsrf/vegtyp(plond,plat),rghnss(plond,plat), $ evapf (plond,plat),vevapf(plond,plat), $ snwjan(plond,plat),snwjly(plond,plat) C real vegtyp, ! Surface thermal type, based on veg type $ rghnss, ! Aerodynamic roughness length $ evapf , ! Constant surface evaporability $ vevapf, ! Variable surface evaporability $ snwjan, ! Snow cover (liq water equiv) for January $ snwjly ! Snow cover (liq water equiv) for July C C------------------------------Arguments-------------------------------- C C Input arguments C integer lat ! Lat index for two dimensional data arrays integer ioro(plond) ! Surface type flag (ocean, land, sea ice) real sndpth(plond), ! Snow depth (liquid water equivalent) $ coszrs(plond) ! Cosine solar zenith angle C C Output arguments C real albs(plond), ! Srf alb for direct rad 0.2-0.7 micro-ms $ albl(plond), ! Srf alb for direct rad 0.7-5.0 micro-ms $ albsd(plond), ! Srf alb for diffuse rad 0.2-0.7 micro-ms $ albld(plond) ! Srf alb for diffuse rad 0.7-5.0 micro-ms C C---------------------------Local variables----------------------------- C integer i, ! Longitude index $ ii, ! Lngtd indx pnts satisfying certain condtns $ ipos(plond), ! Flag for computation points $ indx(plond), ! Indices for computation points $ npts ! Number of computation points C logical ilf(plond) ! Logical for specifying certain types sfc C real ocean(plond), ! Ocean flag (=1 for ocean, 0 otherwise) $ sice(plond), ! Sea ice flag (=1 for sea ice, 0 otherwise) $ rs, ! Empirical fact strng znth angl dependence $ rw, ! Empirical fact weak znth angl dependence $ frsnow(plond), ! Horizontal fraction of snow cover $ snwhgt, ! Physical snow height $ rghsnw ! Roughness for horizontal snow cover fractn C real salbs(plond), ! Snow alb for direct rad 0.2-0.7 micro-ms $ salbl(plond), ! Snow alb for direct rad 0.7-5.0 micro-ms $ salbsd(plond), ! Snow alb for diffuse rad 0.2-0.7 micro-ms $ salbld(plond) ! Snow alb for diffuse rad 0.7-5.0 micro-ms C C Albedos for snow, land ice, and sea ice: C real snws, ! Snow albedo for 0.2-0.7 micro-meters $ snwl, ! Snow albedo for 0.7-5.0 micro-meters $ sices, ! Sea ice albedo for 0.2-0.7 micro-meters $ sicel ! Sea ice albedo for 0.7-5.0 micro-meters C C---------------------------Data statements----------------------------- C data snws / .95 / ! Snow albedo for 0.2-0.7 micro-meters data snwl / .70 / ! Snow albedo for 0.7-5.0 micro-meters data sices / .70 / ! Sea ice alb for 0.2-0.7 micro-meters data sicel / .50 / ! Sea ice alb for 0.7-5.0 micro-meters C C------------------------------Externals-------------------------------- C external wheneq ! When equal funct gives indices for condtn C C----------------------------------------------------------------------- C C Set flags for ocean (with or without sea ice) and C ocean with sea ice points: C CDIR$ IVDEP do i=1,plon ocean(i) = 0. sice(i) = 0. if(ioro(i).eq.0) ocean(i) = 1. if(ioro(i).eq.2) sice(i) = 1. end do C C Initialize all surface albedos to zero C do i=1,plon albs(i) = 0. albl(i) = 0. albsd(i) = 0. albld(i) = 0. end do C C Land surfaces C do i=1,plon if(ocean(i).ne.1.0 .and. sice(i).eq.0.0 .and. $ coszrs(i).gt.0.0) then ipos(i) = 1 else ipos(i) = 0 end if end do call wheneq(plon,ipos,1,1,indx,npts) CDIR$ IVDEP do ii=1,npts i = indx(ii) C C Use empirical factors to adjust surface albedos for zenith angle C effects, distinquishing between strong and weakly dependent surfaces: C rs = 1.4/(1. + .8*coszrs(i)) rw = 1.1/(1. + .2*coszrs(i)) albs(i) = albvss(i,lat)*frctst(i,lat)*rs + $ albvsw(i,lat)*(1. - frctst(i,lat))*rw albl(i) = albnis(i,lat)*frctst(i,lat)*rs + $ albniw(i,lat)*(1. - frctst(i,lat))*rw albsd(i) = albvss(i,lat)*frctst(i,lat) + $ albvsw(i,lat)*(1. - frctst(i,lat)) albld(i) = albnis(i,lat)*frctst(i,lat) + $ albniw(i,lat)*(1. - frctst(i,lat)) end do C C Surfaces covered with sea ice: C do i=1,plon if( (sice(i).eq.1.0 .and. coszrs(i).gt.0.0) ) then ipos(i) = 1 else ipos(i) = 0 end if end do C call wheneq(plon,ipos,1,1,indx,npts) CDIR$ IVDEP do ii=1,npts i = indx (ii) albs(i) = sices albl(i) = sicel albsd(i) = albs(i) albld(i) = albl(i) end do C C Points with snowcover: C do i=1,plon ilf(i) = sndpth(i) .gt. 0. .and. coszrs(i) .gt. 0. if( sndpth(i).gt.0. .and. coszrs(i).gt.0. ) then ipos(i) = 1 else ipos(i) = 0 end if end do C call wheneq(plon,ipos,1,1,indx,npts) do ii=1,npts i = indx(ii) salbsd(i) = snws salbld(i) = snwl end do C C Direct snow albedos: distinguish between 2 zenith angle regimes C do i=1,plon ipos(i) = 0 if(ilf(i)) ipos(i) = 2 if(ilf(i) .and. coszrs(i).lt.0.5) ipos(i) = 1 end do C C Zenith angle regime 1 ( coszrs < 0.5 ). C Set direct snow albedos (limit to 0.98 max) C call wheneq(plon,ipos,1,1,indx,npts) do ii=1,npts i = indx(ii) salbs(i) = amin1(0.98,salbsd(i) + (1. - salbsd(i))*0.5* $ ((3./(1. + 4.*coszrs(i))) - 1.)) salbl(i) = amin1(0.98,salbld(i) + (1. - salbld(i))*0.5* $ ((3./(1. + 4.*coszrs(i))) - 1.)) end do C C Zenith angle regime 2 ( coszrs >= 0.5 ) C call wheneq(plon,ipos,1,2,indx,npts) do ii=1,npts i = indx(ii) salbs(i) = snws salbl(i) = snwl end do C C Compute fraction of horizonal surface covered with snow: C do i=1,plon if(sndpth(i) .le. 0.) then snwhgt = 0.0 rghsnw = 0.0 frsnow(i) = 0.0 else snwhgt = 20. * sndpth(i) rghsnw = amax1(rghnss(i,lat),0.25) frsnow(i) = snwhgt/(rghsnw + snwhgt) end if end do C C Points with snowcover: C do i=1,plon if( sndpth(i).gt.0. .and. coszrs(i).gt.0. ) then ipos(i) = 1 else ipos(i) = 0 end if end do call wheneq(plon,ipos,1,1,indx,npts) C C Compute both diffuse and direct total albedos C CDIR$ IVDEP do ii=1,npts i = indx(ii) albs(i) = albs(i) *(1.-frsnow(i)) + salbs(i) *frsnow(i) albl(i) = albl(i) *(1.-frsnow(i)) + salbl(i) *frsnow(i) albsd(i) = albsd(i)*(1.-frsnow(i)) + salbsd(i)*frsnow(i) albld(i) = albld(i)*(1.-frsnow(i)) + salbld(i)*frsnow(i) end do C C Local points over ice-free ocean with incident solar radiation: C do i=1,plon ipos(i)=0 if(ocean(i).eq.1. .and. sice(i).eq.0. .and. coszrs(i).ge.0.) $ ipos(i) = 1 end do call wheneq(plon,ipos,1,1,indx,npts) C C Ocean albedos function of solar zenith angle only,and C independent of spectral interval: C CDIR$ IVDEP do ii=1,npts i = indx(ii) albl(i) = (.026/(coszrs(i)**1.7 + .065)) + $ (.15*(coszrs(i) - 0.10)* $ (coszrs(i) - 0.50)* $ (coszrs(i) - 1.00) ) albs(i) = albl(i) albld(i) = 0.06 albsd(i) = 0.06 end do C return end subroutine radcsw(lat ,rel ,rei ,fice ,ioro , $ sndpth ,pint ,h2ommr ,cld ,clwp , $ o3mmr ,eccf ,coszrs ,solin ,qrs , $ fsns ,fsnt ,fsnsc ,fsntc ) C----------------------------------------------------------------------- C C Solar radiation code C C Computes incident solar flux, solar heating rate, surface absorbed C solar flux, and total column absorbed solar flux C C Uses the delta-eddington method C C Divides solar spectrum into 18 intervals from 0.2-5.0 micro-meters. C solar flux fractions specified for each interval. allows for C seasonally and diurnally varying solar input. Includes molecular, C cloud, and surface scattering, along with h2o,o3,co2,o2,cloud, and C surface absorption. Computes delta-eddington reflections and C transmissions assuming homogeneously mixed layers. Computes surface C albedos by invoking radalb. adds the layers assuming scattering C between layers to be isotropic, and distinguishes direct solar beam C from scattered radiation down to the surface. C C Longitude loops are broken into 1 or 2 sections, so that only daylight C (i.e. coszrs > 0) computations are done. C C Note that an extra layer above the model top layer is added. C C cgs units are used. C C Special diagnostic calc of the clear sky surface and total column C absorbed flux is also done; this calculation does not effect the rest C of the model, but is included for cloud forcing diagnostics. C C For more details , see Briegleb, Bruce P., 1992: Delta-Eddington C Approximation for Solar Radiation in the NCAR Community Climate Model, C Journal of Geophysical Research, Vol 97, D7, pp7603-7612). C C---------------------------Code history-------------------------------- C C Original version: B. Briegleb C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C------------------------------Commons---------------------------------- C C Radiation constants C common/crdcon/gravit ,rga ,cpair ,epsilo ,sslp , $ stebol ,rgsslp ,co2vmr ,dpfo3 ,dpfco2 , $ dayspy ,pie C real gravit, ! Acceleration of gravity $ rga, ! 1./gravit $ cpair, ! Specific heat of dry air $ epsilo, ! Ratio of mol. wght of H2O to dry air $ sslp, ! Standard sea-level pressure $ stebol, ! Stefan-Boltzmann's constant $ rgsslp, ! 0.5/(gravit*sslp) $ co2vmr, ! CO2 volume mixing ratio $ dpfo3, ! Voigt correction factor for O3 $ dpfco2, ! Voigt correction factor for CO2 $ dayspy, ! Number of days per 1 year $ pie ! 3.14..... C C------------------------------Arguments-------------------------------- C C Input arguments C integer lat ! Latitude index integer ioro(plond) ! Land/ocean/sea ice flag used by radalb real sndpth(plond), ! Snow depth used by radalb $ pint(plond,plevp), ! Interface pressure $ h2ommr(plond,plev), ! Specific humidity (h2o mass mix ratio) $ cld(plond,plevp), ! Fractional cloud cover $ clwp(plond,plev), ! Layer liquid water path $ o3mmr(plond,plev), ! Ozone mass mixing ratio $ eccf, ! Eccentricity factor(1./earth-sun dist. squared) $ coszrs(plond) ! Cosine solar zenith angle real rel(plond,plev) ! effective liquid drop size (microns) real rei(plond,plev) ! effective ice particle size (microns) real fice(plond,plev) ! fractional ice content in cloud layer C C Output arguments C real solin(plond), ! Incident solar flux $ qrs(plond,plev), ! Solar heating rate $ fsns(plond), ! Surface absorbed solar flux $ fsnt(plond), ! Total column absorbed solar flux $ fsnsc(plond), ! Clear sky surface absorbed solar flux $ fsntc(plond) ! Clear sky total column absorbed solar flx C C------------------------------Externals-------------------------------- C integer isrchfgt, ! Search for first array element > 0 $ isrchfle ! Search for first array element < 0 external radalb, ! Computes surface albedos $ radded, ! Computes delta-eddington solution $ radclr, ! Computes clear sky delta-edd solution $ isrchfgt, ! Search for first array element > 0 $ isrchfle ! Search for first array element < 0 C C---------------------------Local variables----------------------------- C integer ns, ! Spectral loop index $ i, ! Longitude loop index $ k, ! Level loop index $ n, ! Loop index for daylight $ nloop, ! Number of daylight loops $ is(2), ! Daytime start indices $ ie(2), ! Daytime end indices $ indxsl ! Index for cloud particle properties C real scon ! Solar constant save scon data scon / 1.370e6 / c data scon / 0.436e6 / ! solar constant devided by pi C C A. Slingo's data for cloud particle radiative properties (from 'A GCM C Parameterization for the Shortwave Properties of Water Clouds' JAS C vol. 46 may 1989 pp 1419-1427) liquid C real abarl(4), ! A coefficient for extinction optical depth $ bbarl(4), ! B coefficiant for extinction optical depth $ cbarl(4), ! C coefficiant for single particle scat albedo $ dbarl(4), ! D coefficiant for single particle scat albedo $ ebarl(4), ! E coefficiant for asymmetry parameter $ fbarl(4) ! F coefficiant for asymmetry parameter C data abarl/ 2.817e-02, 2.682e-02,2.264e-02,1.281e-02/ data bbarl/ 1.305 , 1.346 ,1.454 ,1.641 / cc data cbarl/-5.62e-08 ,-6.94e-06 ,4.64e-04 ,0.201 / cc data dbarl/ 1.63e-07 , 2.35e-05 ,1.24e-03 ,7.56e-03 / data cbarl/0.003,0.010,0.14,0.36/ data dbarl/0.0,0.0,0.0,0.0/ data ebarl/ 0.829 , 0.794 ,0.754 ,0.826 / data fbarl/ 2.482e-03, 4.226e-03,6.560e-03,4.353e-03/ C real abarli, ! A coefficiant for current spectral interval $ bbarli, ! B coefficiant for current spectral interval $ cbarli, ! C coefficiant for current spectral interval $ dbarli, ! D coefficiant for current spectral interval $ ebarli, ! E coefficiant for current spectral interval $ fbarli ! F coefficiant for current spectral interval C c ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836) c real abari(4), ! a coefficient for extinction optical depth $ bbari(4), ! b coefficiant for extinction optical depth $ cbari(4), ! c coefficiant for single particle scat albedo $ dbari(4), ! d coefficiant for single particle scat albedo $ ebari(4), ! e coefficiant for asymmetry parameter $ fbari(4) ! f coefficiant for asymmetry parameter c data abari/ 3.448e-03, 3.448e-03,3.448e-03,3.448e-03/ data bbari/ 2.431 , 2.431 ,2.431 ,2.431 / data cbari/ 1.00e-05 , 1.10e-04 ,1.861e-02,.46658 / data dbari/ 0.0 , 1.405e-05,8.328e-04,2.05e-05 / data ebari/ 0.7661 , 0.7730 ,0.794 ,0.9595 / data fbari/ 5.851e-04, 5.665e-04,7.267e-04,1.076e-04/ C real abarii, ! A coefficiant for current spectral interval $ bbarii, ! B coefficiant for current spectral interval $ cbarii, ! C coefficiant for current spectral interval $ dbarii, ! D coefficiant for current spectral interval $ ebarii, ! E coefficiant for current spectral interval $ fbarii ! F coefficiant for current spectral interval C C Caution... A. Slingo recommends no less than 4.0 micro-meters nor C greater than 20 micro-meters C real cldefr ! Universal cloud effective radius in micro-meters c data cldefr / 10.0 / C real delta ! Pressure (atmospheres) for stratospheric h2o limit data delta / 1.70e-3 / C real o2mmr ! O2 mass mixing ratio: save cldefr, delta, o2mmr data o2mmr / .23143 / C C CO2 info: C real mmwair, ! Mean molecular weight of air $ mmwco2, ! Mean molecular weight of co2 $ co2mmr ! Co2 mass mixing ratio save mmwair, mmwco2 data mmwair / 28.9644 / data mmwco2 / 44.0000 / C real albdir(plond), ! Current spc intrvl srf alb to direct rad $ albdif(plond) ! Current spc intrvl srf alb to diffuse rad C real albs(plond), ! 0.2-0.7 micro-meter srfc alb to direct rad $ albl(plond), ! 0.7-5.0 micro-meter srfc alb to direct rad $ albsd(plond), ! 0.2-0.7 micro-meter srfc alb to diffuse rad $ albld(plond) ! 0.7-5.0 micro-meter srfc alb to diffuse rad C integer nspint ! Num of spectral intervals across solar spectrum parameter ( nspint = 18 ) C C Next series depends on spectral interval C real frcsol(nspint), ! Fraction of solar flux in each spectral interval $ wavmin(nspint), ! Min wavelength (micro-meters) of interval $ wavmax(nspint), ! Max wavelength (micro-meters) of interval $ raytau(nspint), ! Rayleigh scattering optical depth $ abh2o(nspint), ! Absorption coefficiant for h2o (cm2/g) $ abo3 (nspint), ! Absorption coefficiant for o3 (cm2/g) $ abco2(nspint), ! Absorption coefficiant for co2 (cm2/g) $ abo2 (nspint), ! Absorption coefficiant for o2 (cm2/g) $ ph2o(nspint), ! Weight of h2o in spectral interval $ po3 (nspint), ! Weight of o3 in spectral interval $ pco2(nspint), ! Weight of co2 in spectral interval $ po2 (nspint) ! Weight of o2 in spectral interval save frcsol ,wavmin ,wavmax ,raytau ,abh2o ,abo3 , $ abco2 ,abo2 ,ph2o ,po3 ,pco2 ,po2 C data frcsol / .001488, .001389, .001290, .001686, .002877, $ .003869, .026336, .426131, .526861, .526861, $ .526861, .526861, .526861, .526861, .526861, $ .006239, .001834, .001834/ C data wavmin / .200, .245, .265, .275, .285, $ .295, .305, .350, .700, .701, $ .701, .701, .701, .702, .702, $ 2.630, 4.160, 4.160/ data wavmax / .245, .265, .275, .285, .295, $ .305, .350, .700, 5.000, 5.000, $ 5.000, 5.000, 5.000, 5.000, 5.000, $ 2.860, 4.550, 4.550/ C data raytau / 4.020, 2.180, 1.700, 1.450, 1.250, $ 1.085, 0.730, 0.135, 0.020, .0001, $ .0001, .0001, .0001, .0001, .0001, $ .0001, .0001, .0001/ C C Absorption coefficiants C data abh2o / .000, .000, .000, .000, .000, $ .000, .000, .000, .002, .035, $ .377, 1.950, 9.400, 44.600, 190.000, $ .000, .000, .000/ C data abo3 / $ 5.370e+04, 13.080e+04, 9.292e+04, 4.530e+04, 1.616e+04, $ 4.441e+03, 1.775e+02, 2.101e+01, .000, .000, $ .000 , .000 , .000 , .000, .000, $ .000 , .000 , .000 / C data abco2 / .000, .000, .000, .000, .000, $ .000, .000, .000, .000, .000, $ .000, .000, .000, .000, .000, $ .094, .196, 1.963/ C data abo2 / .000, .000, .000, .000, .000, $ .000, .000,1.11e-05,6.69e-05, .000, $ .000, .000, .000, .000, .000, $ .000, .000, .000/ C C Spectral interval weights C data ph2o / .000, .000, .000, .000, .000, $ .000, .000, .000, .505, .210, $ .120, .070, .048, .029, .018, $ .000, .000, .000/ data po3 / 1.000, 1.000, 1.000, 1.000, 1.000, $ 1.000, 1.000, 1.000, .000, .000, $ .000, .000, .000, .000, .000, $ .000, .000, .000/ data pco2 / .000, .000, .000, .000, .000, $ .000, .000, .000, .000, .000, $ .000, .000, .000, .000, .000, $ 1.000, .640, .360/ data po2 / .000, .000, .000, .000, .000, $ .000, .000, 1.000, 1.000, .000, $ .000, .000, .000, .000, .000, $ .000, .000, .000/ C C Diagnostic and accumulation arrays; note that sfltot, fswup, and C fswdn are not used in the computation,but are retained for future use. C real solflx(plond), ! Solar flux in current interval $ sfltot(plond), ! Spectrally summed total solar flux $ totfld(plond,0:plev), ! Spectrally summed flux divergence $ fswup(plond,0:plevp), ! Spectrally summed up flux $ fswdn(plond,0:plevp) ! Spectrally summed down flux C C Cloud radiative property arrays C real tauxcl(plond,0:plev), ! Cloud extinction optical depth $ tauxci(plond,0:plev), ! Cloud extinction optical depth $ wcl(plond,0:plev), ! Cloud single scattering albedo $ gcl(plond,0:plev), ! Cloud asymmetry parameter $ fcl(plond,0:plev), ! Cloud forward scattered fraction $ wci(plond,0:plev), ! Cloud single scattering albedo $ gci(plond,0:plev), ! Cloud asymmetry parameter $ fci(plond,0:plev) ! Cloud forward scattered fraction C C Various arrays and other constants: C real pflx(plond,0:plevp), ! Interface press, including extra layer $ zenfac(plond), ! Square root of cos solar zenith angle $ sqrco2, ! Square root of the co2 mass mixg ratio $ tmp1, $ tmp2, $ tmp1l, ! Temporary constant array $ tmp2l, ! Temporary constant array $ tmp3l, ! Temporary constant array $ tmp1i, ! Temporary constant array $ tmp2i, ! Temporary constant array $ tmp3i, ! Temporary constant array $ pdel ! Pressure difference across layer real path, ! Mass path of layer $ ptop, ! Lower interface pressure of extra layer $ ptho2, ! Used to compute mass path of o2 $ ptho3, ! Used to compute mass path of o3 $ pthco2, ! Used to compute mass path of co2 $ pthh2o, ! Used to compute mass path of h2o $ h2ostr, ! Inverse square root h2o mass mixing ratio $ wavmid, ! Spectral interval middle wavelength $ trayoslp, ! Rayleigh optical depth/standard pressure $ rdenom, ! Multiple scattering term $ psf, ! Frac of solar flux in spect interval $ gocp ! Gravity/cp C C Layer absorber amounts; note that 0 refers to the extra layer added C above the top model layer C real uh2o(plond,0:plev), ! Layer absorber amount of h2o $ uo3(plond,0:plev), ! Layer absorber amount of o3 $ uco2(plond,0:plev), ! Layer absorber amount of co2 $ uo2(plond,0:plev) ! Layer absorber amount of o2 C C Total column absorber amounts: C real uth2o(plond), ! Total column absorber amount of h2o $ uto3(plond), ! Total column absorber amount of o3 $ utco2(plond), ! Total column absorber amount of co2 $ uto2(plond) ! Total column absorber amount of o2 C C These arrays are defined for plev model layers; 0 refers to the extra C layer on top: C real rdir(plond,0:plev), ! Layer reflectivity to direct rad $ rdif(plond,0:plev), ! Layer reflectivity to diffuse rad $ tdir(plond,0:plev), ! Layer transmission to direct rad $ tdif(plond,0:plev), ! Layer transmission to diffuse rad $ explay(plond,0:plev), ! Solar beam exp transmission for layer $ flxdiv(plond,0:plev) ! Flux divergence for layer C C These arrays are defined at model interfaces; 0 is the top of the C extra layer above the model top; plevp is the earth surface: C real rupdir(plond,0:plevp), ! Ref to dir rad for layers below $ rupdif(plond,0:plevp), ! Ref to dif rad for layers below $ rdndif(plond,0:plevp), ! Ref to dif rad for layers above $ exptdn(plond,0:plevp), ! Solar beam exp down transm from top $ tottrn(plond,0:plevp), ! Total transmission for layers above $ fluxup(plond,0:plevp), ! Up flux at model interface $ fluxdn(plond,0:plevp) ! Down flux at model interface C C----------------------------------------------------------------------- cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real upsw,dnsw,uplw,dnlw ! upward and downward fluxes common/rad_save2/ upsw(plon,plevp),dnsw(plon,plevp), * uplw(plon,plevp),dnlw(plon,plevp) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C C Compute surface albedos: C call radalb(lat ,ioro ,sndpth ,coszrs ,albs , $ albl ,albsd ,albld ) C C Set cloud effective radius in micrometers: C c do k=1,plev c cre(k) = cldefr c rcre(k) = 1./cre(k) c end do C C Initialize output fields: C do i=1, plon fsnt(i) = 0.0 fsns(i) = 0.0 solin(i) = 0.0 fsnsc(i) = 0.0 fsntc(i) = 0.0 end do do k=1, plev do i=1, plon qrs(i,k) = 0.0 end do end do C C Compute starting, ending daytime loop indices: C nloop = 0 is(1) = isrchfgt(plon,coszrs,1,0.0) C C If night everywhere, return: C if(is(1).gt.plon) return ie(1) = isrchfle(plon-is(1),coszrs(is(1)+1),1,0.0) + is(1) - 1 nloop = 1 C C Possibly 2 daytime loops needed: C if(ie(1).ne.plon) then is(2) = isrchfgt(plon-ie(1),coszrs(ie(1)+1),1,0.0) + ie(1) if(is(2).le.plon) then nloop = 2 ie(2) = plon end if end if C C Define solar incident radiation and interface pressures: C do n=1,nloop do i=is(n),ie(n) solin(i) = scon*eccf*coszrs(i) pflx(i,0) = 0. end do end do do k=1,plevp do n=1,nloop do i=is(n),ie(n) pflx(i,k) = pint(i,k) end do end do end do C C Compute optical paths: C tmp1 = 0.5/(gravit*sslp) co2mmr = co2vmr*(mmwco2/mmwair) sqrco2 = sqrt(co2mmr) do n=1,nloop do i=is(n),ie(n) ptop = pflx(i,1) ptho2 = o2mmr * ptop / gravit ptho3 = o3mmr(i,1) * ptop / gravit pthco2 = sqrco2 * (ptop / gravit) h2ostr = sqrt( 1. / h2ommr(i,1) ) zenfac(i) = sqrt(coszrs(i)) pthh2o = ptop**2*tmp1 + $ (ptop*rga)*(h2ostr*zenfac(i)*delta) uh2o(i,0) = h2ommr(i,1)*pthh2o uco2(i,0) = zenfac(i)*pthco2 uo2 (i,0) = zenfac(i)*ptho2 uo3 (i,0) = ptho3 end do end do C tmp2 = delta/gravit do k=1,plev do n=1,nloop do i=is(n),ie(n) pdel = pflx(i,k+1) - pflx(i,k) path = pdel / gravit ptho2 = o2mmr * path ptho3 = o3mmr(i,k) * path pthco2 = sqrco2 * path h2ostr = sqrt(1.0/h2ommr(i,k)) pthh2o = (pflx(i,k+1)**2 - pflx(i,k)**2)*tmp1 + $ pdel*h2ostr*zenfac(i)*tmp2 uh2o(i,k) = h2ommr(i,k)*pthh2o uco2(i,k) = zenfac(i)*pthco2 uo2 (i,k) = zenfac(i)*ptho2 uo3 (i,k) = ptho3 end do end do end do C C Compute column absorber amounts for the clear sky computation: C do n=1,nloop do i=is(n),ie(n) uth2o(i) = 0.0 uto3(i) = 0.0 utco2(i) = 0.0 uto2(i) = 0.0 end do end do do k=1,plev do n=1,nloop do i=is(n),ie(n) uth2o(i) = uth2o(i) + uh2o(i,k) uto3(i) = uto3(i) + uo3(i,k) utco2(i) = utco2(i) + uco2(i,k) uto2(i) = uto2(i) + uo2(i,k) end do end do end do C C Initialize spectrally integrated totals: C do k=0,plev do i=1,plon totfld(i,k) = 0.0 fswup (i,k) = 0.0 fswdn (i,k) = 0.0 end do end do do i=1,plon sfltot(i) = 0.0 fswup (i,plevp) = 0.0 fswdn (i,plevp) = 0.0 end do C C Set cloud properties for top (0) layer; so long as tauexc is zero, C there is no cloud above top of model; the other cloud properties C are arbitrary: C do n=1,nloop do i=is(n),ie(n) tauxcl(i,0) = 0. wcl(i,0) = 0.999999 gcl(i,0) = 0.85 fcl(i,0) = 0.725 tauxci(i,0) = 0. wci(i,0) = 0.999999 gci(i,0) = 0.85 fci(i,0) = 0.725 end do end do C C Begin spectral loop C do 100 ns=1,nspint C C Set index for cloud particle properties based on the wavelength, C according to A. Slingo (1989) equations 1-3: C Use index 1 (0.25 to 0.69 micrometers) for visible C Use index 2 (0.69 - 1.19 micrometers) for near-infrared C Use index 3 (1.19 to 2.38 micrometers) for near-infrared C Use index 4 (2.38 to 4.00 micrometers) for near-infrared C C Note that the minimum wavelength is encoded (with .001, .002, .003) C in order to specify the index appropriate for the near-infrared C cloud absorption properties C if(wavmax(ns) .le. 0.7) then indxsl = 1 else if(wavmin(ns) .eq. 0.700) then indxsl = 2 else if(wavmin(ns) .eq. 0.701) then indxsl = 3 else if(wavmin(ns) .eq. 0.702 .or. wavmin(ns) .gt. 2.38) then indxsl = 4 end if C C Set cloud extinction optical depth, single scatter albedo, C asymmetry parameter, and forward scattered fraction: C abarli = abarl(indxsl) bbarli = bbarl(indxsl) cbarli = cbarl(indxsl) dbarli = dbarl(indxsl) ebarli = ebarl(indxsl) fbarli = fbarl(indxsl) c abarii = abari(indxsl) bbarii = bbari(indxsl) cbarii = cbari(indxsl) dbarii = dbari(indxsl) ebarii = ebari(indxsl) fbarii = fbari(indxsl) do k=1,plev do n=1,nloop do i=is(n),ie(n) c liquid tmp1l = abarli + bbarli/rel(i,k) tmp2l = 1. - cbarli - dbarli*rel(i,k) tmp3l = fbarli*rel(i,k) c ice tmp1i = abarii + bbarii/rei(i,k) tmp2i = 1. - cbarii - dbarii*rei(i,k) tmp3i = fbarii*rei(i,k) C C Cloud fraction incorporated into cloud extinction optical depth C tauxcl(i,k) = clwp(i,k)*tmp1l*(1.-fice(i,k)) $ *cld(i,k)*sqrt(cld(i,k)) tauxci(i,k) = clwp(i,k)*tmp1i*fice(i,k) $ *cld(i,k)*sqrt(cld(i,k)) C C Do not let single scatter albedo be 1; delta-eddington solution C for non-conservative case: C wcl(i,k) = amin1(tmp2l,.999999) gcl(i,k) = ebarli + tmp3l fcl(i,k) = gcl(i,k)*gcl(i,k) c wci(i,k) = amin1(tmp2i,.999999) gci(i,k) = ebarii + tmp3i fci(i,k) = gci(i,k)*gci(i,k) end do end do end do C C C Set reflectivities for surface based on mid-point wavelength C wavmid = 0.5*(wavmin(ns) + wavmax(ns)) C C Wavelength less than 0.7 micro-meter C if(wavmid .lt. 0.7 ) then do n=1,nloop do i=is(n),ie(n) albdir(i) = albs(i) albdif(i) = albsd(i) end do end do C C Wavelength greater than 0.7 micro-meter C else do n=1,nloop do i=is(n),ie(n) albdir(i) = albl(i) albdif(i) = albld(i) end do end do end if trayoslp = raytau(ns)/sslp C C Layer input properties now completely specified; compute the C delta-Eddington solution reflectivities and transmissivities C for each layer, starting from the top and working downwards: C call radded(coszrs ,trayoslp,pflx ,abh2o(ns),abo3(ns), $ abco2(ns),abo2(ns),uh2o ,uo3 ,uco2 , $ uo2 ,tauxcl ,wcl ,gcl ,fcl , $ tauxci ,wci ,gci ,fci ,nloop , $ is ,ie ,rdir ,rdif ,tdir , $ tdif ,explay ,exptdn ,rdndif ,tottrn ) C C Compute reflectivity to direct and diffuse radiation for layers below C by adding succesive layers starting from the surface and working C upwards: C do n=1,nloop do i=is(n),ie(n) rupdir(i,plevp) = albdir(i) rupdif(i,plevp) = albdif(i) end do end do do k=plev,0,-1 do n=1,nloop do i=is(n),ie(n) rdenom = 1./( 1. - rdif(i,k)*rupdif(i,k+1)) rupdir(i,k) = rdir(i,k) + tdif(i,k)* $ (rupdir(i,k+1)*explay(i,k) + $ rupdif(i,k+1)*(tdir(i,k)-explay(i,k)))*rdenom rupdif(i,k) = rdif(i,k) + $ rupdif(i,k+1)*tdif(i,k)**2*rdenom end do end do end do C C Compute up and down fluxes for each interface, using the added C atmospheric layer properties at each interface: C do k=0,plevp do n=1,nloop do i=is(n),ie(n) rdenom = 1./(1. - rdndif(i,k)*rupdif(i,k)) fluxup(i,k) = (exptdn(i,k)*rupdir(i,k) + $ (tottrn(i,k)-exptdn(i,k))*rupdif(i,k))*rdenom fluxdn(i,k)=exptdn(i,k) + (tottrn(i,k) - exptdn(i,k) + $ exptdn(i,k)*rupdir(i,k)*rdndif(i,k))*rdenom end do end do end do C C Compute flux divergence in each layer using the interface up and down C fluxes: C do k=0,plev do n=1,nloop do i=is(n),ie(n) flxdiv(i,k) = (fluxdn(i,k ) - fluxdn(i,k+1)) + $ (fluxup(i,k+1) - fluxup(i,k )) end do end do end do C C Monochromatic computation completed; accumulate in totals; adjust C fraction within spectral interval to allow for the possibility of C sub-divisions within a particular interval: C psf = 1.0 if(ph2o(ns).ne.0.) psf = psf*ph2o(ns) if(pco2(ns).ne.0.) psf = psf*pco2(ns) if(po2 (ns).ne.0.) psf = psf*po2 (ns) do n=1,nloop do i=is(n),ie(n) solflx(i) = solin(i)*frcsol(ns)*psf fsnt(i) = fsnt(i) + solflx(i)*(fluxdn(i,1) - fluxup(i,1)) fsns(i) = fsns(i) + solflx(i)* $ (fluxdn(i,plevp) - fluxup(i,plevp)) sfltot(i) = sfltot(i) + solflx(i) fswup(i,0) = fswup(i,0) + solflx(i)*fluxup(i,0) fswdn(i,0) = fswdn(i,0) + solflx(i)*fluxdn(i,0) end do end do do k=0,plev do n=1,nloop do i=is(n),ie(n) totfld(i,k) = totfld(i,k) + solflx(i)*flxdiv(i,k) fswup(i,k+1) = fswup(i,k+1) + solflx(i)*fluxup(i,k+1) fswdn(i,k+1) = fswdn(i,k+1) + solflx(i)*fluxdn(i,k+1) end do end do end do C C C Following code is the diagnostic clear sky computation: C C Compute delta-Eddington solution reflectivities and transmissivities C for the entire column; note, for convenience, we use the same C reflectivity and transmissivity arrays as for the full calculation C above, where 0 for layer quantities refers to the entire atmospheric C column, and where 0 for interface quantities refers to top of atmos- C phere, while 1 refers to the surface: C call radclr(coszrs ,trayoslp,pflx ,abh2o(ns),abo3(ns) , $ abco2(ns),abo2(ns),uth2o ,uto3 ,utco2 , $ uto2 ,nloop ,is ,ie ,rdir , $ rdif ,tdir ,tdif ,explay ,exptdn , $ rdndif ,tottrn ) C C Compute reflectivity to direct and diffuse radiation for entire C column; 0,1 on layer quantities refers to two effective layers C overlying surface; 0 on interface quantities refers to top of column; C 2 on interface quantities refers to the surface: C do n=1,nloop do i=is(n),ie(n) rupdir(i,2) = albdir(i) rupdif(i,2) = albdif(i) end do end do C do k=1,0,-1 do n=1,nloop do i=is(n),ie(n) rdenom = 1./( 1. - rdif(i,k)*rupdif(i,k+1)) rupdir(i,k) = rdir(i,k) + tdif(i,k)* $ (rupdir(i,k+1)*explay(i,k) + $ rupdif(i,k+1)*(tdir(i,k)-explay(i,k)))*rdenom rupdif(i,k) = rdif(i,k) + $ rupdif(i,k+1)*tdif(i,k)**2*rdenom end do end do end do C C Compute up and down fluxes for each interface, using the added C atmospheric layer properties at each interface: C do k=0,2 do n=1,nloop do i=is(n),ie(n) rdenom = 1./(1. - rdndif(i,k)*rupdif(i,k)) fluxup(i,k) = (exptdn(i,k)*rupdir(i,k) + $ (tottrn(i,k)-exptdn(i,k))*rupdif(i,k))*rdenom fluxdn(i,k)=exptdn(i,k) + (tottrn(i,k) - exptdn(i,k) + $ exptdn(i,k)*rupdir(i,k)*rdndif(i,k))*rdenom end do end do end do C do n=1,nloop do i=is(n),ie(n) fsntc(i) = fsntc(i) + solflx(i)*(fluxdn(i,0)-fluxup(i,0)) fsnsc(i) = fsnsc(i) + solflx(i)*(fluxdn(i,2)-fluxup(i,2)) end do end do C C End of clear sky calculation C 100 continue ! End of spectral interval loop C C Compute solar heating rate (k/s) C gocp = gravit/cpair do k=1,plev do n=1,nloop do i=is(n),ie(n) qrs(i,k) = -gocp*totfld(i,k)/(pint(i,k) - pint(i,k+1)) end do end do end do c c save sw fluxes: do k=1,plevp do n=1,nloop do i=is(n),ie(n) upsw(i,k) = fswup(i,k) dnsw(i,k) = fswdn(i,k) end do end do end do C C return end subroutine radded(coszrs ,trayoslp,pflx ,abh2o ,abo3 , $ abco2 ,abo2 ,uh2o ,uo3 ,uco2 , $ uo2 ,tauxcl ,wcl ,gcl ,fcl , $ tauxci ,wci ,gci ,fci ,nloop , $ is ,ie ,rdir ,rdif ,tdir , $ tdif ,explay ,exptdn ,rdndif ,tottrn ) C----------------------------------------------------------------------- C C Computes layer reflectivities and transmissivities, from the top down C to the surface using the delta-Eddington solutions for each layer; C adds layers from top down to surface as well. C C If total transmission to the interface above a particular layer is C less than trmin, then no further delta-Eddington solutions are C evaluated for layers below C C For more details , see Briegleb, Bruce P., 1992: Delta-Eddington C Approximation for Solar Radiation in the NCAR Community Climate Model, C Journal of Geophysical Research, Vol 97, D7, pp7603-7612). C C---------------------------Code history-------------------------------- C C Original version: B. Briegleb C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C------------------------------Arguments-------------------------------- C C Input arguments C real coszrs(plond), ! Cosine zenith angle $ trayoslp, ! Tray/sslp $ pflx(plond,0:plevp), ! Interface pressure $ abh2o, ! Absorption coefficiant for h2o $ abo3 , ! Absorption coefficiant for o3 $ abco2, ! Absorption coefficiant for co2 $ abo2 , ! Absorption coefficiant for o2 $ uh2o(plond,0:plev), ! Layer absorber amount of h2o $ uo3(plond,0:plev), ! Layer absorber amount of o3 $ uco2(plond,0:plev), ! Layer absorber amount of co2 $ uo2(plond,0:plev) ! Layer absorber amount of o2 real tauxcl(plond,0:plev), ! Cloud extinction optical depth $ wcl(plond,0:plev), ! Cloud single scattering albedo $ gcl(plond,0:plev), ! Cloud assymetry parameter $ fcl(plond,0:plev), ! Cloud forward scattered fraction $ tauxci(plond,0:plev), ! Cloud extinction optical depth $ wci(plond,0:plev), ! Cloud single scattering albedo $ gci(plond,0:plev), ! Cloud assymetry parameter $ fci(plond,0:plev) integer nloop, ! Number of loops (1 or 2) $ is(2), ! Starting index for 1 or 2 loops $ ie(2) ! Ending index for 1 or 2 loops C C Input/Output arguments C C Following variables are defined for each layer; 0 refers to extra C layer above top of model: C real rdir(plond,0:plev), ! Layer reflectivity to direct rad $ rdif(plond,0:plev), ! Layer refflectivity to diffuse rad $ tdir(plond,0:plev), ! Layer transmission to direct rad $ tdif(plond,0:plev), ! Layer transmission to diffuse rad $ explay(plond,0:plev) ! Solar beam exp transm for layer C C (Note that the following variables are defined on interfaces, with the C index k referring to the top interface of the kth layer: C exptdn,rdndif,tottrn; for example, tottrn(k=5) refers to the total C transmission to the top interface of the 5th layer; plevp refers to C the earth surface) C real rdndif(plond,0:plevp), ! Added dif ref for layers above $ exptdn(plond,0:plevp), ! Solar beam exp down transm from top $ tottrn(plond,0:plevp) ! Total transmission for layers above C C------------------------------Externals-------------------------------- C external resetr, ! Resets array elements to zero $ whenfgt ! Collect indices greater than conditn C C---------------------------Local variables----------------------------- C integer i, ! Longitude index $ k, ! Level index $ nn, ! Index of longitude loops (max=nloop) $ ii, ! Longitude index $ nval, ! Number of long values satisfying criteria $ index(plond) ! Array of longitude indices C real taugab(plond), ! Layer total gas absorption optical depth $ tauray(plond), ! Layer rayleigh optical depth $ taucsc, ! Layer cloud scattering optical depth $ tautot, ! Total layer optical depth $ wtot, ! Total layer single scatter albedo $ gtot, ! Total layer asymmetry parameter $ ftot ! Total layer forward scatter fraction C C Minimum total transmission below which no layer computation are done: C real trmin, ! Transmission cutoff $ wray, ! Rayleigh single scatter albedo $ gray, ! Rayleigh asymetry parameter $ fray ! Rayleigh forward scattered fraction save trmin, wray, gray, fray C data trmin / 1.e-3 / data wray / 0.999999 / data gray / 0.0 / data fray / 0.1 / C real wtau, ! rayleigh layer scattering optical depth $ wt, ! layer total single scattering albedo $ ts, ! layer scaled extinction optical depth $ ws, ! layer scaled single scattering albedo $ gs ! layer scaled asymmetry parameter C real rdenom, ! mulitiple scattering term $ rdirexp, ! layer direct ref times exp transmission $ tdnmexp ! total transmission minus exp transmission C C---------------------------Statement functions------------------------- C C Statement functions and other local variables C real alpha, ! Term in direct reflect and transmissivity $ gamma, ! Term in direct reflect and transmissivity $ el, ! Term in alpha,gamma,n,u $ taus, ! Scaled extinction optical depth $ omgs, ! Scaled single particle scattering albedo $ asys, ! Scaled asymmetry parameter $ u, ! Term in diffuse reflect and transmissivity $ n, ! Term in diffuse reflect and transmissivity $ lm, ! Temporary for el $ ne ! Temporary for n real w, ! Dummy argument for statement function $ uu, ! Dummy argument for statement function $ g, ! Dummy argument for statement function $ e, ! Dummy argument for statement function $ f, ! Dummy argument for statement function $ t, ! Dummy argument for statement function $ et ! Dummy argument for statement function C C Intermediate terms for delta-eddington solution C real alp, ! Temporary for alpha $ gam, ! Temporary for gamma $ ue, ! Temporary for u $ arg, ! Exponential argument $ extins, ! Extinction $ amg, ! Alp - gam $ apg ! Alp + gam C alpha(w,uu,g,e) = .75*w*uu*((1. + g*(1-w))/(1. - e*e*uu*uu)) gamma(w,uu,g,e) = .50*w*((3.*g*(1.-w)*uu*uu + 1.)/(1.-e*e*uu*uu)) el(w,g) = sqrt(3.*(1-w)*(1. - w*g)) taus(w,f,t) = (1. - w*f)*t omgs(w,f) = (1. - f)*w/(1. - w*f) asys(g,f) = (g - f)/(1. - f) u(w,g,e) = 1.5*(1. - w*g)/e n(uu,et) = ((uu+1.)*(uu+1.)/et ) - ((uu-1.)*(uu-1.)*et) C C----------------------------------------------------------------------- C C Initialize all total transmission values to 0, so that nighttime C values from previous computations are not used: C call resetr(tottrn,plond*plevp,0.) C C Compute total direct beam transmission, total transmission, and C reflectivity for diffuse radiation (from below) for all layers above C each interface by starting from the top and adding layers down: C C For the extra layer above model top: C do 200 nn=1,nloop do 100 i=is(nn),ie(nn) C tauray(i) = trayoslp*(pflx(i,1)-pflx(i,0)) taugab(i) = abh2o*uh2o(i,0) + abo3*uo3(i,0) + $ abco2*uco2(i,0) + abo2*uo2(i,0) C tautot = tauxcl(i,0) + tauxci(i,0) + tauray(i) + taugab(i) taucsc = tauxcl(i,0)*wcl(i,0)+tauxci(i,0)*wci(i,0) wtau = wray*tauray(i) wt = wtau + taucsc wtot = wt/tautot gtot = (wtau*gray + gcl(i,0)*tauxcl(i,0)*wcl(i,0) + $ gci(i,0)*tauxci(i,0)*wci(i,0))/wt ftot = (wtau*fray + fcl(i,0)*tauxcl(i,0)*wcl(i,0) + $ fci(i,0)*tauxci(i,0)*wci(i,0))/wt C ts = taus(wtot,ftot,tautot) ws = omgs(wtot,ftot) gs = asys(gtot,ftot) lm = el(ws,gs) alp = alpha(ws,coszrs(i),gs,lm) gam = gamma(ws,coszrs(i),gs,lm) ue = u(ws,gs,lm) C C Limit argument of exponential to 25, in case lm*ts very large: C arg = amin1(lm*ts,25.) extins = exp(-arg) ne = n(ue,extins) C rdif(i,0) = (ue+1.)*(ue-1.)*(1./extins - extins)/ne tdif(i,0) = 4.*ue/ne C C Limit argument of exponential to 25, in case coszrs is very small: C arg = amin1(ts/coszrs(i),25.) explay(i,0) = exp(-arg) C apg = alp + gam amg = alp - gam rdir(i,0) = amg*(tdif(i,0)*explay(i,0) - 1.) + apg*rdif(i,0) tdir(i,0) = apg*tdif(i,0) + $ (amg*rdif(i,0) - (apg-1.))*explay(i,0) C C Under rare conditions, reflectivies and transmissivities can be C negative; zero out any negative values C rdir(i,0) = amax1(rdir(i,0),0.0) tdir(i,0) = amax1(tdir(i,0),0.0) rdif(i,0) = amax1(rdif(i,0),0.0) tdif(i,0) = amax1(tdif(i,0),0.0) C C Initialize top interface of extra layer: C exptdn(i,0) = 1.0 rdndif(i,0) = 0.0 tottrn(i,0) = 1.0 C rdndif(i,1) = rdif(i,0) tottrn(i,1) = tdir(i,0) C 100 continue 200 continue C C Now, continue down one layer at a time; if the total transmission to C the interface just above a given layer is less than trmin, then no C delta-eddington computation for that layer is done: C do 400 k=1,plev C C Initialize current layer properties to zero; only if total C transmission to the top interface of the current layer exceeds the C minimum, will these values be computed below: C do nn=1,nloop do i=is(nn),ie(nn) C rdir(i,k) = 0.0 rdif(i,k) = 0.0 tdir(i,k) = 0.0 tdif(i,k) = 0.0 explay(i,k) = 0.0 C C Calculates the solar beam transmission, total transmission, and C reflectivity for diffuse radiation from below at the top of the C current layer: C exptdn(i,k) = exptdn(i,k-1)*explay(i,k-1) rdenom = 1./(1. - rdif(i,k-1)*rdndif(i,k-1)) rdirexp = rdir(i,k-1)*exptdn(i,k-1) tdnmexp = tottrn(i,k-1) - exptdn(i,k-1) tottrn(i,k) = exptdn(i,k-1)*tdir(i,k-1) + tdif(i,k-1)* $ (tdnmexp + rdndif(i,k-1)*rdirexp)*rdenom rdndif(i,k) = rdif(i,k-1) + $ (rdndif(i,k-1)*tdif(i,k-1))*(tdif(i,k-1)*rdenom) C end do end do C C Compute next layer delta-eddington solution only if total transmission C of radiation to the interface just above the layer exceeds trmin. C call whenfgt(plon,tottrn(1,k),1,trmin,index,nval) if(nval.gt.0) then CDIR$ IVDEP do 300 ii=1,nval i=index(ii) C tauray(i) = trayoslp*(pflx(i,k+1)-pflx(i,k)) taugab(i) = abh2o*uh2o(i,k) + abo3*uo3(i,k) + $ abco2*uco2(i,k) + abo2*uo2(i,k) C tautot = tauxcl(i,k) + tauxci(i,k) + $ tauray(i) + taugab(i) taucsc = tauxcl(i,k)*wcl(i,k) + tauxci(i,k)*wci(i,k) wtau = wray*tauray(i) wt = wtau + taucsc wtot = wt/tautot gtot = (wtau*gray + gcl(i,k)*wcl(i,k)*tauxcl(i,k) $ + gci(i,k)*wci(i,k)*tauxci(i,k))/wt ftot = (wtau*fray + fcl(i,k)*wcl(i,k)*tauxcl(i,k) $ + fci(i,k)*wci(i,k)*tauxci(i,k))/wt C ts = taus(wtot,ftot,tautot) ws = omgs(wtot,ftot) gs = asys(gtot,ftot) lm = el(ws,gs) alp = alpha(ws,coszrs(i),gs,lm) gam = gamma(ws,coszrs(i),gs,lm) ue = u(ws,gs,lm) C C Limit argument of exponential to 25, in case lm very large: C arg = amin1(lm*ts,25.) extins = exp(-arg) ne = n(ue,extins) C rdif(i,k) = (ue+1.)*(ue-1.)*(1./extins - extins)/ne tdif(i,k) = 4.*ue/ne C C Limit argument of exponential to 25, in case coszrs is very small: C arg = amin1(ts/coszrs(i),25.) explay(i,k) = exp(-arg) C apg = alp + gam amg = alp - gam rdir(i,k) = amg*(tdif(i,k)*explay(i,k) - 1.) + $ apg*rdif(i,k) tdir(i,k) = apg*tdif(i,k) + $ (amg*rdif(i,k) - (apg-1.))*explay(i,k) C C Under rare conditions, reflectivies and transmissivities can be C negative; zero out any negative values C rdir(i,k) = amax1(rdir(i,k),0.0) tdir(i,k) = amax1(tdir(i,k),0.0) rdif(i,k) = amax1(rdif(i,k),0.0) tdif(i,k) = amax1(tdif(i,k),0.0) 300 continue end if C 400 continue C C Compute total direct beam transmission, total transmission, and C reflectivity for diffuse radiation (from below) for all layers C above the surface: C k = plevp do nn=1,nloop do i=is(nn),ie(nn) exptdn(i,k) = exptdn(i,k-1)*explay(i,k-1) rdenom = 1./(1. - rdif(i,k-1)*rdndif(i,k-1)) rdirexp = rdir(i,k-1)*exptdn(i,k-1) tdnmexp = tottrn(i,k-1) - exptdn(i,k-1) tottrn(i,k) = exptdn(i,k-1)*tdir(i,k-1) + tdif(i,k-1)* $ (tdnmexp + rdndif(i,k-1)*rdirexp)*rdenom rdndif(i,k) = rdif(i,k-1) + $ (rdndif(i,k-1)*tdif(i,k-1))*(tdif(i,k-1)*rdenom) end do end do C return end subroutine radclr(coszrs ,trayoslp,pflx ,abh2o ,abo3 , $ abco2 ,abo2 ,uth2o ,uto3 ,utco2 , $ uto2 ,nloop ,is ,ie ,rdir , $ rdif ,tdir ,tdif ,explay ,exptdn , $ rdndif ,tottrn ) C----------------------------------------------------------------------- C C Delta-Eddington solution for special clear sky computation C C Computes total reflectivities and transmissivities for two atmospheric C layers: an overlying purely ozone absorbing layer, and the rest of the C column below. C C For more details , see Briegleb, Bruce P., 1992: Delta-Eddington C Approximation for Solar Radiation in the NCAR Community Climate Model, C Journal of Geophysical Research, Vol 97, D7, pp7603-7612). C C---------------------------Code history-------------------------------- C C Original version: B. Briegleb C Standardized: J. Rosinski, June 1992 C Reviewed: J. Kiehl, B. Briegleb, August 1992 C C----------------------------------------------------------------------- implicit none C------------------------------Parameters------------------------------- CINCLUDE param.rad include 'param.rad' C C C Basic grid point resolution parameters C integer $ plon, ! number of longitudes $ plev, ! number of vertical levels $ plat, ! number of latitudes $ pcnst, ! number of constituents (including water vapor) $ plevmx, ! number of subsurface levels $ plevp, ! plev + 1 $ nxpt, ! no.of points outside active domain for interpolant $ jintmx, ! number of extra latitudes in polar region $ plond, ! slt extended domain longitude $ platd, ! slt extended domain lat. $ plevd ! fold plev,pcnst indices into one C parameter(plon = np*mp,plev = lrad-1,plat = 1,pcnst = 1, $ plevmx = 4, $ plevp = plev + 1, $ nxpt = 1, $ jintmx = 1, $ plond = plon + 1 + 2*nxpt, $ platd = plat + 2*nxpt + 2*jintmx, $ plevd = plev*(3 + pcnst)) C C------------------------------Arguments-------------------------------- C C Input arguments C real coszrs(plond), ! Cosine zenith angle $ trayoslp, ! Tray/sslp $ pflx(plond,0:plevp), ! Interface pressure $ abh2o, ! Absorption coefficiant for h2o $ abo3 , ! Absorption coefficiant for o3 $ abco2, ! Absorption coefficiant for co2 $ abo2 , ! Absorption coefficiant for o2 $ uth2o(plond), ! Total column absorber amount of h2o $ uto3(plond), ! Total column absorber amount of o3 $ utco2(plond), ! Total column absorber amount of co2 $ uto2(plond) ! Total column absorber amount of o2 integer nloop, ! Number of loops (1 or 2) $ is(2), ! Starting index for 1 or 2 loops $ ie(2) ! Ending index for 1 or 2 loops C C Input/Output arguments C C Following variables are defined for each layer; note, we use layer 0 C to refer to the entire atmospheric column: C real rdir(plond,0:plev), ! Layer reflectivity to direct rad $ rdif(plond,0:plev), ! Layer refflectivity to diffuse rad $ tdir(plond,0:plev), ! Layer transmission to direct rad $ tdif(plond,0:plev), ! Layer transmission to diffuse rad $ explay(plond,0:plev) ! Solar beam exp transmn for layer C C Note that the following variables are defined on interfaces, with C the index k referring to the top interface of the kth layer: C exptdn,rdndif,tottrn; for example, tottrn(k=5) refers to the total C transmission to the top interface of the 5th layer. C real exptdn(plond,0:plevp), ! Solar beam exp down transmn from top $ rdndif(plond,0:plevp), ! Added dif ref for layers above $ tottrn(plond,0:plevp) ! Total transmission for layers above C external resetr, ! Resets array elements to zero $ whenfgt ! Collect indices for greater than condition C C---------------------------Local variables----------------------------- C integer i, ! Longitude index $ k, ! Level index $ nn, ! Index of longitude loops (max=nloop) $ ii, ! Longitude index $ nval, ! Number of long values satisfying criteria $ index(plond) ! Array of longitude indices C real taugab(plond), ! Total column gas absorption optical depth $ tauray(plond), ! Column rayleigh optical depth $ tautot , ! Total column optical depth $ wtot , ! Total column single scatter albedo $ gtot , ! Total column asymmetry parameter $ ftot ! Total column forward scatter fraction C C Minimum total transmission below which no layer computation are done: C real trmin, ! Minimum total transmission allowed $ wray, ! Rayleigh single scatter albedo $ gray, ! Rayleigh asymetry parameter $ fray ! Rayleigh forward scattered fraction C data trmin / 1.e-3 / data wray / 0.999999 / data gray / 0.0 / data fray / 0.1 / C real ts, ! Column scaled extinction optical depth $ ws, ! Column scaled single scattering albedo $ gs ! Column scaled asymmetry parameter C real rdenom, ! Mulitiple scattering term $ rdirexp, ! Layer direct ref times exp transmission $ tdnmexp ! Total transmission minus exp transmission C C---------------------------Statement functions------------------------- C C Statement functions for delta-Eddington solution; for detailed C explanation of individual terms, see the routine 'radded'. C real alpha,gamma,el,taus,omgs,asys,u,n,lm,ne real w,uu,g,e,f,t,et C C Intermediate terms for delta-Eddington solution C real alp,gam,ue,arg,extins,amg,apg C alpha(w,uu,g,e) = .75*w*uu*((1. + g*(1-w))/(1. - e*e*uu*uu)) gamma(w,uu,g,e) = .50*w*((3.*g*(1.-w)*uu*uu + 1.)/(1.-e*e*uu*uu)) el(w,g) = sqrt(3.*(1-w)*(1. - w*g)) taus(w,f,t) = (1. - w*f)*t omgs(w,f) = (1. - f)*w/(1. - w*f) asys(g,f) = (g - f)/(1. - f) u(w,g,e) = 1.5*(1. - w*g)/e n(uu,et) = ((uu+1.)*(uu+1.)/et ) - ((uu-1.)*(uu-1.)*et) C C----------------------------------------------------------------------- C C Initialize all total transmimission values to 0, so that nighttime C values from previous computations are not used: C call resetr(tottrn,plond*2,0.) C C Compute total direct beam transmission, total transmission, and C reflectivity for diffuse radiation (from below) for all layers C above each interface by starting from the top and adding layers C down: C C The top layer is assumed to be a purely absorbing ozone layer, and C that the mean diffusivity for diffuse transmission is 1.66: C do nn=1,nloop do i=is(nn),ie(nn) C taugab(i) = abo3*uto3(i) C C Limit argument of exponential to 25, in case coszrs is very small: C arg = amin1(taugab(i)/coszrs(i),25.) explay(i,0) = exp(-arg) tdir(i,0) = explay(i,0) C C Same limit for diffuse transmission: C arg = amin1(1.66*taugab(i),25.) tdif(i,0) = exp(-arg) C rdir(i,0) = 0.0 rdif(i,0) = 0.0 C C Initialize top interface of extra layer: C exptdn(i,0) = 1.0 rdndif(i,0) = 0.0 tottrn(i,0) = 1.0 C rdndif(i,1) = rdif(i,0) tottrn(i,1) = tdir(i,0) C end do end do C C Now, complete the rest of the column; if the total transmission C through the top ozone layer is less than trmin, then no C delta-Eddington computation for the underlying column is done: C do 200 k=1,1 C C Initialize current layer properties to zero;only if total transmission C to the top interface of the current layer exceeds the minimum, will C these values be computed below: C do nn=1,nloop do i=is(nn),ie(nn) C rdir(i,k) = 0.0 rdif(i,k) = 0.0 tdir(i,k) = 0.0 tdif(i,k) = 0.0 explay(i,k) = 0.0 C C Calculates the solar beam transmission, total transmission, and C reflectivity for diffuse radiation from below at the top of the C current layer: C exptdn(i,k) = exptdn(i,k-1)*explay(i,k-1) rdenom = 1./(1. - rdif(i,k-1)*rdndif(i,k-1)) rdirexp = rdir(i,k-1)*exptdn(i,k-1) tdnmexp = tottrn(i,k-1) - exptdn(i,k-1) tottrn(i,k) = exptdn(i,k-1)*tdir(i,k-1) + tdif(i,k-1)* $ (tdnmexp + rdndif(i,k-1)*rdirexp)*rdenom rdndif(i,k) = rdif(i,k-1) + $ (rdndif(i,k-1)*tdif(i,k-1))*(tdif(i,k-1)*rdenom) C end do end do C C Compute next layer delta-Eddington solution only if total transmission C of radiation to the interface just above the layer exceeds trmin. C call whenfgt(plon,tottrn(1,k),1,trmin,index,nval) if(nval.gt.0) then CDIR$ IVDEP do 100 ii=1,nval i=index(ii) C C Remember, no ozone absorption in this layer: C tauray(i) = trayoslp*pflx(i,plevp) taugab(i) = abh2o*uth2o(i) + $ abco2*utco2(i) + abo2*uto2(i) C tautot = tauray(i) + taugab(i) wtot = (wray*tauray(i))/tautot gtot = gray ftot = fray C ts = taus(wtot,ftot,tautot) ws = omgs(wtot,ftot) gs = asys(gtot,ftot) lm = el(ws,gs) alp = alpha(ws,coszrs(i),gs,lm) gam = gamma(ws,coszrs(i),gs,lm) ue = u(ws,gs,lm) C C Limit argument of exponential to 25, in case lm very large: C arg = amin1(lm*ts,25.) extins = exp(-arg) ne = n(ue,extins) C rdif(i,k) = (ue+1.)*(ue-1.)*(1./extins - extins)/ne tdif(i,k) = 4.*ue/ne C C Limit argument of exponential to 25, in case coszrs is very small: C arg = amin1(ts/coszrs(i),25.) explay(i,k) = exp(-arg) C apg = alp + gam amg = alp - gam rdir(i,k) = amg*(tdif(i,k)*explay(i,k) - 1.) + $ apg*rdif(i,k) tdir(i,k) = apg*tdif(i,k) + $ (amg*rdif(i,k) - (apg-1.))*explay(i,k) C C Under rare conditions, reflectivies and transmissivities can be C negative; zero out any negative values C rdir(i,k) = amax1(rdir(i,k),0.0) tdir(i,k) = amax1(tdir(i,k),0.0) rdif(i,k) = amax1(rdif(i,k),0.0) tdif(i,k) = amax1(tdif(i,k),0.0) 100 continue end if C 200 continue C C Compute total direct beam transmission, total transmission, and C reflectivity for diffuse radiation (from below) for both layers C above the surface: C k = 2 do nn=1,nloop do i=is(nn),ie(nn) exptdn(i,k) = exptdn(i,k-1)*explay(i,k-1) rdenom = 1./(1. - rdif(i,k-1)*rdndif(i,k-1)) rdirexp = rdir(i,k-1)*exptdn(i,k-1) tdnmexp = tottrn(i,k-1) - exptdn(i,k-1) tottrn(i,k) = exptdn(i,k-1)*tdir(i,k-1) + tdif(i,k-1)* $ (tdnmexp + rdndif(i,k-1)*rdirexp)*rdenom rdndif(i,k) = rdif(i,k-1) + $ (rdndif(i,k-1)*tdif(i,k-1))*(tdif(i,k-1)*rdenom) end do end do C return end subroutine wheneq(plon,ipos,i1,i2,indx,npts) c....... dummy routine for cray routine integer plon,ipos(plon),indx(plon) npts = 0 do 10 i=1,plon if( ipos(i) .eq. i2 ) then npts = npts + 1 indx(npts) = i endif 10 continue return end subroutine whenne(plon,ipos,i1,i2,indx,npts) c....... dummy routine for cray routine integer plon,ipos(plon),indx(plon) npts = 0 do 10 i=1,plon if( ipos(i) .ne. i2 ) then npts = npts + 1 indx(npts) = i endif 10 continue return end subroutine whenfgt(nmbr,tin,len,tmin,index,nval) c c....... dummy routine for cray routine c dimension tin(nmbr),index(nmbr) nval = 0 index(1) = 0 do 100 n=1,nmbr if( tin(n) .gt. tmin ) then nval = nval + 1 index(nval) = n endif 100 continue return end subroutine whenflt(nmbr,tin,len,tmin,index,nval) c c....... dummy routine for cray routine c dimension tin(nmbr),index(nmbr) nval = 0 index(1) = 0 do 100 n=1,nmbr if( tin(n) .lt. tmin ) then nval = nval + 1 index(nval) = n endif 100 continue return end integer function isrchfgt(number,array,indx,value) c c search for first array element in array (up to number c of elements), starting with index indx, that is greater c than value; if not found, set to number+1; otherwise, index c real array(number) c isrchfgt = 0 do 100 n=1,number if( array(indx+n-1) .gt. value ) then isrchfgt = indx+n-1 goto 101 endif 100 continue 101 if( isrchfgt .eq. 0 ) then isrchfgt = number + 1 endif return end integer function isrchfle(number,array,indx,value) c c search for first array element in array (up to number c of elements), starting with index indx, that is greater c than value; if not found, set to zero; otherwise, index c real array(number) c isrchfle = 0 do 100 n=1,number if( array(indx+n-1) .gt. value ) then isrchfle = indx+n-1 goto 101 endif 100 continue 101 if( isrchfle .eq. 0 ) then isrchfle = number + 1 endif return end subroutine resetr(a,length,val) dimension a(1) do 10 n=1,length a(n) = val 10 continue return end subroutine writeric(nabem,absems,lngbuf,nrow) c c........ dummy routine for write of ab/em data c return end subroutine readric(nabem,absems,lngbuf,nrow) c c........ dummy routine for read of ab/em data c return end '\eof' echo CREATE_CFFTPACK.F cat > cfftpack.f<< '\eof' SUBROUTINE CFFTF (N,C,WSAVE) C C SUBROUTINE CFFTF COMPUTES THE FORWARD COMPLEX DISCRETE FOURIER C TRANSFORM (THE FOURIER ANALYSIS). EQUIVALENTLY , CFFTF COMPUTES C THE FOURIER COEFFICIENTS OF A COMPLEX PERIODIC SEQUENCE. C THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C. C C THE TRANSFORM IS NOT NORMALIZED. TO OBTAIN A NORMALIZED TRANSFORM C THE OUTPUT MUST BE DIVIDED BY N. OTHERWISE A CALL OF CFFTF C FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE SEQUENCE BY N. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTF MUST BE C INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE). C C INPUT PARAMETERS C C C N THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS C MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. N C C C A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE C C WSAVE A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15 C IN THE PROGRAM THAT CALLS CFFTF. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB. C C OUTPUT PARAMETERS C C C FOR J=1,...,N C C C(J)=THE SUM FROM K=1,...,N OF C C C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N) C C WHERE I=SQRT(-1) C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE C DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB C DIMENSION C(*) ,WSAVE(*) C IF (N .EQ. 1) RETURN IW1 = N+N+1 IW2 = IW1+N+N CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) RETURN END C SUBROUTINE CFFTF1 (N,C,CH,WA,IFAC) DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDOT = IDO+IDO IDL1 = IDOT*L1 IF (IP .NE. 4) GO TO 103 IX2 = IW+IDOT IX3 = IX2+IDOT IF (NA .NE. 0) GO TO 101 CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 102 101 CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA GO TO 115 103 IF (IP .NE. 2) GO TO 106 IF (NA .NE. 0) GO TO 104 CALL PASSF2 (IDOT,L1,C,CH,WA(IW)) GO TO 105 104 CALL PASSF2 (IDOT,L1,CH,C,WA(IW)) 105 NA = 1-NA GO TO 115 106 IF (IP .NE. 3) GO TO 109 IX2 = IW+IDOT IF (NA .NE. 0) GO TO 107 CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) GO TO 108 107 CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA GO TO 115 109 IF (IP .NE. 5) GO TO 112 IX2 = IW+IDOT IX3 = IX2+IDOT IX4 = IX3+IDOT IF (NA .NE. 0) GO TO 110 CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 111 110 CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA GO TO 115 112 IF (NA .NE. 0) GO TO 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) GO TO 114 113 CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 IF (NAC .NE. 0) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDOT 116 CONTINUE IF (NA .EQ. 0) RETURN N2 = N+N DO 117 I=1,N2 C(I) = CH(I) 117 CONTINUE RETURN END C SUBROUTINE CFFTI (N,WSAVE) C C SUBROUTINE CFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN C BOTH CFFTF AND CFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND C STORED IN WSAVE. C C INPUT PARAMETER C C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED C C OUTPUT PARAMETER C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4*N+15 C THE SAME WORK ARRAY CAN BE USED FOR BOTH CFFTF AND CFFTB C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS C ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF C WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF CFFTF OR CFFTB. C DIMENSION WSAVE(*) C IF (N .EQ. 1) RETURN IW1 = N+N+1 IW2 = IW1+N+N CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2)) RETURN END C SUBROUTINE CFFTI1 (N,WA,IFAC) DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/ DATA TWOPI/6.2831853071795864769252867665590D0/ NL = N NF = 0 J = 0 101 J = J+1 IF (J-4) 102,102,103 102 NTRY = NTRYH(J) GO TO 104 103 NTRY = NTRY+2 104 NQ = NL/NTRY NR = NL-NTRY*NQ IF (NR) 101,105,101 105 NF = NF+1 IFAC(NF+2) = NTRY NL = NQ IF (NTRY .NE. 2) GO TO 107 IF (NF .EQ. 1) GO TO 107 DO 106 I=2,NF IB = NF-I+2 IFAC(IB+2) = IFAC(IB+1) 106 CONTINUE IFAC(3) = 2 107 IF (NL .NE. 1) GO TO 104 IFAC(1) = N IFAC(2) = NF ARGH = TWOPI/FLOAT(N) I = 2 L1 = 1 DO 110 K1=1,NF IP = IFAC(K1+2) LD = 0 L2 = L1*IP IDO = N/L2 IDOT = IDO+IDO+2 IPM = IP-1 DO 109 J=1,IPM I1 = I WA(I-1) = 1. WA(I) = 0. LD = LD+L1 FI = 0. ARGLD = FLOAT(LD)*ARGH DO 108 II=4,IDOT,2 I = I+2 FI = FI+1. ARG = FI*ARGLD WA(I-1) = COS(ARG) WA(I) = SIN(ARG) 108 CONTINUE IF (IP .LE. 5) GO TO 109 WA(I1-1) = WA(I-1) WA(I1) = WA(I) 109 CONTINUE L1 = L2 110 CONTINUE RETURN END C SUBROUTINE PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), 2 CH2(IDL1,IP) IDOT = IDO/2 NT = IP*IDL1 IPP2 = IP+2 IPPH = (IP+1)/2 IDP = IP*IDO C IF (IDO .LT. L1) GO TO 106 DO 103 J=2,IPPH JC = IPP2-J DO 102 K=1,L1 DO 101 I=1,IDO CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 101 CONTINUE 102 CONTINUE 103 CONTINUE DO 105 K=1,L1 DO 104 I=1,IDO CH(I,K,1) = CC(I,1,K) 104 CONTINUE 105 CONTINUE GO TO 112 106 DO 109 J=2,IPPH JC = IPP2-J DO 108 I=1,IDO DO 107 K=1,L1 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 107 CONTINUE 108 CONTINUE 109 CONTINUE DO 111 I=1,IDO DO 110 K=1,L1 CH(I,K,1) = CC(I,1,K) 110 CONTINUE 111 CONTINUE 112 IDL = 2-IDO INC = 0 DO 116 L=2,IPPH LC = IPP2-L IDL = IDL+IDO DO 113 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) C2(IK,LC) = -WA(IDL)*CH2(IK,IP) 113 CONTINUE IDLJ = IDL INC = INC+IDO DO 115 J=3,IPPH JC = IPP2-J IDLJ = IDLJ+INC IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP WAR = WA(IDLJ-1) WAI = WA(IDLJ) DO 114 IK=1,IDL1 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC) 114 CONTINUE 115 CONTINUE 116 CONTINUE DO 118 J=2,IPPH DO 117 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 117 CONTINUE 118 CONTINUE DO 120 J=2,IPPH JC = IPP2-J DO 119 IK=2,IDL1,2 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 119 CONTINUE 120 CONTINUE NAC = 1 IF (IDO .EQ. 2) RETURN NAC = 0 DO 121 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 121 CONTINUE DO 123 J=2,IP DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J) C1(2,K,J) = CH(2,K,J) 122 CONTINUE 123 CONTINUE IF (IDOT .GT. L1) GO TO 127 IDIJ = 0 DO 126 J=2,IP IDIJ = IDIJ+2 DO 125 I=4,IDO,2 IDIJ = IDIJ+2 DO 124 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 124 CONTINUE 125 CONTINUE 126 CONTINUE RETURN 127 IDJ = 2-IDO DO 130 J=2,IP IDJ = IDJ+IDO DO 129 K=1,L1 IDIJ = IDJ DO 128 I=4,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J) 128 CONTINUE 129 CONTINUE 130 CONTINUE RETURN END C SUBROUTINE PASSF2 (IDO,L1,CC,CH,WA1) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , 1 WA1(*) IF (IDO .GT. 2) GO TO 102 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(1,2,K) CH(1,K,2) = CC(1,1,K)-CC(1,2,K) CH(2,K,1) = CC(2,1,K)+CC(2,2,K) CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 101 CONTINUE RETURN 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2 103 CONTINUE 104 CONTINUE RETURN END C SUBROUTINE PASSF3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , 1 WA1(*) ,WA2(*) DATA TAUR,TAUI /-.5,-.866025403784439/ IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TR2 = CC(1,2,K)+CC(1,3,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 TI2 = CC(2,2,K)+CC(2,3,K) CI2 = CC(2,1,K)+TAUR*TI2 CH(2,K,1) = CC(2,1,K)+TI2 CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 CH(2,K,2) = CI2+CR3 CH(2,K,3) = CI2-CR3 101 CONTINUE RETURN 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 103 CONTINUE 104 CONTINUE RETURN END C SUBROUTINE PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , 1 WA1(*) ,WA2(*) ,WA3(*) IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TI1 = CC(2,1,K)-CC(2,3,K) TI2 = CC(2,1,K)+CC(2,3,K) TR4 = CC(2,2,K)-CC(2,4,K) TI3 = CC(2,2,K)+CC(2,4,K) TR1 = CC(1,1,K)-CC(1,3,K) TR2 = CC(1,1,K)+CC(1,3,K) TI4 = CC(1,4,K)-CC(1,2,K) TR3 = CC(1,2,K)+CC(1,4,K) CH(1,K,1) = TR2+TR3 CH(1,K,3) = TR2-TR3 CH(2,K,1) = TI2+TI3 CH(2,K,3) = TI2-TI3 CH(1,K,2) = TR1+TR4 CH(1,K,4) = TR1-TR4 CH(2,K,2) = TI1+TI4 CH(2,K,4) = TI1-TI4 101 CONTINUE RETURN 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,2,K)-CC(I,4,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,4,K)-CC(I-1,2,K) TR3 = CC(I-1,2,K)+CC(I-1,4,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1+TR4 CR4 = TR1-TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4 103 CONTINUE 104 CONTINUE RETURN END C. SUBROUTINE PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) DATA TR11,TI11,TR12,TI12 /.309016994374947,-.951056516295154, 1-.809016994374947,-.587785252292473/ IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TI5 = CC(2,2,K)-CC(2,5,K) TI2 = CC(2,2,K)+CC(2,5,K) TI4 = CC(2,3,K)-CC(2,4,K) TI3 = CC(2,3,K)+CC(2,4,K) TR5 = CC(1,2,K)-CC(1,5,K) TR2 = CC(1,2,K)+CC(1,5,K) TR4 = CC(1,3,K)-CC(1,4,K) TR3 = CC(1,3,K)+CC(1,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CH(2,K,1) = CC(2,1,K)+TI2+TI3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,5) = CR2+CI5 CH(2,K,2) = CI2+CR5 CH(2,K,3) = CI3+CR4 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(2,K,4) = CI3-CR4 CH(2,K,5) = CI2-CR5 101 CONTINUE RETURN 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5 103 CONTINUE 104 CONTINUE RETURN END C SUBROUTINE CFFTB (N,C,WSAVE) C C SUBROUTINE CFFTB COMPUTES THE BACKWARD COMPLEX DISCRETE FOURIER C TRANSFORM (THE FOURIER SYNTHESIS). EQUIVALENTLY , CFFTB COMPUTES C A COMPLEX PERIODIC SEQUENCE FROM ITS FOURIER COEFFICIENTS. C THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C. C C A CALL OF CFFTF FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE C SEQUENCE BY N. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTB MUST BE C INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE). C C INPUT PARAMETERS C C C N THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS C MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. C C C A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE C C WSAVE A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15 C IN THE PROGRAM THAT CALLS CFFTB. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB. C C OUTPUT PARAMETERS C C C FOR J=1,...,N C C C(J)=THE SUM FROM K=1,...,N OF C C C(K)*EXP(I*(J-1)*(K-1)*2*PI/N) C C WHERE I=SQRT(-1) C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE C DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB C DIMENSION C(*) ,WSAVE(*) C IF (N .EQ. 1) RETURN IW1 = N+N+1 IW2 = IW1+N+N CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2)) RETURN END C SUBROUTINE CFFTB1 (N,C,CH,WA,IFAC) DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDOT = IDO+IDO IDL1 = IDOT*L1 IF (IP .NE. 4) GO TO 103 IX2 = IW+IDOT IX3 = IX2+IDOT IF (NA .NE. 0) GO TO 101 CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 102 101 CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA GO TO 115 103 IF (IP .NE. 2) GO TO 106 IF (NA .NE. 0) GO TO 104 CALL PASSB2 (IDOT,L1,C,CH,WA(IW)) GO TO 105 104 CALL PASSB2 (IDOT,L1,CH,C,WA(IW)) 105 NA = 1-NA GO TO 115 106 IF (IP .NE. 3) GO TO 109 IX2 = IW+IDOT IF (NA .NE. 0) GO TO 107 CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2)) GO TO 108 107 CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA GO TO 115 109 IF (IP .NE. 5) GO TO 112 IX2 = IW+IDOT IX3 = IX2+IDOT IX4 = IX3+IDOT IF (NA .NE. 0) GO TO 110 CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 111 110 CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA GO TO 115 112 IF (NA .NE. 0) GO TO 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) GO TO 114 113 CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 IF (NAC .NE. 0) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDOT 116 CONTINUE IF (NA .EQ. 0) RETURN N2 = N+N DO 117 I=1,N2 C(I) = CH(I) 117 CONTINUE RETURN END C SUBROUTINE PASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,WA(*) ,C2(IDL1,IP), 2 CH2(IDL1,IP) IDOT = IDO/2 NT = IP*IDL1 IPP2 = IP+2 IPPH = (IP+1)/2 IDP = IP*IDO C IF (IDO .LT. L1) GO TO 106 DO 103 J=2,IPPH JC = IPP2-J DO 102 K=1,L1 DO 101 I=1,IDO CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 101 CONTINUE 102 CONTINUE 103 CONTINUE DO 105 K=1,L1 DO 104 I=1,IDO CH(I,K,1) = CC(I,1,K) 104 CONTINUE 105 CONTINUE GO TO 112 106 DO 109 J=2,IPPH JC = IPP2-J DO 108 I=1,IDO DO 107 K=1,L1 CH(I,K,J) = CC(I,J,K)+CC(I,JC,K) CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K) 107 CONTINUE 108 CONTINUE 109 CONTINUE DO 111 I=1,IDO DO 110 K=1,L1 CH(I,K,1) = CC(I,1,K) 110 CONTINUE 111 CONTINUE 112 IDL = 2-IDO INC = 0 DO 116 L=2,IPPH LC = IPP2-L IDL = IDL+IDO DO 113 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2) C2(IK,LC) = WA(IDL)*CH2(IK,IP) 113 CONTINUE IDLJ = IDL INC = INC+IDO DO 115 J=3,IPPH JC = IPP2-J IDLJ = IDLJ+INC IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP WAR = WA(IDLJ-1) WAI = WA(IDLJ) DO 114 IK=1,IDL1 C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J) C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC) 114 CONTINUE 115 CONTINUE 116 CONTINUE DO 118 J=2,IPPH DO 117 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 117 CONTINUE 118 CONTINUE DO 120 J=2,IPPH JC = IPP2-J DO 119 IK=2,IDL1,2 CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC) CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC) CH2(IK,J) = C2(IK,J)+C2(IK-1,JC) CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC) 119 CONTINUE 120 CONTINUE NAC = 1 IF (IDO .EQ. 2) RETURN NAC = 0 DO 121 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 121 CONTINUE DO 123 J=2,IP DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J) C1(2,K,J) = CH(2,K,J) 122 CONTINUE 123 CONTINUE IF (IDOT .GT. L1) GO TO 127 IDIJ = 0 DO 126 J=2,IP IDIJ = IDIJ+2 DO 125 I=4,IDO,2 IDIJ = IDIJ+2 DO 124 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 124 CONTINUE 125 CONTINUE 126 CONTINUE RETURN 127 IDJ = 2-IDO DO 130 J=2,IP IDJ = IDJ+IDO DO 129 K=1,L1 IDIJ = IDJ DO 128 I=4,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 128 CONTINUE 129 CONTINUE 130 CONTINUE RETURN END C SUBROUTINE PASSB2 (IDO,L1,CC,CH,WA1) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , 1 WA1(1) IF (IDO .GT. 2) GO TO 102 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(1,2,K) CH(1,K,2) = CC(1,1,K)-CC(1,2,K) CH(2,K,1) = CC(2,1,K)+CC(2,2,K) CH(2,K,2) = CC(2,1,K)-CC(2,2,K) 101 CONTINUE RETURN 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K) TR2 = CC(I-1,1,K)-CC(I-1,2,K) CH(I,K,1) = CC(I,1,K)+CC(I,2,K) TI2 = CC(I,1,K)-CC(I,2,K) CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2 CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2 103 CONTINUE 104 CONTINUE RETURN END C SUBROUTINE PASSB3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , 1 WA1(*) ,WA2(*) DATA TAUR,TAUI /-.5,.866025403784439/ IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TR2 = CC(1,2,K)+CC(1,3,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 TI2 = CC(2,2,K)+CC(2,3,K) CI2 = CC(2,1,K)+TAUR*TI2 CH(2,K,1) = CC(2,1,K)+TI2 CR3 = TAUI*(CC(1,2,K)-CC(1,3,K)) CI3 = TAUI*(CC(2,2,K)-CC(2,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 CH(2,K,2) = CI2+CR3 CH(2,K,3) = CI2-CR3 101 CONTINUE RETURN 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TR2 = CC(I-1,2,K)+CC(I-1,3,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,2,K)+CC(I,3,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K)) CI3 = TAUI*(CC(I,2,K)-CC(I,3,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 103 CONTINUE 104 CONTINUE RETURN END C SUBROUTINE PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , 1 WA1(*) ,WA2(*) ,WA3(*) IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TI1 = CC(2,1,K)-CC(2,3,K) TI2 = CC(2,1,K)+CC(2,3,K) TR4 = CC(2,4,K)-CC(2,2,K) TI3 = CC(2,2,K)+CC(2,4,K) TR1 = CC(1,1,K)-CC(1,3,K) TR2 = CC(1,1,K)+CC(1,3,K) TI4 = CC(1,2,K)-CC(1,4,K) TR3 = CC(1,2,K)+CC(1,4,K) CH(1,K,1) = TR2+TR3 CH(1,K,3) = TR2-TR3 CH(2,K,1) = TI2+TI3 CH(2,K,3) = TI2-TI3 CH(1,K,2) = TR1+TR4 CH(1,K,4) = TR1-TR4 CH(2,K,2) = TI1+TI4 CH(2,K,4) = TI1-TI4 101 CONTINUE RETURN 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI1 = CC(I,1,K)-CC(I,3,K) TI2 = CC(I,1,K)+CC(I,3,K) TI3 = CC(I,2,K)+CC(I,4,K) TR4 = CC(I,4,K)-CC(I,2,K) TR1 = CC(I-1,1,K)-CC(I-1,3,K) TR2 = CC(I-1,1,K)+CC(I-1,3,K) TI4 = CC(I-1,2,K)-CC(I-1,4,K) TR3 = CC(I-1,2,K)+CC(I-1,4,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1+TR4 CR4 = TR1-TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2 CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2 CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4 CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4 103 CONTINUE 104 CONTINUE RETURN END C SUBROUTINE PASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, 1-.809016994374947,.587785252292473/ IF (IDO .NE. 2) GO TO 102 DO 101 K=1,L1 TI5 = CC(2,2,K)-CC(2,5,K) TI2 = CC(2,2,K)+CC(2,5,K) TI4 = CC(2,3,K)-CC(2,4,K) TI3 = CC(2,3,K)+CC(2,4,K) TR5 = CC(1,2,K)-CC(1,5,K) TR2 = CC(1,2,K)+CC(1,5,K) TR4 = CC(1,3,K)-CC(1,4,K) TR3 = CC(1,3,K)+CC(1,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CH(2,K,1) = CC(2,1,K)+TI2+TI3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,5) = CR2+CI5 CH(2,K,2) = CI2+CR5 CH(2,K,3) = CI3+CR4 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(2,K,4) = CI3-CR4 CH(2,K,5) = CI2-CR5 101 CONTINUE RETURN 102 DO 104 K=1,L1 DO 103 I=2,IDO,2 TI5 = CC(I,2,K)-CC(I,5,K) TI2 = CC(I,2,K)+CC(I,5,K) TI4 = CC(I,3,K)-CC(I,4,K) TI3 = CC(I,3,K)+CC(I,4,K) TR5 = CC(I-1,2,K)-CC(I-1,5,K) TR2 = CC(I-1,2,K)+CC(I-1,5,K) TR4 = CC(I-1,3,K)-CC(I-1,4,K) TR3 = CC(I-1,3,K)+CC(I-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2 CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2 CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3 CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3 CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4 CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4 CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5 CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5 103 CONTINUE 104 CONTINUE RETURN END C SUBROUTINE FOURT (DATA,N,NDIM,ISIGN,IFORM,WORK,NWORK) C C COOLEY-TUKEY FAST FOURIER TRANSFORM IN USASI BASIC FORTRAN. C MULTI-DIMENSIONAL TRANSFORM, DIMENSIONS OF ARBITRARY SIZE, C COMPLEX OR REAL DATA. N POINTS CAN BE TRANSFORMED IN TIME C PROPORTIONAL TO N*LOG(N), WHEREAS OTHER METHODS TAKE N**2 TIME. C FURTHERMORE, LESS ERROR IS BUILT UP. WRITTEN BY NORMAN BRENNER C OF MIT LINCOLN LABORATORY, JUNE 1968. C C DIMENSION DATA(N(1),N(2),...),TRANSFORM(N(1),N(2),...),N(NDIM) C TRANSFORM(K1,K2,...) = SUM(DATA(J1,J2,...)*EXP(ISIGN*2*PI*SQRT(-1) C *((J1-1)*(K1-1)/N(1)+(J2-1)*(K2-1)/N(2)+...))), SUMMED FOR ALL C J1 AND K1 FROM 1 TO N(1), J2 AND K2 FROM 1 TO N(2), ETC. FOR ALL C NDIM SUBSCRIPTS. NDIM MUST BE POSITIVE AND EACH N(IDIM) MAY BE C ANY INTEGER. ISIGN IS +1 OR -1. LET NTOT = N(1)*N(2)... C ...*N(NDIM). THEN A -1 TRANSFORM FOLLOWED BY A +1 ONE C (OR VICE VERSA) RETURNS NTOT TIMES THE ORIGINAL DATA. C IFORM = 1, 0 OR -1, AS DATA IS COMPLEX, REAL OR THE C FIRST HALF OF A COMPLEX ARRAY. TRANSFORM VALUES ARE C RETURNED TO ARRAY DATA. THEY ARE COMPLEX, REAL OR C THE FIRST HALF OF A COMPLEX ARRAY, AS IFORM = 1, -1 OR 0. C THE TRANSFORM OF A REAL ARRAY (IFORM = 0) DIMENSIONED N(1) BY N(2) C BY ... WILL BE RETURNED IN THE SAME ARRAY, NOW CONSIDERED TO C BE COMPLEX OF DIMENSIONS N(1)/2+1 BY N(2) BY .... NOTE THAT IF C IFORM = 0 OR -1, N(1) MUST BE EVEN, AND ENOUGH ROOM MUST BE C RESERVED. THE MISSING VALUES MAY BE OBTAINED BY COMPLEX CONJU- C GATION. THE REVERSE TRANSFORMATION, OF A HALF COMPLEX ARRAY C DIMENSIONED N(1)/2+1 BY N(2) BY ..., IS ACCOMPLISHED SETTING IFORM C TO -1. IN THE N ARRAY, N(1) MUST BE THE TRUE N(1), NOT N(1)/2+1. C THE TRANSFORM WILL BE REAL AND RETURNED TO THE INPUT ARRAY. C WORK IS A ONE-DIMENSIONAL COMPLEX ARRAY USED FOR WORKING STORAGE. C ITS LENGTH, NWORK, NEED NEVER BE LARGER THAN THE LARGEST N(IDIM) C AND FREQUENTLY MAY BE MUCH SMALLER. FOURT COMPUTES THE MINIMUM C LENGTH WORKING STORAGE REQUIRED AND CHECKS THAT NWORK IS AT LEAST C AS LONG. THIS MINIMUM LENGTH IS CCOMPUTED AS SHOWN BELOW. C C FOR EXAMPLE-- C DIMENSION DATA(1960),WORK(10) C COMPLEX DATA,WORK C CALL FOURT(DATA,1960,1,-1,+1,WORK,10) C C THE MULTI-DIMENSIONAL TRANSFORM IS BROKEN DOWN INTO ONE-DIMEN- C SIONAL TRANSFORMS OF LENGTH N(IDIM). THESE ARE FURTHER BROKEN C DOWN INTO TRANSFORMS OF LENGTH IFACT(IF), WHERE THESE ARE THE C PRIME FACTORS OF N(IDIM). FOR EXAMPLE, N(1) = 1960, IFACT(IF) = C 2, 2, 2, 5, 7 AND 7. THE RUNNING TIME IS PROPORTIONAL TO NTOT * C SUM(IFACT(IF)), THOUGH FACTORS OF TWO AND THREE WILL RUN ESPE- C CIALLY FAST. NAIVE TRANSFORM PROGRAMS WILL RUN IN TIME NTOT**2. C ARRAYS WHOSE SIZE NTOT IS PRIME WILL RUN MUCH SLOWER THAN THOSE C WITH COMPOSITE NTOT. FOR EXAMPLE, NTOT = N(1) = 1951 (A PRIME), C RUNNING TIME WILL BE 1951*1951, WHILE FOR NTOT = 1960, IT WILL C BE 1960*(2+2+2+5+7+7), A SPEEDUP OF EIGHTY TIMES. NAIVE CALCUL- C ATION WILL RUN BOTH IN THE SLOWER TIME. IF AN ARRAY IS OF C INCONVENIENT LENGTH, SIMPLY ADD ZEROES TO PAD IT OUT. THE RESULTS C WILL BE INTERPOLATED ACCORDING TO THE NEW LENGTH (SEE BELOW). C C A FOURIER TRANSFORM OF LENGTH IFACT(IF) REQUIRES A WORK ARRAY C OF THAT LENGTH. THEREFORE, NWORK MUST BE AS BIG AS THE LARGEST C PRIME FACTOR. FURTHER, WORK IS NEEDED FOR DIGIT REVERSAL-- C EACH N(IDIM) (BUT N(1)/2 IF IFORM = 0 OR -1) IS FACTORED SYMMETRI- C CALLY, AND NWORK MUST BE AS BIG AS THE CENTER FACTOR. (TO FACTOR C SYMMETRICALLY, SEPARATE PAIRS OF IDENTICAL FACTORS TO THE FLANKS, C COMBINING ALL LEFTOVERS IN THE CENTER.) FOR EXAMPLE, N(1) = 1960 C =2*2*2*5*7*7=2*7*10*7*2, SO NWORK MUST AT LEAST MAX(7,10) = 10. C C AN UPPER BOUND FOR THE RMS RELATIVE ERROR IS GIVEN BY GENTLEMAN C AND SANDE (3)-- 3 * 2**(-B) * SUM(F**1.5), WHERE 2**(-B) IS THE C SMALLEST BIT IN THE FLOATING POINT FRACTION AND THE SUM IS OVER C THE PRIME FACTORS OF NTOT. C C IF THE INPUT DATA ARE A TIME SERIES, WITH INDEX J REPRESENTING C A TIME (J-1)*DELTAT, THEN THE CORRESPONDING INDEX K IN THE C TRANSFORM REPRESENTS THE FREQUENCY (K-1)*2*PI/(N*DELTAT), WHICH C BY PERIODICITY, IS THE SAME AS FREQUENCY -(N-K+1)*2*PI/(N*DELTAT). C THIS IS TRUE FOR N = EACH N(IDIM) INDEPENDENTLY. C C REFERENCES-- C 1. COOLEY, J.W. AND TUKEY, J.W., AN ALGORITHM FOR THE MACHINE C CALCULATION OF COMPLEX FOURIER SERIES. MATH. COMP., 19, 90, C (APRIL 1967), 297-301. C 2. RADER, C., ET AL., WHAT IS THE FAST FOURIER TRANSFORM, IEEE C TRANSACTIONS ON AUDIO AND ELECTROACOUSTICS, AU-15, 2 (JUNE 1967). C (SPECIAL ISSUE ON THE FAST FOURIER TRANSFORM AND ITS APPLICATIONS) C 3. GENTLEMAN, W.M. AND SANDE, G., FAST FOURIER TRANSFORMS-- C FOR FUN AND PROFIT. 1966 FALL JOINT COMP. CONF., SPARTAN BOOKS, C WASHINGTON, 1966. C 4. GOERTZEL, G., AN ALGORITHM FOR THE EVALUATION OF FINITE C TRIGONOMETRIC SERIES. AM. MATH. MO., 65, (1958), 34-35. C 5. SINGLETON, R.C., A METHOD FOR COMPUTING THE FAST FOURIER C TRANSFORM WITH AUXILIARY MEMORY AND LIMITED HIGH-SPEED STORAGE. C IN (2). DIMENSION DATA(1), N(1), WORK(1), IFSYM(32), IFCNT(10), IFACT(32) IF (IFORM) 10,10,40 10 IF (N(1)-2*(N(1)/2)) 20,40,20 C20 WRITE (6,30) IFORM,(N(IDIM),IDIM=1,NDIM) 20 STOP 99 C30 FORMAT (26H0ERROR IN FOURT. IFORM = ,I2,23H (REAL OR HALF-COMPLEX C .)23H, BUT N(1) IS NOT EVEN./14H DIMENSIONS = 20I5) 40 NTOT=1 DO 50 IDIM=1,NDIM 50 NTOT=NTOT*N(IDIM) NREM=NTOT IF (IFORM) 60,70,70 60 NREM=1 NTOT=(NTOT/N(1))*(N(1)/2+1) C LOOP OVER ALL DIMENSIONS. 70 DO 230 JDIM=1,NDIM IF (IFORM) 80,90,90 80 IDIM=NDIM+1-JDIM GO TO 100 90 IDIM=JDIM NREM=NREM/N(IDIM) 100 NCURR=N(IDIM) IF (IDIM-1) 110,110,140 110 IF (IFORM) 120,130,140 120 CALL FIXRL (DATA,N(1),NREM,ISIGN,IFORM) NTOT=(NTOT/(N(1)/2+1))*N(1) 130 NCURR=NCURR/2 140 IF (NCURR-1) 190,190,150 C FACTOR N(IDIM), THE LENGTH OF THIS DIMENSION. 150 CALL FACTR (NCURR,IFACT,NFACT) IFMAX=IFACT(NFACT) C ARRANGE THE FACTORS SYMMETRICALLY FOR SIMPLER DIGIT REVERSAL. CALL SMFAC (IFACT,NFACT,ISYM,IFSYM,NFSYM,ICENT,IFCNT,NFCNT) IFMAX=MAX0(IFMAX,ICENT) IF (IFMAX-NWORK) 180,180,160 C 160 WRITE (6,170) NWORK,IDIM,NCURR,ICENT,(IFACT(IF),IF=1,NFACT) 160 STOP 999 C 170 FORMAT (26H0ERROR IN FOURT. NWORK = ,I4,20H IS TOO SMALL FOR N(, C .I1,4H) = ,I5,17H, WHOSE CENTER = ,I4,31H, AND WHOSE PRIME FACTORS C .ARE--/(1X,20I5)) 180 NPREV=NTOT/(N(IDIM)*NREM) C DIGIT REVERSE ON SYMMETRIC FACTORS, FOR EXAMPLE 2*7*6*7*2. CALL SYMRV (DATA,NPREV,NCURR,NREM,IFSYM,NFSYM) C DIGIT REVERSE THE ASYMMETRIC CENTER, FOR EXAMPLE, ON 6 = 2*3. CALL ASMRV (DATA,NPREV*ISYM,ICENT,ISYM*NREM,IFCNT,NFCNT,WORK) C FOURIER TRANSFORM ON EACH FACTOR, FOR EXAMPLE, ON 2,7,2,3,7 AND 2. CALL COOL (DATA,NPREV,NCURR,NREM,ISIGN,IFACT,WORK) 190 IF (IFORM) 200,210,230 200 NREM=NREM*N(IDIM) GO TO 230 210 IF (IDIM-1) 220,220,230 220 CALL FIXRL (DATA,N(1),NREM,ISIGN,IFORM) NTOT=NTOT/N(1)*(N(1)/2+1) 230 CONTINUE RETURN END C SUBROUTINE FACTR (N,IFACT,NFACT) C FACTOR N INTO ITS PRIME FACTORS, NFACT IN NUMBER. FOR EXAMPLE, C FOR N = 1960, NFACT = 6 AND IFACT(IF) = 2, 2, 2, 5, 7 AND 7. DIMENSION IFACT(1) IF=0 NPART=N DO 50 ID=1,N,2 IDIV=ID IF (ID-1) 10,10,20 10 IDIV=2 20 IQUOT=NPART/IDIV IF (NPART-IDIV*IQUOT) 40,30,40 30 IF=IF+1 IFACT(IF)=IDIV NPART=IQUOT GO TO 20 40 IF (IQUOT-IDIV) 60,60,50 50 CONTINUE 60 IF (NPART-1) 80,80,70 70 IF=IF+1 IFACT(IF)=NPART 80 NFACT=IF RETURN END C SUBROUTINE SMFAC (IFACT,NFACT,ISYM,IFSYM,NFSYM,ICENT,IFCNT,NFCNT) C REARRANGE THE PRIME FACTORS OF N INTO A SQUARE AND A NON- C SQUARE. N = ISYM*ICENT*ISYM, WHERE ICENT IS SQUARE-FREE. C ISYM = IFSYM(1)*...*IFSYM(NFSYM), EACH A PRIME FACTOR. C ICENT = IFCNT(1)*...*IFCNT(NFCNT), EACH A PRIME FACTOR. C FOR EXAMPLE, N = 1960 = 14*10*14. THEN ISYM = 14, ICENT = 10, C NFSYM = 2, NFCNT = 2, NFACT = 6, IFSYM(IFS) = 2, 7, IFCNT(IFC) = C 2, 5 AND IFACT(IF) = 2, 7, 2, 5, 7, 2. DIMENSION IFSYM(1), IFCNT(1), IFACT(1) ISYM=1 ICENT=1 IFS=0 IFC=0 IF=1 10 IF (IF-NFACT) 20,40,50 20 IF (IFACT(IF)-IFACT(IF+1)) 40,30,40 30 IFS=IFS+1 IFSYM(IFS)=IFACT(IF) ISYM=IFACT(IF)*ISYM IF=IF+2 GO TO 10 40 IFC=IFC+1 IFCNT(IFC)=IFACT(IF) ICENT=IFACT(IF)*ICENT IF=IF+1 GO TO 10 50 NFSYM=IFS NFCNT=IFC NFSM2=2*NFSYM NFACT=2*NFSYM+NFCNT IF (NFCNT) 80,80,60 60 NFSM2=NFSM2+1 IFSYM(NFSYM+1)=ICENT DO 70 IFC=1,NFCNT IF=NFSYM+IFC 70 IFACT(IF)=IFCNT(IFC) 80 IF (NFSYM) 110,110,90 90 DO 100 IFS=1,NFSYM IFSCJ=NFSM2+1-IFS IFSYM(IFSCJ)=IFSYM(IFS) IFACT(IFS)=IFSYM(IFS) IFCNJ=NFACT+1-IFS 100 IFACT(IFCNJ)=IFSYM(IFS) 110 NFSYM=NFSM2 RETURN END C SUBROUTINE SYMRV (DATA,NPREV,N,NREM,IFACT,NFACT) C SHUFFLE THE DATA ARRAY BY REVERSING THE DIGITS OF ONE INDEX. C DIMENSION DATA(NPREV,N,NREM) C REPLACE DATA(I1,I2,I3) BY DATA(I1,I2REV,I3) FOR ALL I1 FROM 1 TO C NPREV, I2 FROM 1 TO N AND I3 FROM 1 TO NREM. I2REV-1 IS THE C INTEGER WHOSE DIGIT REPRESENTATION IN THE MULTI-RADIX NOTATION C OF FACTORS IFACT(IF) IS THE REVERSE OF THE REPRESENTATION OF I2-1. C FOR EXAMPLE, IF ALL IFACT(IF) = 2, I2-1 = 11001, I2REV-1 = 10011. C THE FACTORS MUST BE SYMMETRICALLY ARRANGED, I.E., IFACT(IF) = C IFACT(NFACT+1-IF). DIMENSION DATA(1), IFACT(1) IF (NFACT-1) 80,80,10 10 IP0=2 IP1=IP0*NPREV IP4=IP1*N IP5=IP4*NREM I4REV=1 DO 70 I4=1,IP4,IP1 IF (I4-I4REV) 20,40,40 20 I1MAX=I4+IP1-IP0 DO 30 I1=I4,I1MAX,IP0 DO 30 I5=I1,IP5,IP4 I5REV=I4REV+I5-I4 TEMPR=DATA(I5) TEMPI=DATA(I5+1) DATA(I5)=DATA(I5REV) DATA(I5+1)=DATA(I5REV+1) DATA(I5REV)=TEMPR 30 DATA(I5REV+1)=TEMPI 40 IP3=IP4 DO 60 IF=1,NFACT IP2=IP3/IFACT(IF) I4REV=I4REV+IP2 IF (I4REV-IP3) 70,70,50 50 I4REV=I4REV-IP3 60 IP3=IP2 70 CONTINUE 80 RETURN END C SUBROUTINE ASMRV (DATA,NPREV,N,NREM,IFACT,NFACT,WORK) C SHUFFLE THE DATA ARRAY BY REVERSING THE DIGITS OF ONE INDEX. C THE OPERATION IS THE SAME AS IN SYMRV, EXCEPT THAT THE FACTORS C NEED NOT BE SYMMETRICALLY ARRANGED, I.E., GENERALLY IFACT(IF) NOT= C IFACT(NFACT+1-IF). CONSEQUENTLY, A WORK ARRAY OF LENGTH N IS C NEEDED. DIMENSION DATA(1), WORK(1), IFACT(1) IF (NFACT-1) 60,60,10 10 IP0=2 IP1=IP0*NPREV IP4=IP1*N IP5=IP4*NREM DO 50 I1=1,IP1,IP0 DO 50 I5=I1,IP5,IP4 IWORK=1 I4REV=I5 I4MAX=I5+IP4-IP1 DO 40 I4=I5,I4MAX,IP1 WORK(IWORK)=DATA(I4REV) WORK(IWORK+1)=DATA(I4REV+1) IP3=IP4 DO 30 IF=1,NFACT IP2=IP3/IFACT(IF) I4REV=I4REV+IP2 IF (I4REV-IP3-I5) 40,20,20 20 I4REV=I4REV-IP3 30 IP3=IP2 40 IWORK=IWORK+IP0 IWORK=1 DO 50 I4=I5,I4MAX,IP1 DATA(I4)=WORK(IWORK) DATA(I4+1)=WORK(IWORK+1) 50 IWORK=IWORK+IP0 60 RETURN END C SUBROUTINE COOL (DATA,NPREV,N,NREM,ISIGN,IFACT,WORK) C FOURIER TRANSFORM OF LENGTH N. IN PLACE COOLEY-TUKEY METHOD, C DIGIT-REVERSED TO NORMAL ORDER, SANDE-TUKEY FACTORING (2). C DIMENSION DATA(NPREV,N,NREM) C COMPLEX DATA C DATA(I1,J2,I3) = SUM(DATA(I1,I2,I3)*EXP(ISIGN*2*PI*I*((I2-1)* C (J2-1)/N))), SUMMED OVER I2 = 1 TO N FOR ALL I1 FROM 1 TO NPREV, C J2 FROM 1 TO N AND I3 FROM 1 TO NREM. THE FACTORS OF N ARE GIVEN C IN ANY ORDER IN ARRAY IFACT. FACTORS OF TWO ARE DONE IN PAIRS C AS MUCH AS POSSIBLE (FOURIER TRANSFORM OF LENGTH FOUR), FACTORS OF C THREE ARE DONE SEPARATELY, AND ALL FACTORS FIVE OR HIGHER C ARE DONE BY GOERTZEL@S ALGORITHM (4). DIMENSION DATA(1), WORK(1), IFACT(1) TWOPI = 6.2831853071795865 * FLOAT(ISIGN) IP0=2 IP1=IP0*NPREV IP4=IP1*N IP5=IP4*NREM IF=0 IP2=IP1 10 IF (IP2-IP4) 20,240,240 20 IF=IF+1 IFCUR=IFACT(IF) IF (IFCUR-2) 60,30,60 30 IF (4*IP2-IP4) 40,40,60 40 IF (IFACT(IF+1)-2) 60,50,60 50 IF=IF+1 IFCUR=4 60 IP3=IP2*IFCUR THETA=TWOPI/FLOAT(IFCUR) SINTH=SIN(THETA/2.) ROOTR=-2.*SINTH*SINTH C COS(THETA)-1, FOR ACCURACY. ROOTI=SIN(THETA) THETA=TWOPI/FLOAT(IP3/IP1) SINTH=SIN(THETA/2.) WSTPR=-2.*SINTH*SINTH WSTPI=SIN(THETA) WR=1. WI=0. DO 230 I2=1,IP2,IP1 IF (IFCUR-4) 70,70,210 70 IF ((I2-1)*(IFCUR-2)) 240,90,80 80 W2R=WR*WR-WI*WI W2I=2.*WR*WI W3R=W2R*WR-W2I*WI W3I=W2R*WI+W2I*WR 90 I1MAX=I2+IP1-IP0 DO 200 I1=I2,I1MAX,IP0 DO 200 I5=I1,IP5,IP3 J0=I5 J1=J0+IP2 J2=J1+IP2 J3=J2+IP2 IF (I2-1) 140,140,100 100 IF (IFCUR-3) 130,120,110 C APPLY THE PHASE SHIFT FACTORS 110 TEMPR=DATA(J3) DATA(J3)=W3R*TEMPR-W3I*DATA(J3+1) DATA(J3+1)=W3R*DATA(J3+1)+W3I*TEMPR TEMPR=DATA(J2) DATA(J2)=WR*TEMPR-WI*DATA(J2+1) DATA(J2+1)=WR*DATA(J2+1)+WI*TEMPR TEMPR=DATA(J1) DATA(J1)=W2R*TEMPR-W2I*DATA(J1+1) DATA(J1+1)=W2R*DATA(J1+1)+W2I*TEMPR GO TO 140 120 TEMPR=DATA(J2) DATA(J2)=W2R*TEMPR-W2I*DATA(J2+1) DATA(J2+1)=W2R*DATA(J2+1)+W2I*TEMPR 130 TEMPR=DATA(J1) DATA(J1)=WR*TEMPR-WI*DATA(J1+1) DATA(J1+1)=WR*DATA(J1+1)+WI*TEMPR 140 IF (IFCUR-3) 150,160,170 C DO A FOURIER TRANSFORM OF LENGTH TWO 150 TEMPR=DATA(J1) TEMPI=DATA(J1+1) DATA(J1)=DATA(J0)-TEMPR DATA(J1+1)=DATA(J0+1)-TEMPI DATA(J0)=DATA(J0)+TEMPR DATA(J0+1)=DATA(J0+1)+TEMPI GO TO 200 C DO A FOURIER TRANSFORM OF LENGTH THREE 160 SUMR=DATA(J1)+DATA(J2) SUMI=DATA(J1+1)+DATA(J2+1) TEMPR=DATA(J0)-.5*SUMR TEMPI=DATA(J0+1)-.5*SUMI DATA(J0)=DATA(J0)+SUMR DATA(J0+1)=DATA(J0+1)+SUMI DIFR=ROOTI*(DATA(J2+1)-DATA(J1+1)) DIFI=ROOTI*(DATA(J1)-DATA(J2)) DATA(J1)=TEMPR+DIFR DATA(J1+1)=TEMPI+DIFI DATA(J2)=TEMPR-DIFR DATA(J2+1)=TEMPI-DIFI GO TO 200 C DO A FOURIER TRANSFORM OF LENGTH FOUR (FROM BIT REVERSED ORDER) 170 T0R=DATA(J0)+DATA(J1) T0I=DATA(J0+1)+DATA(J1+1) T1R=DATA(J0)-DATA(J1) T1I=DATA(J0+1)-DATA(J1+1) T2R=DATA(J2)+DATA(J3) T2I=DATA(J2+1)+DATA(J3+1) T3R=DATA(J2)-DATA(J3) T3I=DATA(J2+1)-DATA(J3+1) DATA(J0)=T0R+T2R DATA(J0+1)=T0I+T2I DATA(J2)=T0R-T2R DATA(J2+1)=T0I-T2I IF (ISIGN) 180,180,190 180 T3R=-T3R T3I=-T3I 190 DATA(J1)=T1R-T3I DATA(J1+1)=T1I+T3R DATA(J3)=T1R+T3I DATA(J3+1)=T1I-T3R 200 CONTINUE GO TO 220 C DO A FOURIER TRANSFORM OF LENGTH FIVE OR MORE 210 CALL GOERT (DATA(I2),NPREV,IP2/IP1,IFCUR,IP5/IP3,WORK,WR,WI,ROOTR, .ROOTI) 220 TEMPR=WR WR=WSTPR*TEMPR-WSTPI*WI+TEMPR 230 WI=WSTPR*WI+WSTPI*TEMPR+WI IP2=IP3 GO TO 10 240 RETURN END C SUBROUTINE GOERT(DATA,NPREV,IPROD,IFACT,IREM,WORK,WMINR,WMINI, . ROOTR,ROOTI) C PHASE-SHIFTED FOURIER TRANSFORM OF LENGTH IFACT BY THE GOERTZEL C ALGORITHM (4). IFACT MUST BE ODD AND AT LEAST 5. FURTHER SPEED C IS GAINED BY COMPUTING TWO TRANSFORM VALUES AT THE SAME TIME. C DIMENSION DATA(NPREV,IPROD,IFACT,IREM) C DATA(I1,1,J3,I5) = SUM(DATA(I1,1,I3,I5) * W**(I3-1)), SUMMED C OVER I3 = 1 TO IFACT FOR ALL I1 FROM 1 TO NPREV, J3 FROM 1 TO C IFACT AND I5 FROM 1 TO IREM. C W = WMIN * EXP(ISIGN*2*PI*I*(J3-1)/IFACT). DIMENSION DATA(1), WORK(1) IP0=2 IP1=IP0*NPREV IP2=IP1*IPROD IP3=IP2*IFACT IP5=IP3*IREM IF (WMINI) 10,40,10 C APPLY THE PHASE SHIFT FACTORS 10 WR=WMINR WI=WMINI I3MIN=1+IP2 DO 30 I3=I3MIN,IP3,IP2 I1MAX=I3+IP1-IP0 DO 20 I1=I3,I1MAX,IP0 DO 20 I5=I1,IP5,IP3 TEMPR=DATA(I5) DATA(I5)=WR*TEMPR-WI*DATA(I5+1) 20 DATA(I5+1)=WR*DATA(I5+1)+WI*TEMPR TEMPR=WR WR=WMINR*TEMPR-WMINI*WI 30 WI=WMINR*WI+WMINI*TEMPR 40 DO 90 I1=1,IP1,IP0 DO 90 I5=I1,IP5,IP3 C STRAIGHT SUMMATION FOR THE FIRST TERM SUMR=0. SUMI=0. I3MAX=I5+IP3-IP2 DO 50 I3=I5,I3MAX,IP2 SUMR=SUMR+DATA(I3) 50 SUMI=SUMI+DATA(I3+1) WORK(1)=SUMR WORK(2)=SUMI WR=ROOTR+1. WI=ROOTI IWMIN=1+IP0 IWMAX=IP0*((IFACT+1)/2)-1 DO 80 IWORK=IWMIN,IWMAX,IP0 TWOWR=WR+WR I3=I3MAX OLDSR=0. OLDSI=0. SUMR=DATA(I3) SUMI=DATA(I3+1) I3=I3-IP2 60 TEMPR=SUMR TEMPI=SUMI SUMR=TWOWR*SUMR-OLDSR+DATA(I3) SUMI=TWOWR*SUMI-OLDSI+DATA(I3+1) OLDSR=TEMPR OLDSI=TEMPI I3=I3-IP2 IF (I3-I5) 70,70,60 C IN A FOURIER TRANSFORM THE W CORRESPONDING TO THE POINT AT K C IS THE CONJUGATE OF THAT AT IFACT-K (THAT IS, EXP(TWOPI*I* C K/IFACT) = CONJ(EXP(TWOPI*I*(IFACT-K)/IFACT))). SINCE THE C MAIN LOOP OF GOERTZELS ALGORITHM IS INDIFFERENT TO THE IMAGINARY C PART OF W, IT NEED BE SUPPLIED ONLY AT THE END. 70 TEMPR=-WI*SUMI TEMPI=WI*SUMR SUMR=WR*SUMR-OLDSR+DATA(I3) SUMI=WR*SUMI-OLDSI+DATA(I3+1) WORK(IWORK)=SUMR+TEMPR WORK(IWORK+1)=SUMI+TEMPI IWCNJ=IP0*(IFACT+1)-IWORK WORK(IWCNJ)=SUMR-TEMPR WORK(IWCNJ+1)=SUMI-TEMPI C SINGLETON@S RECURSION, FOR ACCURACY AND SPEED (5). TEMPR=WR WR=WR*ROOTR-WI*ROOTI+WR 80 WI=TEMPR*ROOTI+WI*ROOTR+WI IWORK=1 DO 90 I3=I5,I3MAX,IP2 DATA(I3)=WORK(IWORK) DATA(I3+1)=WORK(IWORK+1) 90 IWORK=IWORK+IP0 RETURN END C SUBROUTINE FIXRL (DATA,N,NREM,ISIGN,IFORM) C FOR IFORM = 0, CONVERT THE TRANSFORM OF A DOUBLED-UP REAL ARRAY, C CONSIDERED COMPLEX, INTO ITS TRUE TRANSFORM. SUPPLY ONLY THE C FIRST HALF OF THE COMPLEX TRANSFORM, AS THE SECOND HALF HAS C CONJUGATE SYMMETRY. FOR IFORM = -1, CONVERT THE FIRST HALF C OF THE TRUE TRANSFORM INTO THE TRANSFORM OF A DOUBLED-UP REAL C ARRAY. N MUST BE EVEN. C USING COMPLEX NOTATION AND SUBSCRIPTS STARTING AT ZERO, THE C TRANSFORMATION IS-- C DIMENSION DATA(N,NREM) C ZSTP = EXP(ISIGN*2*PI*I/N) C DO 10 I2=0,NREM-1 C DATA(0,I2) = CONJ(DATA(0,I2))*(1+I) C DO 10 I1=1,N/4 C Z = (1+(2*IFORM+1)*I*ZSTP**I1)/2 C I1CNJ = N/2-I1 C DIF = DATA(I1,I2)-CONJ(DATA(I1CNJ,I2)) C TEMP = Z*DIF C DATA(I1,I2) = (DATA(I1,I2)-TEMP)*(1-IFORM) C 10 DATA(I1CNJ,I2) = (DATA(I1CNJ,I2)+CONJ(TEMP))*(1-IFORM) C IF I1=I1CNJ, THE CALCULATION FOR THAT VALUE COLLAPSES INTO C A SIMPLE CONJUGATION OF DATA(I1,I2). DIMENSION DATA(1) TWOPI = 6.2831853071795865 * FLOAT(ISIGN) IP0=2 IP1=IP0*(N/2) IP2=IP1*NREM IF (IFORM) 10,70,70 C PACK THE REAL INPUT VALUES (TWO PER COLUMN) 10 J1=IP1+1 DATA(2)=DATA(J1) IF (NREM-1) 70,70,20 20 J1=J1+IP0 I2MIN=IP1+1 DO 60 I2=I2MIN,IP2,IP1 DATA(I2)=DATA(J1) J1=J1+IP0 IF (N-2) 50,50,30 30 I1MIN=I2+IP0 I1MAX=I2+IP1-IP0 DO 40 I1=I1MIN,I1MAX,IP0 DATA(I1)=DATA(J1) DATA(I1+1)=DATA(J1+1) 40 J1=J1+IP0 50 DATA(I2+1)=DATA(J1) 60 J1=J1+IP0 70 DO 80 I2=1,IP2,IP1 TEMPR=DATA(I2) DATA(I2)=DATA(I2)+DATA(I2+1) 80 DATA(I2+1)=TEMPR-DATA(I2+1) IF (N-2) 200,200,90 90 THETA=TWOPI/FLOAT(N) SINTH=SIN(THETA/2.) ZSTPR=-2.*SINTH*SINTH ZSTPI=SIN(THETA) ZR=(1.-ZSTPI)/2. ZI=(1.+ZSTPR)/2. IF (IFORM) 100,110,110 100 ZR=1.-ZR ZI=-ZI 110 I1MIN=IP0+1 I1MAX=IP0*(N/4)+1 DO 190 I1=I1MIN,I1MAX,IP0 DO 180 I2=I1,IP2,IP1 I2CNJ=IP0*(N/2+1)-2*I1+I2 IF (I2-I2CNJ) 150,120,120 120 IF (ISIGN*(2*IFORM+1)) 130,140,140 130 DATA(I2+1)=-DATA(I2+1) 140 IF (IFORM) 170,180,180 150 DIFR=DATA(I2)-DATA(I2CNJ) DIFI=DATA(I2+1)+DATA(I2CNJ+1) TEMPR=DIFR*ZR-DIFI*ZI TEMPI=DIFR*ZI+DIFI*ZR DATA(I2)=DATA(I2)-TEMPR DATA(I2+1)=DATA(I2+1)-TEMPI DATA(I2CNJ)=DATA(I2CNJ)+TEMPR DATA(I2CNJ+1)=DATA(I2CNJ+1)-TEMPI IF (IFORM) 160,180,180 160 DATA(I2CNJ)=DATA(I2CNJ)+DATA(I2CNJ) DATA(I2CNJ+1)=DATA(I2CNJ+1)+DATA(I2CNJ+1) 170 DATA(I2)=DATA(I2)+DATA(I2) DATA(I2+1)=DATA(I2+1)+DATA(I2+1) 180 CONTINUE TEMPR=ZR-.5 ZR=ZSTPR*TEMPR-ZSTPI*ZI+ZR 190 ZI=ZSTPR*ZI+ZSTPI*TEMPR+ZI C RECURSION SAVES TIME, AT A SLIGHT LOSS IN ACCURACY. IF AVAILABLE, C USE DOUBLE PRECISION TO COMPUTE ZR AND ZI. 200 IF (IFORM) 270,210,210 C UNPACK THE REAL TRANSFORM VALUES (TWO PER COLUMN) 210 I2=IP2+1 I1=I2 J1=IP0*(N/2+1)*NREM+1 GO TO 250 220 DATA(J1)=DATA(I1) DATA(J1+1)=DATA(I1+1) I1=I1-IP0 J1=J1-IP0 230 IF (I2-I1) 220,240,240 240 DATA(J1)=DATA(I1) DATA(J1+1)=0. 250 I2=I2-IP1 J1=J1-IP0 DATA(J1)=DATA(I2+1) DATA(J1+1)=0. I1=I1-IP0 J1=J1-IP0 IF (I2-1) 260,260,230 260 DATA(2)=0. 270 RETURN END '\eof' echo CREATE_V5D43.C cat > v5d43.c << '\eof' /* Vis5D version 4.3 */ /* this should be updated when the file version changes */ #define FILE_VERSION "4.2" /* * New grid file format for VIS-5D: * * The header is a list of tagged items. Each item has 3 parts: * 1. A tag which is a 4-byte integer identifying the type of item. * 2. A 4-byte integer indicating how many bytes of data follow. * 3. The binary data. * * If we need to add new information to a file header we just create a * new tag and add the code to read/write the information. * * If we're reading a header and find an unknown tag, we can use the * length field to skip ahead to the next tag. Therefore, the file * format is forward (and backward) compatible. * * Grid data is stored as either: * 1-byte unsigned integers (255=missing) * 2-byte unsigned integers (65535=missing) * 4-byte IEEE floats ( >1.0e30 = missing) * * All numeric values are stored in big endian order. All floating point * values are in IEEE format. */ /* * Updates: * * April 13, 1995, brianp * finished Cray support for 2-byte and 4-byte compress modes */ #include #include #include #include #include #include #include "v5d43.h" #ifndef SEEK_SET # define SEEK_SET 0 #endif #ifndef SEEK_CUR # define SEEK_CUR 1 #endif #ifndef SEEK_END # define SEEK_END 2 #endif /* * Currently defined tags: * Note: the notation a[i] doesn't mean a is an array of i elements, * rather it just refers to the ith element of a[]. * * Tags marked as PHASED OUT should be readable but are no longer written. * Old tag numbers can't be reused! * */ /* TAG NAME VALUE DATA (comments) */ /*----------------------------------------------------------------------*/ #define TAG_ID 0x5635440a /* hex encoding of "V5D\n" */ /* general stuff 1000+ */ #define TAG_VERSION 1000 /* char*10 FileVersion */ #define TAG_NUMTIMES 1001 /* int*4 NumTimes */ #define TAG_NUMVARS 1002 /* int*4 NumVars */ #define TAG_VARNAME 1003 /* int*4 var; char*10 VarName[var] */ #define TAG_NR 1004 /* int*4 Nr */ #define TAG_NC 1005 /* int*4 Nc */ #define TAG_NL 1006 /* int*4 Nl (Nl for all vars) */ #define TAG_NL_VAR 1007 /* int*4 var; int*4 Nl[var] */ #define TAG_LOWLEV_VAR 1008 /* int*4 var; int*4 LowLev[var] */ #define TAG_TIME 1010 /* int*4 t; int*4 TimeStamp[t] */ #define TAG_DATE 1011 /* int*4 t; int*4 DateStamp[t] */ #define TAG_MINVAL 1012 /* int*4 var; real*4 MinVal[var] */ #define TAG_MAXVAL 1013 /* int*4 var; real*4 MaxVal[var] */ #define TAG_COMPRESS 1014 /* int*4 CompressMode; (#bytes/grid)*/ #define TAG_UNITS 1015 /* int *4 var; char*20 Units[var] */ /* vertical coordinate system 2000+ */ #define TAG_VERTICAL_SYSTEM 2000 /* int*4 VerticalSystem */ #define TAG_VERT_ARGS 2100 /* int*4 n; real*4 VertArgs[0..n-1]*/ #define TAG_BOTTOMBOUND 2001 /* real*4 BottomBound (PHASED OUT) */ #define TAG_LEVINC 2002 /* real*4 LevInc (PHASED OUT) */ #define TAG_HEIGHT 2003 /* int*4 l; real*4 Height[l] (PHASED OUT) */ /* projection 3000+ */ #define TAG_PROJECTION 3000 /* int*4 projection: */ /* 0 = generic linear */ /* 1 = cylindrical equidistant */ /* 2 = Lambert conformal/Polar Stereo */ /* 3 = rotated equidistant */ #define TAG_PROJ_ARGS 3100 /* int *4 n; real*4 ProjArgs[0..n-1] */ #define TAG_NORTHBOUND 3001 /* real*4 NorthBound (PHASED OUT) */ #define TAG_WESTBOUND 3002 /* real*4 WestBound (PHASED OUT) */ #define TAG_ROWINC 3003 /* real*4 RowInc (PHASED OUT) */ #define TAG_COLINC 3004 /* real*4 ColInc (PHASED OUT) */ #define TAG_LAT1 3005 /* real*4 Lat1 (PHASED OUT) */ #define TAG_LAT2 3006 /* real*4 Lat2 (PHASED OUT) */ #define TAG_POLE_ROW 3007 /* real*4 PoleRow (PHASED OUT) */ #define TAG_POLE_COL 3008 /* real*4 PoleCol (PHASED OUT) */ #define TAG_CENTLON 3009 /* real*4 CentralLon (PHASED OUT) */ #define TAG_CENTLAT 3010 /* real*4 CentralLat (PHASED OUT) */ #define TAG_CENTROW 3011 /* real*4 CentralRow (PHASED OUT) */ #define TAG_CENTCOL 3012 /* real*4 CentralCol (PHASED OUT) */ #define TAG_ROTATION 3013 /* real*4 Rotation (PHASED OUT) */ #define TAG_END 9999 /**********************************************************************/ /***** Miscellaneous Functions *****/ /**********************************************************************/ float pressure_to_height(float pressure) { return (float) DEFAULT_LOG_EXP * log((double) pressure / DEFAULT_LOG_SCALE); } float height_to_pressure(float height) { return (float) DEFAULT_LOG_SCALE * exp((double) height / DEFAULT_LOG_EXP); } /* * Return current file position. * Input: f - file descriptor */ static off_t ltell( int f ) { return lseek( f, 0, SEEK_CUR ); } /* ****************************************************************** * Copy up to maxlen characters from src to dst stopping upon whitespace * in src. Terminate dst with null character. * Return: length of dst. */ static int copy_string2( char *dst, const char *src, int maxlen ) { int i; for (i=0;i=0; i--) { if (dst[i]==' ' || i==maxlen-1) dst[i] = 0; else break; } return strlen(dst); } /* ****************************************************************** * Copy up to maxlen characters from src to dst stopping upon whitespace * in src. Terminate dst with null character. * Return: length of dst. */ static int copy_string( char *dst, const char *src, int maxlen ) { int i; for (i=0;i 99) iy = iy - 100; /* WLH 31 July 96 << 31 Dec 99 */ /* iy = iy + 1900; is the right way to fix this, but requires changing all places where dates are printed - procrastinate */ iyyddd = iy*1000+id; return iyyddd; } /* ****************************************************************** * Convert a time in seconds since midnight to HHMMSS format. */ int v5dSecondsToHHMMSS( int seconds ) { int hh, mm, ss; hh = seconds / (60*60); mm = (seconds / 60) % 60; ss = seconds % 60; return hh*10000 + mm * 100 + ss; } void v5dPrintStruct( const v5dstruct *v ) { static char day[7][10] = { "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday" }; int time, var, i; int maxnl; maxnl = 0; for (var=0;varNumVars;var++) { if (v->Nl[var]+v->LowLev[var]>maxnl) { maxnl = v->Nl[var]+v->LowLev[var]; } } if (v->FileFormat==0) { if (v->FileVersion[0] == 0) { printf("File format: v5d version: (4.0 or 4.1)\n"); } else { printf("File format: v5d version: %s\n", v->FileVersion); } } else { printf("File format: comp5d (VIS-5D 3.3 or older)\n"); } if (v->CompressMode==1) { printf("Compression: 1 byte per gridpoint.\n"); } else { printf("Compression: %d bytes per gridpoint.\n", v->CompressMode); } printf("header size=%d\n", v->FirstGridPos); printf("sizeof(v5dstruct)=%d\n", sizeof(v5dstruct) ); printf("\n"); printf("NumVars = %d\n", v->NumVars ); printf("Var Name Units Rows Cols Levels LowLev MinVal MaxVal\n"); for (var=0;varNumVars;var++) { printf("%3d %-10s %-10s %3d %3d %3d %3d", var+1, v->VarName[var], v->Units[var], v->Nr, v->Nc, v->Nl[var], v->LowLev[var] ); if (v->MinVal[var] > v->MaxVal[var]) { printf(" MISSING MISSING\n"); } else { printf(" %-12g %-12g\n", v->MinVal[var], v->MaxVal[var] ); } } printf("\n"); printf("NumTimes = %d\n", v->NumTimes ); printf("Step Date(YYDDD) Time(HH:MM:SS) Day\n"); for (time=0;timeNumTimes;time++) { int i = v->TimeStamp[time]; printf("%3d %05d %5d:%02d:%02d %s\n", time+1, v->DateStamp[time], i/10000, (i/100)%100, i%100, day[ v5dYYDDDtoDays(v->DateStamp[time]) % 7 ]); } printf("\n"); switch (v->VerticalSystem) { case 0: printf("Generic linear vertical coordinate system:\n"); printf("\tBottom Bound: %f\n", v->VertArgs[0] ); printf("\tIncrement between levels: %f\n", v->VertArgs[1] ); break; case 1: printf("Equally spaced levels in km:\n"); printf("\tBottom Bound: %f\n", v->VertArgs[0] ); printf("\tIncrement: %f\n", v->VertArgs[1] ); break; case 2: printf("Unequally spaced levels in km:\n"); printf("Level\tHeight(km)\n"); for (i=0;iVertArgs[i] ); } break; case 3: printf("Unequally spaced levels in mb:\n"); printf("Level\tPressure(mb)\n"); for (i=0;iVertArgs[i]) ); } break; default: printf("Bad VerticalSystem value: %d\n", v->VerticalSystem ); } printf("\n"); switch (v->Projection) { case 0: printf("Generic linear projection:\n"); printf("\tNorth Boundary: %f\n", v->ProjArgs[0] ); printf("\tWest Boundary: %f\n", v->ProjArgs[1] ); printf("\tRow Increment: %f\n", v->ProjArgs[2] ); printf("\tColumn Increment: %f\n", v->ProjArgs[3] ); break; case 1: printf("Cylindrical Equidistant projection:\n"); printf("\tNorth Boundary: %f degrees\n", v->ProjArgs[0] ); printf("\tWest Boundary: %f degrees\n", v->ProjArgs[1] ); printf("\tRow Increment: %f degrees\n", v->ProjArgs[2] ); printf("\tColumn Increment: %f degrees\n", v->ProjArgs[3] ); /* printf("\tSouth Boundary: %f degrees\n", v->NorthBound - v->RowInc * (v->Nr-1) ); printf("\tEast Boundary: %f degrees\n", v->WestBound - v->ColInc * (v->Nc-1) ); */ break; case 2: printf("Lambert Conformal projection:\n"); printf("\tStandard Latitude 1: %f\n", v->ProjArgs[0] ); printf("\tStandard Latitude 2: %f\n", v->ProjArgs[1] ); printf("\tNorth/South Pole Row: %f\n", v->ProjArgs[2] ); printf("\tNorth/South Pole Column: %f\n", v->ProjArgs[3] ); printf("\tCentral Longitude: %f\n", v->ProjArgs[4] ); printf("\tColumn Increment: %f km\n", v->ProjArgs[5] ); break; case 3: printf("Stereographic:\n"); printf("\tCenter Latitude: %f\n", v->ProjArgs[0] ); printf("\tCenter Longitude: %f\n", v->ProjArgs[1] ); printf("\tCenter Row: %f\n", v->ProjArgs[2] ); printf("\tCenter Column: %f\n", v->ProjArgs[3] ); printf("\tColumn Spacing: %f\n", v->ProjArgs[4] ); break; case 4: /* WLH 4-21-95 */ printf("Rotated equidistant projection:\n"); printf("\tLatitude of grid(0,0): %f\n", v->ProjArgs[0] ); printf("\tLongitude of grid(0,0): %f\n", v->ProjArgs[1] ); printf("\tRow Increment: %f degress\n", v->ProjArgs[2] ); printf("\tColumn Increment: %f degrees\n", v->ProjArgs[3] ); printf("\tCenter Latitude: %f\n", v->ProjArgs[4] ); printf("\tCenter Longitude: %f\n", v->ProjArgs[5] ); printf("\tRotation: %f degrees\n", v->ProjArgs[6] ); break; default: printf("Bad projection number: %d\n", v->Projection ); } } /* ****************************************************************** * Compute the location of a compressed grid within a file. * Input: v - pointer to v5dstruct describing the file header. * time, var - which timestep and variable. * Return: file offset in bytes */ static int grid_position( const v5dstruct *v, int time, int var ) { int pos, i; assert( time >= 0 ); assert( var >= 0 ); assert( time < v->NumTimes ); assert( var < v->NumVars ); pos = v->FirstGridPos + time * v->SumGridSizes; for (i=0;iGridSize[i]; } return pos; } /* ****************************************************************** * Compute the ga and gb (de)compression values for a grid. * Input: nr, nc, nl - size of grid * data - the grid data * ga, gb - arrays to store results. * minval, maxval - pointer to floats to return min, max values * compressmode - 1, 2 or 4 bytes per grid point * Output: ga, gb - the (de)compression values * minval, maxval - the min and max grid values * Side effect: the MinVal[var] and MaxVal[var] fields in g may be * updated with new values. */ static void compute_ga_gb( int nr, int nc, int nl, const float data[], int compressmode, float ga[], float gb[], float *minval, float *maxval ) { #ifdef SIMPLE_COMPRESSION /* * Compute ga, gb values for whole grid. */ int i, lev, allmissing, num; float min, max, a, b; min = 1.0e30; max = -1.0e30; num = nr * nc * nl; allmissing = 1; for (i=0;imax) max = data[i]; allmissing = 0; } } if (allmissing) { a = 1.0; b = 0.0; } else { a = (max-min) / 254.0; b = min; } /* return results */ for (i=0;imax) max = data[j]; j++; } if (mingridmax) gridmax = max; levmin[lev] = min; levmax[lev] = max; } /* WLH 2-2-95 */ #ifdef KLUDGE /* if the grid minimum is within delt of 0.0, fudge all values */ /* within delt of 0.0 to delt, and recalculate mins and maxes */ { float delt; int nrncnl = nrnc * nl; delt = (gridmax - gridmin)/100000.0; if ( ABS(gridmin) < delt && gridmin!=0.0 && compressmode != 4 ) { float min, max; for (j=0; j=BIGVALUE && levmax[lev]<=SMALLVALUE) { /* all values in the layer are MISSING */ d[lev] = 0.0; } else { d[lev] = levmax[lev]-levmin[lev]; } if (d[lev]>dmax) dmax = d[lev]; } /*** Compute ga (scale) and gb (bias) for each grid level */ if (dmax==0.0) { /*** Special cases ***/ if (gridmin==gridmax) { /*** whole grid is of same value ***/ for (lev=0; lev> 8; /* upper byte */ compdata1[p*2+1] = compvalue & 0xffu; /* lower byte */ } #else for (i=0;iNr * v->Nc * v->Nl[var] * v->CompressMode; } /* ****************************************************************** * Initialize a v5dstructure to reasonable initial values. * Input: v - pointer to v5dstruct. */ void v5dInitStruct( v5dstruct *v ) { int i; /* set everything to zero */ memset( v, 0, sizeof(v5dstruct) ); /* special cases */ v->Projection = -1; v->VerticalSystem = -1; for (i=0;iMinVal[i] = MISSING; v->MaxVal[i] = -MISSING; v->LowLev[i] = 0; } /* set file version */ strcpy(v->FileVersion, FILE_VERSION); v->CompressMode = 1; v->FileDesc = -1; } /* ****************************************************************** * Return a pointer to a new, initialized v5dstruct. */ v5dstruct *v5dNewStruct( void ) { v5dstruct *v; v = (v5dstruct *) malloc( sizeof(v5dstruct) ); if (v) { v5dInitStruct(v); } return v; } /* ****************************************************************** * Free an initialized v5dstruct. (Todd Plessel) */ void v5dFreeStruct( v5dstruct* v ) { /*assert( v5dVerifyStruct( v ) );*/ free( v ); v = 0; } /* ****************************************************************** * Do some checking that the information in a v5dstruct is valid. * Input: v - pointer to v5dstruct * Return: 1 = g is ok, 0 = g is invalid */ int v5dVerifyStruct( const v5dstruct *v ) { int var, i, invalid, maxnl; invalid = 0; if (!v) return 0; /* Number of variables */ if (v->NumVars<0) { printf("Invalid number of variables: %d\n", v->NumVars ); invalid = 1; } else if (v->NumVars>MAXVARS) { printf("Too many variables: %d (Maximum is %d)\n", v->NumVars, MAXVARS); invalid = 1; } /* Variable Names */ for (i=0;iNumVars;i++) { if (v->VarName[i][0]==0) { printf("Missing variable name: VarName[%d]=\"\"\n", i ); invalid = 1; } } /* Number of timesteps */ if (v->NumTimes<0) { printf("Invalid number of timesteps: %d\n", v->NumTimes ); invalid = 1; } else if (v->NumTimes>MAXTIMES) { printf("Too many timesteps: %d (Maximum is %d)\n", v->NumTimes, MAXTIMES ); invalid = 1; } /* Make sure timestamps are increasing */ for (i=1;iNumTimes;i++) { int date0 = v5dYYDDDtoDays( v->DateStamp[i-1] ); int date1 = v5dYYDDDtoDays( v->DateStamp[i] ); int time0 = v5dHHMMSStoSeconds( v->TimeStamp[i-1] ); int time1 = v5dHHMMSStoSeconds( v->TimeStamp[i] ); if (time1<=time0 && date1<=date0) { printf("Timestamp for step %d must be later than step %d\n", i, i-1); invalid = 1; } } /* Rows */ if (v->Nr<2) { printf("Too few rows: %d (2 is minimum)\n", v->Nr ); invalid = 1; } else if (v->Nr>MAXROWS) { printf("Too many rows: %d (%d is maximum)\n", v->Nr, MAXROWS ); invalid = 1; } /* Columns */ if (v->Nc<2) { printf("Too few columns: %d (2 is minimum)\n", v->Nc ); invalid = 1; } else if (v->Nc>MAXCOLUMNS) { printf("Too many columns: %d (%d is maximum)\n", v->Nc, MAXCOLUMNS ); invalid = 1; } /* Levels */ maxnl = 0; for (var=0;varNumVars;var++) { if (v->LowLev[var] < 0) { printf("Low level cannot be negative for var %s: %d\n", v->VarName[var], v->LowLev[var] ); invalid = 1; } if (v->Nl[var]<1) { printf("Too few levels for var %s: %d (1 is minimum)\n", v->VarName[var], v->Nl[var] ); invalid = 1; } if (v->Nl[var]+v->LowLev[var]>MAXLEVELS) { printf("Too many levels for var %s: %d (%d is maximum)\n", v->VarName[var], v->Nl[var]+v->LowLev[var], MAXLEVELS ); invalid = 1; } if (v->Nl[var]+v->LowLev[var]>maxnl) { maxnl = v->Nl[var]+v->LowLev[var]; } } if (v->CompressMode != 1 && v->CompressMode != 2 && v->CompressMode != 4) { printf("Bad CompressMode: %d (must be 1, 2 or 4)\n", v->CompressMode ); invalid = 1; } switch (v->VerticalSystem) { case 0: case 1: if (v->VertArgs[1]==0.0) { printf("Vertical level increment is zero, must be non-zero\n"); invalid = 1; } break; case 2: /* Check that Height values increase upward */ for (i=1;iVertArgs[i] <= v->VertArgs[i-1]) { printf("Height[%d]=%f <= Height[%d]=%f, level heights must increase\n", i, v->VertArgs[i], i-1, v->VertArgs[i-1] ); invalid = 1; break; } } break; case 3: /* Check that Pressure values decrease upward */ for (i=1;iVertArgs[i] <= v->VertArgs[i-1]) { printf("Pressure[%d]=%f >= Pressure[%d]=%f, level pressures must decrease\n", i, height_to_pressure(v->VertArgs[i]), i-1, height_to_pressure(v->VertArgs[i-1]) ); invalid = 1; break; } } break; default: printf("VerticalSystem = %d, must be in 0..3\n", v->VerticalSystem ); invalid = 1; } switch (v->Projection) { case 0: /* Generic */ if (v->ProjArgs[2]==0.0) { printf("Row Increment (ProjArgs[2]) can't be zero\n"); invalid = 1; } if (v->ProjArgs[3]==0.0) { printf("Column increment (ProjArgs[3]) can't be zero\n"); invalid = 1; } break; case 1: /* Cylindrical equidistant */ if (v->ProjArgs[2]<0.0) { printf("Row Increment (ProjArgs[2]) = %g (must be >=0.0)\n", v->ProjArgs[2] ); invalid = 1; } if (v->ProjArgs[3]<=0.0) { printf("Column Increment (ProjArgs[3]) = %g (must be >=0.0)\n", v->ProjArgs[3] ); invalid = 1; } break; case 2: /* Lambert Conformal */ if (v->ProjArgs[0]<-90.0 || v->ProjArgs[0]>90.0) { printf("Lat1 (ProjArgs[0]) out of range: %g\n", v->ProjArgs[0] ); invalid = 1; } if (v->ProjArgs[1]<-90.0 || v->ProjArgs[1]>90.0) { printf("Lat2 (ProjArgs[1] out of range: %g\n", v->ProjArgs[1] ); invalid = 1; } if (v->ProjArgs[5]<=0.0) { printf("ColInc (ProjArgs[5]) = %g (must be >=0.0)\n", v->ProjArgs[5] ); invalid = 1; } break; case 3: /* Stereographic */ if (v->ProjArgs[0]<-90.0 || v->ProjArgs[0]>90.0) { printf("Central Latitude (ProjArgs[0]) out of range: "); printf("%g (must be in +/-90)\n", v->ProjArgs[0] ); invalid = 1; } if (v->ProjArgs[1]<-180.0 || v->ProjArgs[1]>180.0) { printf("Central Longitude (ProjArgs[1]) out of range: "); printf("%g (must be in +/-180)\n", v->ProjArgs[1] ); invalid = 1; } if (v->ProjArgs[4]<0) { printf("Column spacing (ProjArgs[4]) = %g (must be positive)\n", v->ProjArgs[4]); invalid = 1; } break; case 4: /* Rotated */ /* WLH 4-21-95 */ if (v->ProjArgs[2]<=0.0) { printf("Row Increment (ProjArgs[2]) = %g (must be >=0.0)\n", v->ProjArgs[2] ); invalid = 1; } if (v->ProjArgs[3]<=0.0) { printf("Column Increment = (ProjArgs[3]) %g (must be >=0.0)\n", v->ProjArgs[3] ); invalid = 1; } if (v->ProjArgs[4]<-90.0 || v->ProjArgs[4]>90.0) { printf("Central Latitude (ProjArgs[4]) out of range: "); printf("%g (must be in +/-90)\n", v->ProjArgs[4] ); invalid = 1; } if (v->ProjArgs[5]<-180.0 || v->ProjArgs[5]>180.0) { printf("Central Longitude (ProjArgs[5]) out of range: "); printf("%g (must be in +/-180)\n", v->ProjArgs[5] ); invalid = 1; } if (v->ProjArgs[6]<-180.0 || v->ProjArgs[6]>180.0) { printf("Central Longitude (ProjArgs[6]) out of range: "); printf("%g (must be in +/-180)\n", v->ProjArgs[6] ); invalid = 1; } break; default: printf("Projection = %d, must be in 0..4\n", v->Projection ); invalid = 1; } return !invalid; } /**********************************************************************/ /***** Output Functions *****/ /**********************************************************************/ static int write_tag( v5dstruct *v, int tag, int length, int newfile ) { if (!newfile) { /* have to check that there's room in header to write this tagged item */ if (v->CurPos+8+length > v->FirstGridPos) { printf("Error: out of header space!\n"); /* Out of header space! */ return 0; } } if (write_int4( v->FileDesc, tag )==0) return 0; if (write_int4( v->FileDesc, length )==0) return 0; v->CurPos += 8 + length; return 1; } /* ****************************************************************** * Write the information in the given v5dstruct as a v5d file header. * Note that the current file position is restored when this function * returns normally. * Input: f - file already open for writing * v - pointer to v5dstruct * Return: 1 = ok, 0 = error. */ static int write_v5d_header( v5dstruct *v ) { int var, time, filler, maxnl; int f; int newfile; if (v->FileFormat!=0) { printf("Error: v5d library can't write comp5d format files.\n"); return 0; } f = v->FileDesc; if (!v5dVerifyStruct( v )) return 0; /* Determine if we're writing to a new file */ if (v->FirstGridPos==0) { newfile = 1; } else { newfile = 0; } /* compute grid sizes */ v->SumGridSizes = 0; for (var=0;varNumVars;var++) { v->GridSize[var] = 8 * v->Nl[var] + v5dSizeofGrid( v, 0, var ); v->SumGridSizes += v->GridSize[var]; } /* set file pointer to start of file */ lseek( f, 0, SEEK_SET ); v->CurPos = 0; /* * Write the tagged header info */ #define WRITE_TAG( V, T, L ) if (!write_tag(V,T,L,newfile)) return 0; /* ID */ WRITE_TAG( v, TAG_ID, 0 ); /* File Version */ WRITE_TAG( v, TAG_VERSION, 10 ); write_bytes( f, FILE_VERSION, 10 ); /* Number of timesteps */ WRITE_TAG( v, TAG_NUMTIMES, 4 ); write_int4( f, v->NumTimes ); /* Number of variables */ WRITE_TAG( v, TAG_NUMVARS, 4 ); write_int4( f, v->NumVars ); /* Names of variables */ for (var=0;varNumVars;var++) { WRITE_TAG( v, TAG_VARNAME, 14 ); write_int4( f, var ); write_bytes( f, v->VarName[var], 10 ); } /* Physical Units */ for (var=0;varNumVars;var++) { WRITE_TAG( v, TAG_UNITS, 24 ); write_int4( f, var ); write_bytes( f, v->Units[var], 20 ); } /* Date and time of each timestep */ for (time=0;timeNumTimes;time++) { WRITE_TAG( v, TAG_TIME, 8 ); write_int4( f, time ); write_int4( f, v->TimeStamp[time] ); WRITE_TAG( v, TAG_DATE, 8 ); write_int4( f, time ); write_int4( f, v->DateStamp[time] ); } /* Number of rows */ WRITE_TAG( v, TAG_NR, 4 ); write_int4( f, v->Nr ); /* Number of columns */ WRITE_TAG( v, TAG_NC, 4 ); write_int4( f, v->Nc ); /* Number of levels, compute maxnl */ maxnl = 0; for (var=0;varNumVars;var++) { WRITE_TAG( v, TAG_NL_VAR, 8 ); write_int4( f, var ); write_int4( f, v->Nl[var] ); WRITE_TAG( v, TAG_LOWLEV_VAR, 8 ); write_int4( f, var ); write_int4( f, v->LowLev[var] ); if (v->Nl[var]+v->LowLev[var]>maxnl) { maxnl = v->Nl[var]+v->LowLev[var]; } } /* Min/Max values */ for (var=0;varNumVars;var++) { WRITE_TAG( v, TAG_MINVAL, 8 ); write_int4( f, var ); write_float4( f, v->MinVal[var] ); WRITE_TAG( v, TAG_MAXVAL, 8 ); write_int4( f, var ); write_float4( f, v->MaxVal[var] ); } /* Compress mode */ WRITE_TAG( v, TAG_COMPRESS, 4 ); write_int4( f, v->CompressMode ); /* Vertical Coordinate System */ WRITE_TAG( v, TAG_VERTICAL_SYSTEM, 4 ); write_int4( f, v->VerticalSystem ); WRITE_TAG( v, TAG_VERT_ARGS, 4+4*MAXVERTARGS ); write_int4( f, MAXVERTARGS ); write_float4_array( f, v->VertArgs, MAXVERTARGS ); /* Map Projection */ WRITE_TAG( v, TAG_PROJECTION, 4 ); write_int4( f, v->Projection ); WRITE_TAG( v, TAG_PROJ_ARGS, 4+4*MAXPROJARGS ); write_int4( f, MAXPROJARGS ); write_float4_array( f, v->ProjArgs, MAXPROJARGS ); /* write END tag */ if (newfile) { /* We're writing to a brand new file. Reserve 10000 bytes */ /* for future header growth. */ WRITE_TAG( v, TAG_END, 10000 ); lseek( f, 10000, SEEK_CUR ); /* Let file pointer indicate where first grid is stored */ v->FirstGridPos = ltell( f ); } else { /* we're rewriting a header */ filler = v->FirstGridPos - ltell(f); WRITE_TAG( v, TAG_END, filler-8 ); } #undef WRITE_TAG return 1; } /* ************************************************************** * Open a v5d file for writing. If the named file already exists, * it will be deleted. * Input: filename - name of v5d file to create. * v - pointer to v5dstruct with the header info to write. * Return: 1 = ok, 0 = error. */ int v5dCreateFile( const char *filename, v5dstruct *v ) { mode_t mask; int fd; mask = 0666; fd = open( filename, O_WRONLY | O_CREAT | O_TRUNC, mask ); if (fd==-1) { printf("Error in v5dCreateFile: open failed\n"); v->FileDesc = -1; v->Mode = 0; return 0; } else { /* ok */ v->FileDesc = fd; v->Mode = 'w'; /* write header and return status */ return write_v5d_header(v); } } /* ************************************************************** * Write a compressed grid to a v5d file. * Input: v - pointer to v5dstruct describing the file * time, var - which timestep and variable * ga, gb - the GA and GB (de)compression value arrays * compdata - address of array of compressed data values * Return: 1 = ok, 0 = error. */ int v5dWriteCompressedGrid( const v5dstruct *v, int time, int var, const float *ga, const float *gb, const void *compdata ) { int pos, n, k; /* simple error checks */ if (v->Mode!='w') { printf("Error in v5dWriteCompressedGrid: file opened for reading,"); printf(" not writing.\n"); return 0; } if (time<0 || time>=v->NumTimes) { printf("Error in v5dWriteCompressedGrid: bad timestep argument (%d)\n", time); return 0; } if (var<0 || var>=v->NumVars) { printf("Error in v5dWriteCompressedGrid: bad variable argument (%d)\n", var); return 0; } /* move to position in file */ pos = grid_position( v, time, var ); if (lseek( v->FileDesc, pos, SEEK_SET )<0) { /* lseek failed, return error */ printf("Error in v5dWrite[Compressed]Grid: seek failed, disk full?\n"); return 0; } /* write ga, gb arrays */ k = 0; if (write_float4_array( v->FileDesc, ga, v->Nl[var] ) == v->Nl[var] && write_float4_array( v->FileDesc, gb, v->Nl[var] ) == v->Nl[var]) { /* write compressed grid data (k=1=OK, k=0=Error) */ n = v->Nr * v->Nc * v->Nl[var]; if (v->CompressMode==1) { k = write_block( v->FileDesc, compdata, n, 1 )==n; } else if (v->CompressMode==2) { k = write_block( v->FileDesc, compdata, n, 2 )==n; } else if (v->CompressMode==4) { k = write_block( v->FileDesc, compdata, n, 4 )==n; } } if (k==0) { /* Error while writing */ printf("Error in v5dWrite[Compressed]Grid: write failed, disk full?\n"); } return k; /* n = v->Nr * v->Nc * v->Nl[var] * v->CompressMode; if (write_bytes( v->FileDesc, compdata, n )!=n) { printf("Error in v5dWrite[Compressed]Grid: write failed, disk full?\n"); return 0; } else { return 1; } */ } /* ************************************************************** * Compress a grid and write it to a v5d file. * Input: v - pointer to v5dstruct describing the file * time, var - which timestep and variable (starting at 0) * data - address of uncompressed grid data * Return: 1 = ok, 0 = error. */ int v5dWriteGrid( v5dstruct *v, int time, int var, const float data[] ) { float ga[MAXLEVELS], gb[MAXLEVELS]; void *compdata; int n, bytes; float min, max; if (v->Mode!='w') { printf("Error in v5dWriteGrid: file opened for reading,"); printf(" not writing.\n"); return 0; } if (time<0 || time>=v->NumTimes) { printf("Error in v5dWriteGrid: bad timestep argument (%d)\n", time); return 0; } if (var<0 || var>=v->NumVars) { printf("Error in v5dWriteGrid: bad variable argument (%d)\n", var); return 0; } /* allocate compdata buffer */ if (v->CompressMode==1) { bytes = v->Nr * v->Nc * v->Nl[var] * sizeof(unsigned char); } else if (v->CompressMode==2) { bytes = v->Nr * v->Nc * v->Nl[var] * sizeof(unsigned short); } else if (v->CompressMode==4) { bytes = v->Nr * v->Nc * v->Nl[var] * sizeof(float); } compdata = (void *) malloc( bytes ); if (!compdata) { printf("Error in v5dWriteGrid: out of memory (needed %d bytes)\n", bytes ); return 0; } /* compress the grid data */ v5dCompressGrid( v->Nr, v->Nc, v->Nl[var], v->CompressMode, data, compdata, ga, gb, &min, &max ); /* update min and max value */ if (minMinVal[var]) v->MinVal[var] = min; if (max>v->MaxVal[var]) v->MaxVal[var] = max; /* write the compressed grid */ n = v5dWriteCompressedGrid( v, time, var, ga, gb, compdata ); /* free compdata */ free( compdata ); return n; } /* ************************************************************** * Close a v5d file which was opened with open_v5d_file() or * create_v5d_file(). * Input: f - file descriptor * Return: 1 = ok, 0 = error */ int v5dCloseFile( v5dstruct *v ) { int status = 1; if (v->Mode=='w') { /* rewrite header because writing grids updates the minval and */ /* maxval fields */ lseek( v->FileDesc, 0, SEEK_SET ); status = write_v5d_header( v ); lseek( v->FileDesc, 0, SEEK_END ); close( v->FileDesc ); } else if (v->Mode=='r') { /* just close the file */ close(v->FileDesc); } else { printf("Error in v5dCloseFile: bad v5dstruct argument\n"); return 0; } v->FileDesc = -1; v->Mode = 0; return status; } /**********************************************************************/ /***** Simple v5d file writing functions. *****/ /**********************************************************************/ static v5dstruct *Simple = NULL; /* ************************************************************** * Create a new v5d file specifying both a map projection and vertical * coordinate system. See README file for argument details. * Return: 1 = ok, 0 = error. */ int v5dCreate( const char *name, int numtimes, int numvars, int nr, int nc, const int nl[], const char varname[MAXVARS][10], const int timestamp[], const int datestamp[], int compressmode, int projection, const float proj_args[], int vertical, const float vert_args[] ) { int var, time, maxnl, i; /* initialize the v5dstruct */ Simple = v5dNewStruct(); Simple->NumTimes = numtimes; Simple->NumVars = numvars; Simple->Nr = nr; Simple->Nc = nc; maxnl = nl[0]; for (var=0;varmaxnl) { maxnl = nl[var]; } Simple->Nl[var] = nl[var]; Simple->LowLev[var] = 0; strncpy( Simple->VarName[var], varname[var], 10 ); Simple->VarName[var][9] = 0; } /* time and date for each timestep */ for (time=0;timeTimeStamp[time] = timestamp[time]; Simple->DateStamp[time] = datestamp[time]; } Simple->CompressMode = compressmode; /* Map projection and vertical coordinate system */ Simple->Projection = projection; memcpy( Simple->ProjArgs, proj_args, MAXPROJARGS*sizeof(float) ); Simple->VerticalSystem = vertical; if (vertical == 3) { /* convert pressures to heights */ for (i=0; i 0.000001) { Simple->VertArgs[i] = pressure_to_height(vert_args[i]); } else Simple->VertArgs[i] = 0.0; } } else { memcpy( Simple->VertArgs, vert_args, MAXVERTARGS*sizeof(float) ); } /* create the file */ if (v5dCreateFile( name, Simple )==0) { printf("Error in v5dCreateSimpleFile: unable to create %s\n", name ); return 0; } else { return 1; } } /* ************************************************************** * Set lowest levels for each variable (other than default of 0). * Input: lowlev - array [NumVars] of ints * Return: 1 = ok, 0 = error */ int v5dSetLowLev( int lowlev[] ) { int var; if (Simple) { for (var=0;varNumVars;var++) { Simple->LowLev[var] = lowlev[var]; } return 1; } else { printf("Error: must call v5dCreate before v5dSetLowLev\n"); return 0; } } /* ************************************************************** * Set the units for a variable. * Input: var - a variable in [1,NumVars] * units - a string * Return: 1 = ok, 0 = error */ int v5dSetUnits( int var, const char *units ) { if (Simple) { if (var>=1 && var<=Simple->NumVars) { strncpy( Simple->Units[var-1], units, 19 ); Simple->Units[var-1][19] = 0; return 1; } else { printf("Error: bad variable number in v5dSetUnits\n"); return 0; } } else { printf("Error: must call v5dCreate before v5dSetUnits\n"); return 0; } } /* ************************************************************** * Write a grid to a v5d file. * Input: time - timestep in [1,NumTimes] * var - timestep in [1,NumVars] * data - array [nr*nc*nl] of floats * Return: 1 = ok, 0 = error */ int v5dWrite( int time, int var, const float data[] ) { if (Simple) { if (time<1 || time>Simple->NumTimes) { printf("Error in v5dWrite: bad timestep number: %d\n", time ); return 0; } if (var<1 || var>Simple->NumVars) { printf("Error in v5dWrite: bad variable number: %d\n", var ); } return v5dWriteGrid( Simple, time-1, var-1, data ); } else { printf("Error: must call v5dCreate before v5dWrite\n"); return 0; } } /* ************************************************************** * Close a v5d file after the last grid has been written to it. * Return: 1 = ok, 0 = error */ int v5dClose( void ) { if (Simple) { int ok = v5dCloseFile( Simple ); v5dFreeStruct( Simple ); return ok; } else { printf("Error: v5dClose: no file to close\n"); return 0; } } /**********************************************************************/ /***** FORTRAN-callable simple output *****/ /**********************************************************************/ /* ************************************************************** * Create a v5d file. See README file for argument descriptions. * Return: 1 = ok, 0 = error. */ #ifdef UNDERSCORE int v5dcreate_ #else # ifdef _CRAY int V5DCREATE # else int v5dcreate # endif #endif ( const char *name, const int *numtimes, const int *numvars, const int *nr, const int *nc, const int nl[], const char varname[][10], const int timestamp[], const int datestamp[], const int *compressmode, const int *projection, const float proj_args[], const int *vertical, const float vert_args[] ) { char filename[13]; char names[MAXVARS][10]; int i, maxnl, args; /* copy name to filename and remove trailing spaces if any */ copy_string( filename, name, 14 ); /* * Check for uninitialized arguments */ if (*numtimes<1) { printf("Error: numtimes invalid\n"); return 0; } if (*numvars<1) { printf("Error: numvars invalid\n"); return 0; } if (*nr<2) { printf("Error: nr invalid\n"); return 0; } if (*nc<2) { printf("Error: nc invalid\n"); return 0; } maxnl = 0; for (i=0;i<*numvars;i++) { if (nl[i]<1) { printf("Error: nl(%d) invalid\n", i+1); return 0; } if (nl[i]>maxnl) { maxnl = nl[i]; } } for (i=0;i<*numvars;i++) { if (copy_string2( names[i], varname[i], 10)==0) { printf("Error: unitialized varname(%d)\n", i+1); return 0; } } for (i=0;i<*numtimes;i++) { if (timestamp[i]<0) { printf("Error: times(%d) invalid\n", i+1); return 0; } if (datestamp[i]<0) { printf("Error: dates(%d) invalid\n", i+1); return 0; } } if (*compressmode != 1 && *compressmode != 2 && *compressmode != 4) { printf("Error: compressmode invalid\n"); return 0; } switch (*projection) { case 0: args = 4; break; case 1: args = 0; if (IS_MISSING(proj_args[0])) { printf("Error: northlat (proj_args(1)) invalid\n"); return 0; } if (IS_MISSING(proj_args[1])) { printf("Error: westlon (proj_args(2)) invalid\n"); return 0; } if (IS_MISSING(proj_args[2])) { printf("Error: latinc (proj_args(3)) invalid\n"); return 0; } if (IS_MISSING(proj_args[3])) { printf("Error: loninc (proj_args(4)) invalid\n"); return 0; } break; case 2: args = 6; break; case 3: args = 5; break; case 4: args = 7; break; default: args = 0; printf("Error: projection invalid\n"); return 0; } for (i=0;i>>> These functions are built on top of Unix I/O functions, not stdio! <<<< * * The file format is assumed to be BIG-ENDIAN. * If this code is compiled with -DLITTLE and executes on a little endian * CPU then byte-swapping will be done. * * If an ANSI compiler is used prototypes and ANSI function declarations * are used. Otherwise use K&R conventions. * * If we're running on a CRAY (8-byte ints and floats), conversions will * be done as needed. */ /* * Updates: * * April 13, 1995, brianp * added cray_to_ieee and iee_to_cray array conversion functions. * fixed potential cray bug in write_float4_array function. * */ /**********************************************************************/ /****** Byte Flipping *****/ /**********************************************************************/ #define FLIP4( n ) ( (n & 0xff000000) >> 24 \ | (n & 0x00ff0000) >> 8 \ | (n & 0x0000ff00) << 8 \ | (n & 0x000000ff) << 24 ) #define FLIP2( n ) (((unsigned short) (n & 0xff00)) >> 8 | (n & 0x00ff) << 8) /* * Flip the order of the 4 bytes in an array of 4-byte words. */ void flip4( const unsigned int *src, unsigned int *dest, int n ) { int i; for (i=0;i> 48)-16258) << 55)) + /* exp */ (((*f & 0x00007fffff000000) + ((*f & 0x0000000000800000) << 1)) << 8)); /* mantissa */ } else *t = *f; } #define C_TO_IF( T, F ) \ if (F != 0) { \ T = (((F & 0x8000000000000000) | \ ((((F & 0x7fff000000000000) >> 48)-16258) << 55)) + \ (((F & 0x00007fffff000000) + \ ((F & 0x0000000000800000) << 1)) << 8)); \ } \ else { \ T = F; \ } /* Cray to IEEE single precision */ static void c_to_if1( long *t, const long *f) { /* * Clamp values to [-1e35, -1e-35] U {0} U [1e-35, 1e+35] * to prevent overflows and underflows that can occur when converting * from 8 byte to 4 byte floats. */ const float* fp = (const float*) f; float x = *fp; if ( x != 0 ) { #define SIGN(x) ((x) < 0 ? -1 : 1) #define ABST(x) ((x) < 0 ? -(x) : (x)) const float huge = 1e35; const float tiny = 1e-35; printf("ABST( x )\n"); if ( ABST( x ) < tiny ) x = tiny * SIGN( x ); else if ( ABST( x ) > huge ) x = huge * SIGN( x ); printf("huge\n"); f = (const long*) &x; printf("f = \n"); #undef SIGN #undef ABST } if (*f != 0){ printf("8000000000000000 \n"); *t = (((*f & 0x8000000000000000) | /* sign bit */ ((((*f & 0x7fff000000000000) >> 48)-16258) << 55)) + /* exp */ (((*f & 0x00007fffff000000) + ((*f & 0x0000000000800000) << 1)) << 8)); /* mantissa */ printf("0x00000 \n"); } else *t = *f; } #define C_TO_IF( T, F ) \ if (F != 0) { \ T = (((F & 0x8000000000000000) | \ ((((F & 0x7fff000000000000) >> 48)-16258) << 55)) + \ (((F & 0x00007fffff000000) + \ ((F & 0x0000000000800000) << 1)) << 8)); \ } \ else { \ T = F; \ } /* IEEE single precison to Cray */ static void if_to_c( long *t, const long *f) { if (*f != 0) { *t = (((*f & 0x8000000000000000) | ((*f & 0x7f80000000000000) >> 7) + (16258 << 48)) | (((*f & 0x007fffff00000000) >> 8) | (0x0000800000000000))); if ((*f << 1) == 0) *t = 0; } else *t = *f; } /* T and F must be longs! */ #define IF_TO_C( T, F ) \ if (F != 0) { \ T = (((F & 0x8000000000000000) | \ ((F & 0x7f80000000000000) >> 7) + \ (16258 << 48)) | \ (((F & 0x007fffff00000000) >> 8) | (0x0000800000000000))); \ if ((F << 1) == 0) T = 0; \ } \ else { \ T = F; \ } /* * Convert an array of Cray 8-byte floats to an array of IEEE 4-byte floats. */ void cray_to_ieee_array( long *dest, const float *source, int n ) { long *dst; const long *src; long tmp1, tmp2; int i; dst = dest; src = (const long *) source; for (i=0;i= n) { tmp2 = 0; } else { c_to_if( &tmp2, &src[i+1] ); } *dst = (tmp1 & 0xffffffff00000000) | (tmp2 >> 32); dst++; } } /* * Convert an array of IEEE 4-byte floats to an array of 8-byte Cray floats. */ void ieee_to_cray_array( float *dest, const long *source, int n ) { long *dst; const long *src; int i; long ieee; src = source; dst = (long *) dest; for (i=0;i> 8) & 0xff; buffer[i*2+1] = iarray[i] & 0xff; } nwritten = write( f, buffer, 2*n ); free( buffer ); if (nwritten<=0) return 0; else return nwritten/2; #else int nwritten; #ifdef LITTLE flip2( iarray, (unsigned short *) iarray, n ); #endif nwritten = write( f, iarray, 2*n ); #ifdef LITTLE flip2( iarray, (unsigned short *) iarray, n ); #endif if (nwritten<=0) return 0; else return nwritten/2; #endif } /* * Write a 4-byte integer. *Input: f - the file descriptor * i - the integer * Return: 1 = ok, 0 = error */ int write_int4( int f, int i ) { #ifdef _CRAY i = i << 32; return write( f, &i, 4 ) > 0; #else # ifdef LITTLE i = FLIP4( i ); # endif return write( f, &i, 4 ) > 0; #endif } /* * Write an array of 4-byte integers. * Input: f - the file descriptor * i - the array of ints * n - the number of ints in array * Return: number of integers written. */ int write_int4_array( int f, const int *i, int n ) { #ifdef _CRAY int j, nwritten; char *buf, *b, *ptr; b = buf = (char *) malloc( n*4 + 8 ); if (!b) return 0; ptr = (char *) i; for (j=0;j 0; #else # ifdef LITTLE float y; unsigned int *iptr = (unsigned int *) &y, temp; y = (float) x; temp = FLIP4( *iptr ); return write( f, &temp, 4 ) > 0; # else float y; y = (float) x; return write( f, &y, 4 ) > 0; # endif #endif } /* * Write an array of 4-byte IEEE floating point numbers. * Input: f - the file descriptor * x - the array of floats * n - number of floats in array * Return: number of float written. */ int write_float4_array( int f, const float *x, int n ) { #ifdef _CRAY /* convert cray floats to IEEE and put into buffer */ int nwritten; long *buffer; buffer = (long *) malloc( n*4 + 8 ); if (!buffer) return 0; cray_to_ieee_array( buffer, x, n ); nwritten = write( f, buffer, 4*n ); free( buffer ); if (nwritten<=0) return 0; else return nwritten / 4; #else # ifdef LITTLE int nwritten; flip4( (const unsigned int *) x, (unsigned int *) x, n ); nwritten = write( f, x, 4*n ); flip4( (const unsigned int *) x, (unsigned int *) x, n ); if (nwritten<=0) return 0; else return nwritten / 4; # else return write( f, x, 4*n ) / 4; # endif #endif } /* * Write a block of memory. * Input: f - file descriptor * data - address of first byte * elements - number of elements to write * elsize - size of each element to write (1, 2 or 4) * Return: number of elements written */ int write_block( int f, const void *data, int elements, int elsize ) { if (elsize==1) { return write( f, data, elements ); } else if (elsize==2) { #ifdef LITTLE int n; flip2( (const unsigned short *) data, (unsigned short *) data, elements); n = write( f, data, elements*2 ) / 2; flip2( (const unsigned short *) data, (unsigned short *) data, elements); return n; #else return write( f, data, elements*2 ) / 2; #endif } else if (elsize==4) { #ifdef LITTLE int n; flip4( (const unsigned int *) data, (unsigned int *) data, elements ); n = write( f, data, elements*4 ) / 4; flip4( (const unsigned int *) data, (unsigned int *) data, elements ); return n; #else return write( f, data, elements*4 ) / 4; #endif } else { printf("Fatal error in write_block(): bad elsize (%d)\n", elsize ); abort(); } return 0; } '\eof' echo CREATE_V5D43.H cat > v5d43.h << '\eof' /* $Id: vis5d.h,v 1.8 1997/01/02 17:25:29 billh Exp $ */ /* $Id: v5d.h,v 1.16 1996/08/23 13:03:12 billh Exp $ */ /* Vis5D version 5.0 */ /* Vis5D version 4.3 */ /* Vis5D version 4.2 */ #ifndef V5D_H #define V5D_H /* * A numeric version number which we can test for in utility programs which * use the v5d functions. For example, we can do tests like this: * #if V5D_VERSION > 42 * do something * #else * do something else * #endif * * If V5D_VERSION is not defined, then its value is considered to be zero. */ #define V5D_VERSION 42 /* * Define our own 1 and 2-byte data types. We use these names to avoid * collisions with types defined by the OS include files. */ typedef unsigned char V5Dubyte; /* Must be 1 byte, except for cray */ typedef unsigned short V5Dushort; /* Must be 2 byte, except for cray */ #define MISSING 1.0e35 #define IS_MISSING(X) ( (X) >= 1.0e30 ) /* Limits on 5-D grid size: (must match those in v5df.h!!!) */ #define MAXVARS 15 #define MAXTIMES 100 #ifdef MCIDAS_SIDECAR #define MAXROWS 300 #define MAXCOLUMNS 600 #else #define MAXROWS 300 #define MAXCOLUMNS 600 #endif #define MAXLEVELS 300 /************************************************************************/ /*** ***/ /*** Functions for writing v5d files. See README file for details. ***/ /*** These are the functions user's will want for writing file ***/ /*** converters, etc. ***/ /*** ***/ /************************************************************************/ extern int v5dCreate( const char *name, int numtimes, int numvars, int nr, int nc, const int nl[], const char varname[MAXVARS][10], const int timestamp[], const int datestamp[], int compressmode, int projection, const float proj_args[], int vertical, const float vert_args[] ); extern int v5dWrite( int time, int var, const float data[] ); extern int v5dClose( void ); extern int v5dSetLowLev( int lowlev[] ); extern int v5dSetUnits( int var, const char *units ); /************************************************************************/ /*** ***/ /*** Definition of v5d struct and function prototypes. ***/ /*** These functions are used by vis5d and advanced v5d utilities. ***/ /*** ***/ /************************************************************************/ #define MAXPROJARGS 100 #define MAXVERTARGS (MAXLEVELS+1) /* * This struct describes the structure of a .v5d file. */ typedef struct { /* PUBLIC (user can freely read, sometimes write, these fields) */ int NumTimes; /* Number of time steps */ int NumVars; /* Number of variables */ int Nr; /* Number of rows */ int Nc; /* Number of columns */ int Nl[MAXVARS]; /* Number of levels per variable */ int LowLev[MAXVARS]; /* Lowest level per variable */ char VarName[MAXVARS][10]; /* 9-character variable names */ char Units[MAXVARS][20]; /* 19-character units for variables */ int TimeStamp[MAXTIMES]; /* Time in HHMMSS format */ int DateStamp[MAXTIMES]; /* Date in YYDDD format */ float MinVal[MAXVARS]; /* Minimum variable data values */ float MaxVal[MAXVARS]; /* Maximum variable data values */ /* This info is used for external function computation */ short McFile[MAXTIMES][MAXVARS];/* McIDAS file number in 1..9999 */ short McGrid[MAXTIMES][MAXVARS];/* McIDAS grid number in 1..? */ int VerticalSystem; /* Which vertical coordinate system */ float VertArgs[MAXVERTARGS]; /* Vert. Coord. Sys. arguments... */ /* IF VerticalSystem==0 THEN -- Linear scale, equally-spaced levels in generic units VertArgs[0] = Height of bottom-most grid level in generic units VertArgs[1] = Increment between levels in generic units ELSE IF VerticalSystem==1 THEN -- Linear scale, equally-spaced levels in km VertArgs[0] = Height of bottom grid level in km VertArgs[1] = Increment between levels in km ELSE IF VerticalSystem==2 THEN -- Linear scale, Unequally spaced levels in km VertArgs[0] = Height of grid level 0 (bottom) in km ... ... VertArgs[n] = Height of grid level n in km ELSE IF VerticalSystem==3 THEN -- Linear scale, Unequally spaced levels in mb VertArgs[0] = Pressure of grid level 0 (bottom) in mb ... ... VertArgs[n] = Pressure of grid level n in mb ENDIF */ int Projection; /* Which map projection */ float ProjArgs[MAXPROJARGS]; /* Map projection arguments... */ /* IF Projection==0 THEN -- Rectilinear grid, generic units ProjArgs[0] = North bound, Y coordinate of grid row 0 ProjArgs[1] = West bound, X coordiante of grid column 0 ProjArgs[2] = Increment between rows ProjArgs[3] = Increment between colums NOTES: X coordinates increase to the right, Y increase upward. NOTES: Coordinate system is right-handed. ELSE IF Projection==1 THEN -- Cylindrical equidistant (Old VIS-5D) -- Rectilinear grid in lat/lon ProjArgs[0] = Latitude of grid row 0, north bound, in degrees ProjArgs[1] = Longitude of grid column 0, west bound, in deg. ProjArgs[2] = Increment between rows in degrees ProjArgs[3] = Increment between rows in degrees NOTES: Coordinates (degrees) increase to the left and upward. ELSE IF Projection==2 THEN -- Lambert conformal ProjArgs[0] = Standared Latitude 1 of conic projection ProjArgs[1] = Standared Latitude 2 of conic projection ProjArgs[2] = Row of North/South pole ProjArgs[3] = Column of North/South pole ProjArgs[4] = Longitude which is parallel to columns ProjArgs[5] = Increment between grid columns in km ELSE IF Projection==3 THEN -- Polar Stereographic ProjArgs[0] = Latitude of center of projection ProjArgs[1] = Longitude of center of projection ProjArgs[2] = Grid row of center of projection ProjArgs[3] = Grid column of center of projection ProjArgs[4] = Increment between grid columns at center in km ELSE IF Projection==4 THEN -- Rotated ProjArgs[0] = Latitude on rotated globe of grid row 0 ProjArgs[1] = Longitude on rotated globe of grid column 0 ProjArgs[2] = Degrees of latitude on rotated globe between grid rows ProjArgs[3] = Degrees of longitude on rotated globe between grid columns ProjArgs[4] = Earth latitude of (0, 0) on rotated globe ProjArgs[5] = Earth longitude of (0, 0) on rotated globe ProjArgs[6] = Clockwise rotation of rotated globe in degrees ENDIF */ int CompressMode; /* 1, 2 or 4 = # bytes per grid point */ char FileVersion[10]; /* 9-character version number */ /* PRIVATE (not to be touched by user code) */ unsigned int FileFormat; /* COMP5D file version or 0 if .v5d */ int FileDesc; /* Unix file descriptor */ char Mode; /* 'r' = read, 'w' = write */ int CurPos; /* current position of file pointer */ int FirstGridPos; /* position of first grid in file */ int GridSize[MAXVARS]; /* size of each grid */ int SumGridSizes; /* sum of GridSize[0..NumVars-1] */ } v5dstruct; extern float pressure_to_height( float pressure); extern float height_to_pressure( float height ); extern int v5dYYDDDtoDays( int yyddd ); extern int v5dHHMMSStoSeconds( int hhmmss ); extern int v5dDaysToYYDDD( int days ); extern int v5dSecondsToHHMMSS( int seconds ); extern void v5dPrintStruct( const v5dstruct *v ); extern v5dstruct *v5dNewStruct( void ); extern void v5dFreeStruct( v5dstruct* v ); extern void v5dInitStruct( v5dstruct *v ); extern int v5dVerifyStruct( const v5dstruct *v ); extern void v5dCompressGrid( int nr, int nc, int nl, int compressmode, const float data[], void *compdata, float ga[], float gb[], float *minval, float *maxval ); extern int v5dSizeofGrid( const v5dstruct *v, int time, int var ); extern v5dstruct *v5dOpenFile( const char *filename, v5dstruct *v ); extern int v5dCreateFile( const char *filename, v5dstruct *v ); extern v5dstruct *v5dUpdateFile( const char *filename, v5dstruct *v ); extern int v5dCloseFile( v5dstruct *v ); extern int v5dWriteCompressedGrid( const v5dstruct *v, int time, int var, const float *ga, const float *gb, const void *compdata ); extern int v5dWriteGrid( v5dstruct *v, int time, int var, const float data[] ); #endif /* * Functions to do binary I/O of floats, ints, etc. with byte swapping * as needed. */ #ifndef BINIO_H #define BINIO_H /* Include files which define SEEK_SET, O_RD_ONLY, etc. */ /* and prototype open(), close(), lseek(), etc. */ #include #include extern void flip4( const unsigned int *src, unsigned int *dest, int n ); extern void flip2( const unsigned short *src, unsigned short *dest, int n ); #ifdef _CRAY extern void cray_to_ieee_array( long *dest, const float *source, int n ); extern void ieee_to_cray_array( float *dest, const long *source, int n ); #endif /**********************************************************************/ /***** Write Functions *****/ /**********************************************************************/ extern int write_bytes( int f, const void *b, int n ); extern int write_int2_array( int f, const short *iarray, int n ); extern int write_uint2_array( int f, const unsigned short *iarray, int n ); extern int write_int4( int f, int i ); extern int write_int4_array( int f, const int *iarray, int n ); extern int write_float4( int f, float x ); extern int write_float4_array( int f, const float *x, int n ); extern int write_block( int f, const void *data, int elements, int elsize ); #endif /* Vis5D version 4.3 * This configuration file contains options which can be safely * changed by the user. */ #ifndef VIS5D_H #define VIS5D_H /* * Amount of physical RAM in megabytes: * vis5d normally uses a bounded amount of memory to avoid swapping. * When the limit is reached, the least-recently-viewed graphics will * be deallocated. If MBS is set to 0, however, vis5d will use ordinary * malloc/free and not deallocate graphics (ok for systems with a lot * of memory (>=128MB)). */ #define MBS 32 /* Default topography file: */ #define TOPOFILE "EARTH.TOPO" /* Default map lines files: */ #define WORLDFILE "OUTLSUPW" #define USAFILE "OUTLUSAM" /* Default filename of Tcl startup commands: */ #define TCL_STARTUP_FILE "vis5d.tcl" /* Default directory to search for user functions: */ #define FUNCTION_PATH "userfuncs" /* Default animation rate in milliseconds: */ #define ANIMRATE 100 /* Default scale and exponent values for logrithmic vertical coordinate system: */ #define DEFAULT_LOG_SCALE 1012.5 #define DEFAULT_LOG_EXP -7.2 /*** USERS: DON'T CHANGE ANYTHING BEYOND THIS POINT ***/ /* * Define BIG_GFX to allow larger isosurfaces, contour slices, etc. if * there's enough memory. #if MBS==0 || MBS>=128 # define BIG_GFX #endif */ #define BIG_GFX /* * Shared by code above and below API: */ #define MAX_LABEL 1000 #define MAX_FUNCS 100 #endif '\eof' ############################################################################# #### #### #### C O M P I L E A N D L I N K P R G R A M #### #### #### ############################################################################# echo NOW_COMPILE_SOURCE_CODE date ######################### if ($MACHINE == WRK) then gcc -c -DLITTLE -DUNDERSCORE v5d43.c -o v5d43.o # old Eulag #g77 -g -O3 src.F v5d43.o -lX11 -lm -L/usr/X11R6/lib #ncargf77 -m32 -O2 src.F v5d43.o #ncargf77 src.F setenv LM_LICENSE_FILE "7496@licenseb.ucar.edu:7496@licensea.ucar.edu" /usr/local/compilers/pgi/linux86-64-nollvm/20.4/bin/pgf90 -r8 src.F #pgf90 -r8 src.F rm cfftpack.f c*gks msg.* param.* v5d43.* vel*gks aerosol1size.inc endif echo Done. echo Eulag executable file: a.out exit